macros for commands (dc) and terms (dt)

5 files changed, 107 insertions, 23 deletions

diff --git a/src-3.0/GF/Command/Abstract.hs b/src-3.0/GF/Command/Abstract.hs
index 31858a1f9..2b9ce5d1d 100644
--- a/src-3.0/GF/Command/Abstract.hs
+++ b/src-3.0/GF/Command/Abstract.hs
@@ -25,6 +25,7 @@ data Value
 data Argument
   = AExp Exp
   | ANoArg
+  | AMacro Ident
   deriving (Eq,Ord,Show)
 
 valIdOpts :: String -> String -> [Option] -> String
diff --git a/src-3.0/GF/Command/Commands.hs b/src-3.0/GF/Command/Commands.hs
index f442cfa22..6fd4a1fb2 100644
--- a/src-3.0/GF/Command/Commands.hs
+++ b/src-3.0/GF/Command/Commands.hs
@@ -89,7 +89,9 @@ allCommands pgf = Map.fromList [
        "N.B.1 You need the flag -retain when importing the grammar, if you want",
        "the definitions to be retained after compilation.",
        "N.B.2 The resulting term is not a tree in the sense of abstract syntax",
-       "and hence not a valid input to a Tree-expecting command."
+       "and hence not a valid input to a Tree-expecting command.",
+       "This command must be a line of its own, and thus cannot be a part",
+       "of a pipe."
        ],
      options = [
        ("all","pick all strings (forms and variants) from records and tables"),
@@ -97,6 +99,31 @@ allCommands pgf = Map.fromList [
        ("unqual","hide qualifying module names")
        ]
      }),
