split the Exp type to Tree and Expr

1 files changed, 237 insertions, 257 deletions

diff --git a/src-3.0/GFI.hs b/src-3.0/GFI.hs
index 27a825c12..8bcc7df14 100644
--- a/src-3.0/GFI.hs
+++ b/src-3.0/GFI.hs
@@ -1,257 +1,237 @@
-module GFI (mainGFI) where

-

-import GF.Command.Interpreter

-import GF.Command.Importing

-import GF.Command.Commands

-import GF.Command.Abstract

-import GF.Command.Parse

-import GF.Data.ErrM

-import GF.Grammar.API  -- for cc command

-import GF.Infra.UseIO

-import GF.Infra.Option

-import GF.System.Readline

-

-import PGF

-import PGF.Data

-import PGF.Macros

-import PGF.ExprSyntax (readExp)

-

-import Data.Char

-import Data.List(isPrefixOf)

-import qualified Data.Map as Map

-import qualified Text.ParserCombinators.ReadP as RP

-import System.Cmd

-import System.CPUTime

-import Control.Exception

-

-import Data.Version

-import Paths_gf

-

-mainGFI :: Options -> [FilePath] -> IO ()

-mainGFI opts files = do

-  putStrLn welcome

-  gfenv <- importInEnv emptyGFEnv opts files

-  loop opts gfenv

-  return ()

-

-loop :: Options -> GFEnv -> IO GFEnv

-loop opts gfenv0 = do

-  let env = commandenv gfenv0

-  let sgr = sourcegrammar gfenv0

-  setCompletionFunction (Just (wordCompletion (commandenv gfenv0)))

-  s <- fetchCommand (prompt env)

-  let gfenv = gfenv0 {history = s : history gfenv0}

-  let loopNewCPU gfenv' = do 

-        cpu' <- getCPUTime

-        putStrLnFlush (show ((cpu' - cputime gfenv') `div` 1000000000) ++ " msec")

-        loop opts $ gfenv' {cputime = cpu'}

-  let 

-    pwords = case words s of

-      w:ws -> getCommandOp w :ws

-      ws -> ws

-  case pwords of

-  -- special commands, requiring source grammar in env

-    "!":ws -> do

-       system $ unwords ws

-       loopNewCPU gfenv

-    "cc":ws -> do

-       let 

-         (style,term) = case ws of 

-           ('-':w):ws2 -> (pTermPrintStyle w, ws2)

-           _ -> (TermPrintDefault, ws)

-       case pTerm (unwords term) >>= checkTerm sgr >>= computeTerm sgr of   ---- pipe!

-         Ok  x -> putStrLnFlush (showTerm style x)

-         Bad s -> putStrLnFlush s

-       loopNewCPU gfenv

-    "i":args -> do

-        gfenv' <- case parseOptions args of

-          Ok (opts',files) -> importInEnv gfenv (addOptions opts opts') files

-          Bad err -> do 

-            putStrLn $ "Command parse error: " ++ err

-            return gfenv

-        loopNewCPU gfenv'

-

-  -- other special commands, working on GFEnv

-    "e":_ -> loopNewCPU $ gfenv {

-       commandenv=emptyCommandEnv, sourcegrammar = emptyGrammar

-       }

-

-    "dc":f:ws -> do

-       case readCommandLine (unwords ws) of

-         Just comm -> loopNewCPU $ gfenv {

-           commandenv = env {

-             commandmacros = Map.insert f comm (commandmacros env)

-             }

-           }

-         _ -> putStrLnFlush "command definition not parsed" >> loopNewCPU gfenv

-

-    "dt":f:"<":ws -> do

-       case readCommandLine (unwords ws) of

-         Just [pip] -> do

-           ip <- interpretPipe env pip

-           case ip of

-             (exp:es,_) -> do 

-               if null es then return () else

-                 putStrLnFlush $ "ambiguous definition, selected the first one"

-               loopNewCPU $ gfenv {

-                 commandenv = env {

-                   expmacros = Map.insert f exp (expmacros env)

-                   }

-                 }

