1 files changed, 121 insertions, 0 deletions
diff --git a/src/GF/Command/Interpreter.hs b/src/GF/Command/Interpreter.hs
new file mode 100644
index 000000000..e1a06a205
--- /dev/null
+++ b/src/GF/Command/Interpreter.hs
@@ -0,0 +1,121 @@
+module GF.Command.Interpreter (
+  CommandEnv (..),
+  mkCommandEnv,
+  emptyCommandEnv,
+  interpretCommandLine,
+  interpretPipe,
+  getCommandOp
+  ) where
+
+import GF.Command.Commands
+import GF.Command.Abstract
+import GF.Command.Parse
+import PGF
+import PGF.Data
+import PGF.Macros
+import GF.System.Signal
+import GF.Infra.UseIO
+
+import GF.Data.ErrM ----
+
+import qualified Data.Map as Map
+
+data CommandEnv = CommandEnv {
+  multigrammar  :: PGF,
+  commands      :: Map.Map String CommandInfo,
+  commandmacros :: Map.Map String CommandLine,
+  expmacros     :: Map.Map String Tree
+  }
+
+mkCommandEnv :: PGF -> CommandEnv
+mkCommandEnv pgf = CommandEnv pgf (allCommands pgf) Map.empty Map.empty
+
+emptyCommandEnv :: CommandEnv
+emptyCommandEnv = mkCommandEnv emptyPGF
+
+interpretCommandLine :: CommandEnv -> String -> IO ()
+interpretCommandLine env line =
+  case readCommandLine line of
+    Just []    -> return ()
+    Just pipes -> do res <- runInterruptibly (mapM_ (interpretPipe env) pipes)
+                     case res of
+                       Left ex -> putStrLnFlush (show ex)
+                       Right x -> return x
+    Nothing    -> putStrLnFlush "command not parsed"
+
+interpretPipe env cs = do
+     v@(_,s) <- intercs ([],"") cs
+     putStrLnFlush s
+     return v
+  where
+   intercs treess [] = return treess
+   intercs (trees,_) (c:cs) = do
+     treess2 <- interc trees c
+     intercs treess2 cs
+   interc es comm@(Command co _ arg) = case co of
+     '%':f -> case Map.lookup f (commandmacros env) of
+       Just css -> do
+         mapM_ (interpretPipe env) (appLine (getCommandArg env arg es) css) 
+         return ([],[]) ---- return ?
+       _ -> do
+         putStrLn $ "command macro " ++ co ++ " not interpreted"
+         return ([],[])
+     _ -> interpret env es comm
+   appLine es = map (map (appCommand es))
+
+-- macro definition applications: replace ?i by (exps !! i)
+appCommand :: [Tree] -> Command -> Command
+appCommand xs c@(Command i os arg) = case arg of
+  ATree e -> Command i os (ATree (app e))
+  _       -> c
+ where
+  app e = case e of
+    Meta i   -> xs !! i
+    Fun f as -> Fun f (map app as)
+    Abs x b  -> Abs x (app b)
+
+-- return the trees to be sent in pipe, and the output possibly printed
+interpret :: CommandEnv -> [Tree] -> Command -> IO CommandOutput
+interpret env trees0 comm = case lookCommand co comms of
+    Just info -> do
+      checkOpts info
+      tss@(_,s) <- exec info opts trees
+      optTrace s
+      return tss
+    _ -> do
+      putStrLn $ "command " ++ co ++ " not interpreted"
+      return ([],[])
+ where
+   optTrace = if isOpt "tr" opts then putStrLn else const (return ()) 
+   (co,opts,trees) = getCommand env comm trees0
+   comms = commands env
+   checkOpts info = 
+     case
+       [o | OOpt  o   <- opts, notElem o ("tr" : map fst (options info))] ++
+       [o | OFlag o _ <- opts, notElem o (map fst (flags info))]
+      of
+        []  -> return () 
+        [o] -> putStrLn $ "option not interpreted: " ++ o
+        os  -> putStrLn $ "options not interpreted: " ++ unwords os
+
+-- analyse command parse tree to a uniform datastructure, normalizing comm name
+--- the env is needed for macro lookup
+getCommand :: CommandEnv -> Command -> [Tree] -> (String,[Option],[Tree])
+getCommand env co@(Command c opts arg) ts = 
+  (getCommandOp c,opts,getCommandArg env arg ts) 
+
+getCommandArg :: CommandEnv -> Argument -> [Tree] -> [Tree]
+getCommandArg env a ts = case a of
+  AMacro m -> case Map.lookup m (expmacros env) of
+    Just t -> [t]
+    _ -> [] 
+  ATree t -> [t] -- ignore piped
+  ANoArg  -> ts  -- use piped
+
+-- abbreviation convention from gf commands
+getCommandOp s = case break (=='_') s of
+     (a:_,_:b:_) -> [a,b]  -- axx_byy --> ab
+     _ -> case s of
+       [a,b] -> s          -- ab  --> ab
+       a:_ -> [a]          -- axx --> a
+