+  ("dc",  emptyCommandInfo {
+     longname = "define_command",
+     syntax = "dc IDENT COMMANDLINE",
+     synopsis = "define a command macro",
+     explanation = unlines [
+       "Defines IDENT as macro for COMMANDLINE, until IDENT gets redefined.",
+       "A call of the command has the form %IDENT. The command may take an", 
+       "argument, which in COMMANDLINE is marked as ?0. Both strings and",
+       "trees can be arguments. Currently at most one argument is possible.",
+       "This command must be a line of its own, and thus cannot be a part",
+       "of a pipe."
+       ] 
+     }),
+  ("dt",  emptyCommandInfo {
+     longname = "define_tree",
+     syntax = "dt IDENT (TREE | STRING)", -- | '<' COMMANDLINE)",
+     synopsis = "define a tree or string macro",
+     explanation = unlines [
+       "Defines IDENT as macro for TREE or STRING, until IDENT gets redefined.",
+       -- "The defining value can also come from a command, preceded by '<'.",
+       "A use of the macro has the form %IDENT. Currently this use cannot be",
+       "a subtree of another tree. This command must be a line of its own",
+       "and thus cannot be a part of a pipe."
+       ] 
+     }),
   ("e",  emptyCommandInfo {
      longname = "empty",
      synopsis = "empty the environment"
diff --git a/src-3.0/GF/Command/Interpreter.hs b/src-3.0/GF/Command/Interpreter.hs
index 9c0d32849..3e774a693 100644
--- a/src-3.0/GF/Command/Interpreter.hs
+++ b/src-3.0/GF/Command/Interpreter.hs
@@ -1,6 +1,7 @@
 module GF.Command.Interpreter (
   CommandEnv (..),
   mkCommandEnv,
+  emptyCommandEnv,
   interpretCommandLine,
   getCommandOp
   ) where
@@ -19,12 +20,17 @@ import GF.Data.ErrM ----
 import qualified Data.Map as Map
 
 data CommandEnv = CommandEnv {
-  multigrammar :: PGF,
-  commands     :: Map.Map String CommandInfo
+  multigrammar  :: PGF,
+  commands      :: Map.Map String CommandInfo,
+  commandmacros :: Map.Map String CommandLine,
+  expmacros     :: Map.Map String Exp
   }
 
 mkCommandEnv :: PGF -> CommandEnv
-mkCommandEnv pgf = CommandEnv pgf (allCommands pgf)
+mkCommandEnv pgf = CommandEnv pgf (allCommands pgf) Map.empty Map.empty
+
+emptyCommandEnv :: CommandEnv
+emptyCommandEnv = mkCommandEnv emptyPGF
 
 interpretCommandLine :: CommandEnv -> String -> IO ()
 interpretCommandLine env line =
@@ -43,22 +49,42 @@ interpretCommandLine env line =
    intercs (trees,_) (c:cs) = do
      treess2 <- interc trees c
      intercs treess2 cs
-   interc = interpret env
+   interc es comm@(Command co _ arg) = case co of
+     '%':f -> case Map.lookup f (commandmacros env) of
+       Just css -> do
+         mapM_ interPipe (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 :: [Exp] -> Command -> Command
+appCommand xs c@(Command i os arg) = case arg of
+  AExp e -> Command i os (AExp (app e))
+  _ -> c
+ where
+  app e = case e of
+    EMeta i -> xs !! i
+    EApp f as -> EApp f (map app as)
+    EAbs x b  -> EAbs x (app b)
 
 -- return the trees to be sent in pipe, and the output possibly printed
 interpret :: CommandEnv -> [Exp] -> 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 ([],[])
+    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 comm trees0
+   (co,opts,trees) = getCommand env comm trees0
    comms = commands env
    checkOpts info = 
      case
@@ -70,10 +96,18 @@ interpret env trees0 comm = case lookCommand co comms of
         os  -> putStrLn $ "options not interpreted: " ++ unwords os
 
 -- analyse command parse tree to a uniform datastructure, normalizing comm name
-getCommand :: Command -> [Exp] -> (String,[Option],[Exp])
-getCommand co ts = case co of
-  Command c opts (AExp t) -> (getCommandOp c,opts,[t]) -- ignore piped
-  Command c opts ANoArg   -> (getCommandOp c,opts,ts)  -- use piped
+--- the env is needed for macro lookup
+getCommand :: CommandEnv -> Command -> [Exp] -> (String,[Option],[Exp])
+getCommand env co@(Command c opts arg) ts = 
+  (getCommandOp c,opts,getCommandArg env arg ts) 
+
+getCommandArg :: CommandEnv -> Argument -> [Exp] -> [Exp]
+getCommandArg env a ts = case a of
+  AMacro m -> case Map.lookup m (expmacros env) of
+    Just t -> [t]
+    _ -> [] 
+  AExp t -> [t] -- ignore piped
+  ANoArg -> ts  -- use piped
 
 -- abbreviation convention from gf commands
 getCommandOp s = case break (=='_') s of
diff --git a/src-3.0/GF/Command/Parse.hs b/src-3.0/GF/Command/Parse.hs
index f209b713b..12c88464f 100644
--- a/src-3.0/GF/Command/Parse.hs
+++ b/src-3.0/GF/Command/Parse.hs
@@ -20,10 +20,10 @@ pCommandLine = RP.sepBy (RP.skipSpaces >> pPipe) (RP.skipSpaces >> RP.char ';')
 pPipe = RP.sepBy1 (RP.skipSpaces >> pCommand) (RP.skipSpaces >> RP.char '|')
 
 pCommand = do
-  cmd  <- pIdent
+  cmd  <- pIdent RP.<++ (RP.char '%' >> pIdent >>= return . ('%':))
   RP.skipSpaces
   opts <- RP.sepBy pOption RP.skipSpaces
-  arg  <- RP.option ANoArg (fmap AExp (pExp False))
+  arg  <- pArgument
   return (Command cmd opts arg)
 
 pOption = do
@@ -38,3 +38,9 @@ pValue = do
 
 pFilename = liftM2 (:) (RP.satisfy isFileFirst) (RP.munch (not . isSpace)) where
   isFileFirst c = not (isSpace c) && not (isDigit c)
+
+pArgument =          
+  RP.option ANoArg 
+    (fmap AExp (pExp False)
+              RP.<++ 
+    (RP.munch isSpace >> RP.char '%' >> fmap AMacro pIdent))
diff --git a/src-3.0/GFI.hs b/src-3.0/GFI.hs
index e956d5c18..c9d9db0b3 100644
--- a/src-3.0/GFI.hs
+++ b/src-3.0/GFI.hs
@@ -14,6 +14,7 @@ import GF.System.Readline
 import PGF
 import PGF.Data
 import PGF.Macros
+import PGF.ExprSyntax (readExp)
 
 import Data.Char
 import Data.List(isPrefixOf)
@@ -26,7 +27,6 @@ import Control.Exception
 import Data.Version
 import Paths_gf
 
-
 mainGFI :: Options -> [FilePath] -> IO ()
 mainGFI opts files = do
   putStrLn welcome
@@ -72,10 +72,26 @@ loop opts gfenv0 = do
 
   -- other special commands, working on GFEnv
     "e":_ -> loopNewCPU $ gfenv {
-       commandenv=env{multigrammar=emptyPGF}, sourcegrammar = emptyGrammar
+       commandenv=emptyCommandEnv, sourcegrammar = emptyGrammar
        }
 
-    ---- "eh":file:_ ->
+    "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 readExp (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