-             _ -> putStrLnFlush "no value given in definition" >> loopNewCPU gfenv

-         _ -> putStrLnFlush "value definition not parsed" >> loopNewCPU gfenv

-

-    "dt":f:ws -> do

-       case readExp (unwords ws) of

-         Just exp -> loopNewCPU $ gfenv {

-           commandenv = env {

-             expmacros = Map.insert f exp (expmacros env)

-             }

-           }

-         _ -> putStrLnFlush "value definition not parsed" >> loopNewCPU gfenv

-

-    "ph":_ -> mapM_ putStrLnFlush (reverse (history gfenv0)) >> loopNewCPU gfenv

-    "q":_  -> putStrLnFlush "See you." >> return gfenv

-

-  -- ordinary commands, working on CommandEnv

-    _ -> do

-      interpretCommandLine env s

-      loopNewCPU gfenv

-

-importInEnv :: GFEnv -> Options -> [FilePath] -> IO GFEnv

-importInEnv gfenv opts files

-    | flag optRetainResource opts =

-        do src <- importSource (sourcegrammar gfenv) opts files

-           return $ gfenv {sourcegrammar = src}

-    | otherwise =

-        do let opts' = addOptions (setOptimization OptCSE False) opts

-               cenv0 = commandenv gfenv

-               pgf0  = multigrammar cenv0 

-           pgf1 <- importGrammar pgf0 opts' files

-           putStrLnFlush $ unwords $ "\nLanguages:" : languages pgf1

-           return $ gfenv { commandenv = (mkCommandEnv pgf1) 

-             {commandmacros = commandmacros cenv0, expmacros = expmacros cenv0}}

----           return $ gfenv { commandenv = cenv0 {multigrammar = pgf1} } -- WHY NOT

-

-welcome = unlines [

-  "                              ",

-  "         *  *  *              ",

-  "      *           *           ",

-  "    *               *         ",

-  "   *                          ",

-  "   *                          ",

-  "   *        * * * * * *       ",

-  "   *        *         *       ",

-  "    *       * * * *  *        ",

-  "      *     *      *          ",

-  "         *  *  *              ",

-  "                              ",

-  "This is GF version "++showVersion version++". ",

-  "Some things may work.         "

-  ]

-

-prompt env = absname ++ "> " where

-  absname = case abstractName (multigrammar env) of

-    "_" -> ""  --- created by new Ident handling 22/5/2008

-    n   -> n

-

-data GFEnv = GFEnv {

-  sourcegrammar :: Grammar, -- gfo grammar -retain

-  commandenv :: CommandEnv,

-  history    :: [String],

-  cputime    :: Integer

-  }

-

-emptyGFEnv :: GFEnv

-emptyGFEnv = GFEnv emptyGrammar (mkCommandEnv emptyPGF) [] 0

-

-

-wordCompletion cmdEnv line prefix p =

-  case wc_type (take p line) of

-    CmplCmd pref

-      -> ret ' ' [name | name <- Map.keys (commands cmdEnv), isPrefixOf pref name]

-    CmplStr (Just (Command _ opts _)) s

-      -> do mb_state0 <- try (evaluate (initState pgf (optLang opts) (optCat  opts)))

-            case mb_state0 of

-              Right state0 -> let ws     = words (take (length s - length prefix) s)

-                                  state  = foldl nextState state0 ws

-                                  compls = getCompletions state prefix

-                              in ret ' ' (Map.keys compls)

-              Left  _      -> ret ' ' []

-    CmplOpt (Just (Command n _ _)) pref

-      -> case Map.lookup n (commands cmdEnv) of

-           Just inf -> do let flg_compls = ['-':flg | (flg,_) <- flags   inf, isPrefixOf pref flg]

-                              opt_compls = ['-':opt | (opt,_) <- options inf, isPrefixOf pref opt]

-                          ret (if null flg_compls then ' ' else '=')

-                              (flg_compls++opt_compls)

-           Nothing  -> ret ' ' []

-    CmplIdent (Just (Command "i" _ _)) _        -- HACK: file name completion for command i

-      -> filenameCompletionFunction prefix

-    CmplIdent _ pref

-      -> do mb_abs <- try (evaluate (abstract pgf))

-            case mb_abs of

-              Right abs -> ret ' ' [name | cid <- Map.keys (funs abs), let name = prCId cid, isPrefixOf pref name]

-              Left  _   -> ret ' ' []

-    _ -> ret ' ' []

-  where

-    pgf = multigrammar cmdEnv

-    optLang opts = valIdOpts "lang" (head (languages pgf)) opts

-    optCat  opts = valIdOpts "cat"  (lookStartCat pgf)     opts

-    

-    ret c [x] = return [x++[c]]

-    ret _ xs  = return xs

-

-

-data CompletionType

-  = CmplCmd                   Ident

-  | CmplStr   (Maybe Command) String

-  | CmplOpt   (Maybe Command) Ident

-  | CmplIdent (Maybe Command) Ident

-  deriving Show

-

-wc_type :: String -> CompletionType

-wc_type = cmd_name

-  where

-    cmd_name cs =

-      let cs1 = dropWhile isSpace cs

-      in go cs1 cs1

-      where

-        go x []       = CmplCmd x

-        go x (c:cs)

-          | isIdent c = go x cs

-          | otherwise = cmd x cs

-

-    cmd x []       = ret CmplIdent x "" 0

-    cmd _ ('|':cs) = cmd_name cs

-    cmd _ (';':cs) = cmd_name cs

-    cmd x ('"':cs) = str x cs cs

-    cmd x ('-':cs) = option x cs cs

-    cmd x (c  :cs)

-      | isIdent c  = ident x (c:cs) cs

-      | otherwise  = cmd x cs

-

-    option x y []     = ret CmplOpt x y 1

-    option x y (c:cs)

-      | isIdent c     = option x y cs

-      | otherwise     = cmd x cs

-

-    ident x y []     = ret CmplIdent x y 0

-    ident x y (c:cs)

-      | isIdent c    = ident x y cs

-      | otherwise    = cmd x cs

-

-    str x y []          = ret CmplStr x y 1

-    str x y ('\"':cs)   = cmd x cs

-    str x y ('\\':c:cs) = str x y cs

-    str x y (c:cs)      = str x y cs

-

-    ret f x y d = f cmd y

-      where

-        x1 = take (length x - length y - d) x

-        x2 = takeWhile (\c -> isIdent c || isSpace c || c == '-' || c == '=') x1

-        

-        cmd = case [x | (x,cs) <- RP.readP_to_S pCommand x2, all isSpace cs] of

-	        [x] -> Just x

-                _   -> Nothing

-

-    isIdent c = c == '_' || c == '\'' || isAlphaNum c

+module GFI (mainGFI) where
+
+import GF.Command.Interpreter
+import GF.Command.Importing
+import GF.Command.Commands
+import GF.Command.Abstract
+import GF.Command.Parse
+import GF.Data.ErrM
+import GF.Grammar.API  -- for cc command
+import GF.Infra.UseIO
+import GF.Infra.Option
+import GF.System.Readline
+
+import PGF
+import PGF.Data
+import PGF.Macros
+import PGF.Expr (readTree)
+
+import Data.Char
+import Data.List(isPrefixOf)
+import qualified Data.Map as Map
+import qualified Text.ParserCombinators.ReadP as RP
+import System.Cmd
+import System.CPUTime
+import Control.Exception
+
+import Data.Version
+import Paths_gf
+
+mainGFI :: Options -> [FilePath] -> IO ()
+mainGFI opts files = do
+  putStrLn welcome
+  gfenv <- importInEnv emptyGFEnv opts files
+  loop opts gfenv
+  return ()
+
+loop :: Options -> GFEnv -> IO GFEnv
+loop opts gfenv0 = do
+  let env = commandenv gfenv0
+  let sgr = sourcegrammar gfenv0
+  setCompletionFunction (Just (wordCompletion (commandenv gfenv0)))
+  s <- fetchCommand (prompt env)
+  let gfenv = gfenv0 {history = s : history gfenv0}
+  let loopNewCPU gfenv' = do 
+        cpu' <- getCPUTime
+        putStrLnFlush (show ((cpu' - cputime gfenv') `div` 1000000000) ++ " msec")
+        loop opts $ gfenv' {cputime = cpu'}
+  let 
+    pwords = case words s of
+      w:ws -> getCommandOp w :ws
+      ws -> ws
+  case pwords of
+  -- special commands, requiring source grammar in env
+    "!":ws -> do
+       system $ unwords ws
+       loopNewCPU gfenv
+    "cc":ws -> do
+       let 
+         (style,term) = case ws of 
+           ('-':w):ws2 -> (pTermPrintStyle w, ws2)
+           _ -> (TermPrintDefault, ws)
+       case pTerm (unwords term) >>= checkTerm sgr >>= computeTerm sgr of   ---- pipe!
+         Ok  x -> putStrLn (showTerm style x)
+         Bad s -> putStrLn s
+       loopNewCPU gfenv
+    "i":args -> do
+        gfenv' <- case parseOptions args of
+                    Ok (opts',files) -> importInEnv gfenv (addOptions opts opts') files
+                    Bad err -> do putStrLn $ "Command parse error: " ++ err
+                                  return gfenv
+        loopNewCPU gfenv'
+
+  -- other special commands, working on GFEnv
+    "e":_ -> loopNewCPU $ gfenv {
+       commandenv=emptyCommandEnv, sourcegrammar = emptyGrammar
+       }
+
+    "dc":f:ws -> do
+       case readCommandLine (unwords ws) of
+         Just comm -> loopNewCPU $ gfenv {
+           commandenv = env {
+             commandmacros = Map.insert f comm (commandmacros env)
+             }
+           }
+         _ -> putStrLn "command definition not parsed" >> loopNewCPU gfenv
+
+    "dt":f:ws -> do
+       case readTree (unwords ws) of
+         Just exp -> loopNewCPU $ gfenv {
+           commandenv = env {
+             expmacros = Map.insert f exp (expmacros env)
+             }
+           }
+         _ -> putStrLn "value definition not parsed" >> loopNewCPU gfenv
+
+    "ph":_ -> mapM_ putStrLn (reverse (history gfenv0)) >> loopNewCPU gfenv
+    "q":_  -> putStrLn "See you." >> return gfenv
+
+  -- ordinary commands, working on CommandEnv
+    _ -> do
+      interpretCommandLine env s
+      loopNewCPU gfenv
+
+importInEnv :: GFEnv -> Options -> [FilePath] -> IO GFEnv
+importInEnv gfenv opts files
+    | flag optRetainResource opts =
+        do src <- importSource (sourcegrammar gfenv) opts files
+           return $ gfenv {sourcegrammar = src}
+    | otherwise =
+        do let opts' = addOptions (setOptimization OptCSE False) opts
+               pgf0 = multigrammar (commandenv gfenv)
+           pgf1 <- importGrammar pgf0 opts' files
+           putStrLnFlush $ unwords $ "\nLanguages:" : languages pgf1
+           return $ gfenv { commandenv = mkCommandEnv pgf1 }
+
+welcome = unlines [
+  "                              ",
+  "         *  *  *              ",
+  "      *           *           ",
+  "    *               *         ",
+  "   *                          ",
+  "   *                          ",
+  "   *        * * * * * *       ",
+  "   *        *         *       ",
+  "    *       * * * *  *        ",
+  "      *     *      *          ",
+  "         *  *  *              ",
+  "                              ",
+  "This is GF version "++showVersion version++". ",
+  "Some things may work.         "
+  ]
+
+prompt env = absname ++ "> " where
+  absname = case abstractName (multigrammar env) of
+    "_" -> ""  --- created by new Ident handling 22/5/2008
+    n   -> n
+
+data GFEnv = GFEnv {
+  sourcegrammar :: Grammar, -- gfo grammar -retain
+  commandenv :: CommandEnv,
+  history    :: [String],
+  cputime    :: Integer
+  }
+
+emptyGFEnv :: GFEnv
+emptyGFEnv = GFEnv emptyGrammar (mkCommandEnv emptyPGF) [] 0
+
+
+wordCompletion cmdEnv line prefix p =
+  case wc_type (take p line) of
+    CmplCmd pref
+      -> ret ' ' [name | name <- Map.keys (commands cmdEnv), isPrefixOf pref name]
+    CmplStr (Just (Command _ opts _)) s
+      -> do mb_state0 <- try (evaluate (initState pgf (optLang opts) (optCat  opts)))
+            case mb_state0 of
+              Right state0 -> let ws     = words (take (length s - length prefix) s)
+                                  state  = foldl nextState state0 ws
+                                  compls = getCompletions state prefix
+                              in ret ' ' (Map.keys compls)
+              Left  _      -> ret ' ' []
+    CmplOpt (Just (Command n _ _)) pref
+      -> case Map.lookup n (commands cmdEnv) of
+           Just inf -> do let flg_compls = ['-':flg | (flg,_) <- flags   inf, isPrefixOf pref flg]
+                              opt_compls = ['-':opt | (opt,_) <- options inf, isPrefixOf pref opt]
+                          ret (if null flg_compls then ' ' else '=')
+                              (flg_compls++opt_compls)
+           Nothing  -> ret ' ' []
+    CmplIdent (Just (Command "i" _ _)) _        -- HACK: file name completion for command i
+      -> filenameCompletionFunction prefix
+    CmplIdent _ pref
+      -> do mb_abs <- try (evaluate (abstract pgf))
+            case mb_abs of
+              Right abs -> ret ' ' [name | cid <- Map.keys (funs abs), let name = prCId cid, isPrefixOf pref name]
+              Left  _   -> ret ' ' []
+    _ -> ret ' ' []
+  where
+    pgf = multigrammar cmdEnv
+    optLang opts = valIdOpts "lang" (head (languages pgf)) opts
+    optCat  opts = valIdOpts "cat"  (lookStartCat pgf)     opts
+    
+    ret c [x] = return [x++[c]]
+    ret _ xs  = return xs
+
+
+data CompletionType
+  = CmplCmd                   Ident
+  | CmplStr   (Maybe Command) String
+  | CmplOpt   (Maybe Command) Ident
+  | CmplIdent (Maybe Command) Ident
+  deriving Show
+
+wc_type :: String -> CompletionType
+wc_type = cmd_name
+  where
+    cmd_name cs =
+      let cs1 = dropWhile isSpace cs
+      in go cs1 cs1
+      where
+        go x []       = CmplCmd x
+        go x (c:cs)
+          | isIdent c = go x cs
+          | otherwise = cmd x cs
+
+    cmd x []       = ret CmplIdent x "" 0
+    cmd _ ('|':cs) = cmd_name cs
+    cmd _ (';':cs) = cmd_name cs
+    cmd x ('"':cs) = str x cs cs
+    cmd x ('-':cs) = option x cs cs
+    cmd x (c  :cs)
+      | isIdent c  = ident x (c:cs) cs
+      | otherwise  = cmd x cs
+
+    option x y []     = ret CmplOpt x y 1
+    option x y (c:cs)
+      | isIdent c     = option x y cs
+      | otherwise     = cmd x cs
+
+    ident x y []     = ret CmplIdent x y 0
+    ident x y (c:cs)
+      | isIdent c    = ident x y cs
+      | otherwise    = cmd x cs
+
+    str x y []          = ret CmplStr x y 1
+    str x y ('\"':cs)   = cmd x cs
+    str x y ('\\':c:cs) = str x y cs
+    str x y (c:cs)      = str x y cs
+
+    ret f x y d = f cmd y
+      where
+        x1 = take (length x - length y - d) x
+        x2 = takeWhile (\c -> isIdent c || isSpace c || c == '-' || c == '=') x1
+        
+        cmd = case [x | (x,cs) <- RP.readP_to_S pCommand x2, all isSpace cs] of
+	        [x] -> Just x
+                _   -> Nothing
+
+    isIdent c = c == '_' || c == '\'' || isAlphaNum c