macro commands

doc/gf-history.html

@@ -12,6 +12,10 @@ Changes in functionality since May 17, 2005, release of GF Version 2.2
 
 </center>
 
+6/10 (AR) New commands <tt>dc = define_command</tt> and
+<tt>dt = define_tree</tt> to define macros in a GF session.
+See <tt>help</tt> for details and examples. 
+
 <p>
 
 5/10 (AR) Printing missing linearization rules:

src/GF/GFModes.hs

@@ -4,9 +4,9 @@
 -- Stability   : (stability)
 -- Portability : (portability)
 --
--- > CVS $Date: 2005/04/21 16:21:04 $ 
+-- > CVS $Date: 2005/10/06 10:02:33 $ 
--- > CVS $Author: bringert $
+-- > CVS $Author: aarne $
--- > CVS $Revision: 1.7 $
+-- > CVS $Revision: 1.8 $
 --
 -- (Description of the module)
 -----------------------------------------------------------------------------
@@ -30,7 +30,7 @@ import Data.Char (isSpace)
 gfInteract :: HState -> IO HState
 gfInteract st@(env,hist) = do
   -- putStrFlush "> " M.F 25/01-02 prompt moved to Arch.
-  (s,cs) <- getCommandLines
+  (s,cs) <- getCommandLines st
   case ifImpure cs of
 
     -- these are the three impure commands
@@ -39,12 +39,12 @@ gfInteract st@(env,hist) = do
       return st
     Just (ICExecuteHistory file,_) -> do
       ss  <- readFileIf file
-      let co = pCommandLines ss
+      let co = pCommandLines st ss
       st' <- execLinesH s co st      
       gfInteract st'      
     Just (ICEarlierCommand i,_) -> do
       let line = earlierCommandH st i
-          co   = pCommandLine $ words line
+          co   = pCommandLine st $ words line
       st' <- execLinesH line [co] st       -- s would not work in execLinesH
       gfInteract st'
 
@@ -69,7 +69,7 @@ gfInteract st@(env,hist) = do
 
 gfBatch :: HState -> IO HState
 gfBatch st@(sh,_) = do
-  (s,cs) <- getCommandLinesBatch
+  (s,cs) <- getCommandLinesBatch st
   if s == "q" then return st else do
     st' <- if all isSpace s then return st else do
         putVe "<gfcommand>"
@@ -90,9 +90,10 @@ putVerb st@(sh,_) s = if (oElem beSilent (globalOptions sh))
 batchCompile :: Options -> FilePath -> IO ()
 batchCompile os file = do
   let file' = mkGFC file
+  let st    = initHState emptyShellState
   let s     = "i -o" +++ (unwords $ map ('-':) $ words $ prOpts os) +++ file
-  let cs    = pCommandLines s
+  let cs    = pCommandLines st s
-  execLines True cs (initHState emptyShellState)
+  execLines True cs st
   return ()
 
 mkGFC = reverse . ("cfg" ++) . dropWhile (/='.') . reverse

src/GF/Infra/Option.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/09/18 22:55:46 $ 
+-- > CVS $Date: 2005/10/06 10:02:33 $ 
 -- > CVS $Author: aarne $
--- > CVS $Revision: 1.31 $
+-- > CVS $Revision: 1.32 $
 --
 -- Options and flags used in GF shell commands and files.
 --
@@ -210,6 +210,7 @@ tableLin    = iOpt "table"
 defaultLinOpts = [firstLin]
 useUTF8     = iOpt "utf8"
 showLang    = iOpt "lang"
+showDefs    = iOpt "defs"
 withMetas   = iOpt "metas"
 
 -- ** other
@@ -221,6 +222,7 @@ beVerbose, showInfo, beSilent, emitCode, getHelp,
   stripQualif, nostripQualif, showAll, fromSource :: Option
 
 beVerbose    = iOpt "v"
+invertGrep   = iOpt "v" --- same letter in unix
 showInfo     = iOpt "i"
 beSilent     = iOpt "s"
 emitCode     = iOpt "o"

src/GF/Shell.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/10/05 20:02:19 $ 
+-- > CVS $Date: 2005/10/06 10:02:33 $ 
 -- > CVS $Author: aarne $
--- > CVS $Revision: 1.43 $
+-- > CVS $Revision: 1.44 $
 --
 -- GF shell command interpreter.
 -----------------------------------------------------------------------------
@@ -57,7 +57,7 @@ import GF.Data.Zipper ----
 import GF.Data.Operations
 import GF.Infra.UseIO
 import GF.Text.UTF8 (encodeUTF8)
-
+import Data.Char (isDigit)
 
 ---- import qualified GrammarToGramlet as Gr
 ---- import qualified GrammarToCanonXML2 as Canon
@@ -72,31 +72,67 @@ type CommandLine = (CommandOpt, CommandArg,  [CommandOpt])
 type SrcTerm = G.Term 
 
 -- | history & CPU
-type HState  = (ShellState,([String],Integer)) 
+type HState  = (ShellState,([String],Integer,ShMacros,ShTerms)) 
+
+type ShMacros = [(String,[String])] -- dc %c = ... #1 ... #2 ...
+type ShTerms  = [(String,Tree)]     -- dt $e = f ...
 
 type ShellIO = (HState, CommandArg) -> IO (HState, CommandArg)
 
 initHState :: ShellState -> HState
-initHState st = (st,([],0))
+initHState st = (st,([],0,[],[]))
 
 cpuHState :: HState -> Integer
-cpuHState (_,(_,i)) = i
+cpuHState (_,(_,i,_,_)) = i
 
 optsHState :: HState -> Options
 optsHState (st,_) = globalOptions st
 
 putHStateCPU :: Integer -> HState -> HState
-putHStateCPU cpu (st,(h,_)) = (st,(h,cpu))
+putHStateCPU cpu (st,(h,_,c,t)) = (st,(h,cpu,c,t))
 
 updateHistory :: String -> HState -> HState
-updateHistory s (st,(h,cpu)) = (st,(s:h,cpu))
+updateHistory s (st,(h,cpu,c,t)) = (st,(s:h,cpu,c,t))
+
+addShMacro :: (String,[String]) -> HState -> HState
+addShMacro m (st,(h,cpu,c,t)) = (st,(h,cpu,m:c,t))
+
+addShTerm :: (String,Tree) -> HState -> HState
+addShTerm m (st,(h,cpu,c,t)) = (st,(h,cpu,c,m:t))
+
+resolveShMacro :: HState -> String -> [String] -> [String]
+resolveShMacro st@(_,(_,_,cs,_)) c args = case lookup c cs of
+  Just def -> map subst def
+  _ -> [] ----
+ where
+   subst s = case s of
+     "#1" -> unwords args
+     _ -> s
+ --- so far only one arg allowed - how to determine arg boundaries?
+{-
+   subst s = case s of
+     '#':d@(_:_) | all isDigit d -> 
+        let i = read d in if i > lg then s else args !! (i-1) -- #1 is first
+     _ -> s
+   lg = length args
+-}
+
+lookupShTerm :: HState -> String -> Maybe Tree
+lookupShTerm st@(_,(_,_,_,ts)) c = lookup c ts
+
+txtHelpMacros :: HState -> String
+txtHelpMacros (_,(_,_,cs,ts)) = unlines $
+  ["Defined commands:",""] ++
+  [c +++ "=" +++ unwords def | (c,def) <- cs] ++
+  ["","Defined terms:",""] ++
+  [c +++ "=" +++ prt_ def | (c,def) <- ts]
 
 -- | empty command if index over
 earlierCommandH :: HState -> Int -> String
-earlierCommandH (_,(h,_)) = ((h ++ repeat "") !!) 
+earlierCommandH (_,(h,_,_,_)) = ((h ++ repeat "") !!) 
 
 execLinesH :: String -> [CommandLine] -> HState -> IO HState
-execLinesH s cs hst@(st, (h, _)) = do
+execLinesH s cs hst@(st, (h,_,_,_)) = do
   (_,st') <- execLines True cs hst
   cpu     <- prOptCPU (optsHState st') (cpuHState hst)
   return $ putHStateCPU cpu $ updateHistory s st'
@@ -125,7 +161,7 @@ execLine put (c@(co, os), arg, cs) (outps,st) = do
 
 -- | individual commands possibly piped: value returned; this is not a state monad
 execC :: CommandOpt -> ShellIO
-execC co@(comm, opts0) sa@((st,(h,_)),a) = checkOptions st co >> case comm of
+execC co@(comm, opts0) sa@(sh@(st,(h,_,_,_)),a) = checkOptions st co >> case comm of
 
   CImport file | oElem fromExamples opts -> do
     es <- liftM nub $ getGFEFiles opts file
@@ -151,6 +187,17 @@ execC co@(comm, opts0) sa@((st,(h,_)),a) = checkOptions st co >> case comm of
   CPrintHistory -> (returnArg $ AString $ unlines $ reverse h) sa
   -- good to have here for piping; eh and ec must be done on outer level
 
+  CDefineCommand c args -> return (addShMacro (c,args) sh, AUnit)
+  CDefineTerm c -> do 
+    let 
+      a' = case a of
+        ASTrm _ -> s2t a
+        AString _ -> s2t a
+        _ -> a
+    case a' of
+      ATrms [trm] -> return (addShTerm (c,trm) sh, AUnit) 
+      _ ->  returnArg (AError "illegal term definition") sa
+
   CLinearize [] 
     | oElem showMulti opts -> 
        changeArg (opTS2CommandArg (unlines. linearizeToAll
@@ -277,7 +324,8 @@ execC co@(comm, opts0) sa@((st,(h,_)),a) = checkOptions st co >> case comm of
 
   CHelp (Just c) -> returnArg   (AString (txtHelpCommand c)) sa
   CHelp _ -> case opts0 of
-    Opts [o] | o == showAll -> returnArg   (AString txtHelpFile) sa
+    Opts [o] | o == showAll  -> returnArg   (AString txtHelpFile) sa
+    Opts [o] | o == showDefs -> returnArg   (AString (txtHelpMacros sh)) sa
     Opts [o]        -> returnArg   (AString (txtHelpCommand ('-':prOpt o))) sa
     _               -> returnArg   (AString txtHelpFileSummary) sa
 
@@ -312,6 +360,7 @@ execC co@(comm, opts0) sa@((st,(h,_)),a) = checkOptions st co >> case comm of
    cgr = canModules st
 
    s2t a = case a of
+     ASTrm ('$':c) -> maybe (AError "undefined term") (ATrms . return) $ lookupShTerm sh c
      ASTrm s  -> err AError (ATrms . return) $ string2treeErr gro s
      AString s  -> err AError (ATrms . return) $ string2treeErr gro s
      _ -> a
@@ -329,7 +378,7 @@ execC co@(comm, opts0) sa@((st,(h,_)),a) = checkOptions st co >> case comm of
        then (putStrLn ("Warning: discontinuous category" +++ prt_ c))
        else (return ())
 
-   grep ms s = (if oElem beVerbose opts then not else id) $ grepv ms s --- -v
+   grep ms s = (if oElem invertGrep opts then not else id) $ grepv ms s --- -v
    grepv ms s = case s of
      _:cs -> isPrefixOf ms s || grepv ms cs
      _ -> isPrefixOf ms s

src/GF/Shell/Commands.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/08/17 15:13:55 $ 
+-- > CVS $Date: 2005/10/06 10:02:33 $ 
 -- > CVS $Author: aarne $
--- > CVS $Revision: 1.41 $
+-- > CVS $Revision: 1.42 $
 --
 -- temporary hacks for GF 2.0
 --
@@ -162,8 +162,9 @@ execCommand env c s = case c of
     return (startEditEnv emptyShellState, initSState)
 
   CCEnvGFShell command -> do
-    let cs = PShell.pCommandLines command
+    let hs = Shell.initHState env
-    (msg,(env',_)) <- Shell.execLines False cs (Shell.initHState env)
+    let cs = PShell.pCommandLines hs command
+    (msg,(env',_)) <- Shell.execLines False cs hs
     return (env', changeMsg msg s) ----
 
   CCEnvOpenTerm file -> do

src/GF/Shell/HelpFile.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/10/05 20:02:19 $
+-- > CVS $Date: 2005/10/06 10:02:34 $
 -- > CVS $Author: aarne $
--- > CVS $Revision: 1.14 $
+-- > CVS $Revision: 1.15 $
 --
 -- Help on shell commands. Generated from HelpFile by 'make help'.
 -- PLEASE DON'T EDIT THIS FILE.
@@ -90,6 +90,23 @@ txtHelpFile =
   "\ns,  strip: s" ++
   "\n      Prune the state by removing source and resource modules." ++
   "\n" ++
+  "\ndc, define_command Name Anything" ++
+  "\n      Add a new defined command. The Name must star with '%'. Later," ++
+  "\n      if 'Name X' is used, it is replaced by Anything where #1 is replaced" ++
+  "\n      by X. Currently at most one argument is possible. To see" ++
+  "\n      definitions in scope, use help -defs." ++
+  "\n  examples:" ++
+  "\n      dc %tnp p -cat=NP -lang=Eng #1 | l -lang=Swe    -- translate NPs" ++
+  "\n      %tnp \"this man\" | p -lang=Swe                   -- translate and parse" ++
+  "\n" ++
+  "\ndt, define_term Name Tree" ++
+  "\n      Add a constant for a tree. The constant can later be called by" ++
+  "\n      prefixing it with '$'. It is not yet usable as a subterm. To see" ++
+  "\n      definitions in scope, use help -defs." ++
+  "\n  examples:" ++
+  "\n      p -cat=NP \"this man\" | dt tm    -- define tm as parse result" ++
+  "\n      l -all $tm                      -- linearize tm in all forms" ++
+  "\n" ++
   "\n-- commands that give information about the state" ++
   "\n" ++
   "\npg, print_grammar: pg" ++
@@ -445,7 +462,8 @@ txtHelpFile =
   "\n      Displays the paragraph concerning the command from this help file." ++
   "\n      Without the argument, shows the first lines of all paragraphs." ++
   "\n  options" ++
-  "\n       -all  show the whole help file" ++
+  "\n       -all   show the whole help file" ++
+  "\n       -defs  show user-defined commands and terms" ++
   "\n  examples:" ++
   "\n       h print_grammar  -- show all information on the pg command" ++
   "\n" ++

src/GF/Shell/PShell.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/10/05 20:02:20 $ 
+-- > CVS $Date: 2005/10/06 10:02:34 $ 
 -- > CVS $Author: aarne $
--- > CVS $Revision: 1.26 $
+-- > CVS $Revision: 1.27 $
 --
 -- parsing GF shell commands. AR 11\/11\/2001
 -----------------------------------------------------------------------------
@@ -30,18 +30,19 @@ import System.IO.Error
 -- parsing GF shell commands. AR 11/11/2001
 
 -- | getting a sequence of command lines as input
-getCommandLines :: IO (String,[CommandLine])
+getCommandLines :: HState -> IO (String,[CommandLine])
-getCommandLines = do
+getCommandLines st = do
   s <- fetchCommand "> "
-  return (s,pCommandLines s)
+  return (s,pCommandLines st s)
 
-getCommandLinesBatch :: IO (String,[CommandLine])
+getCommandLinesBatch :: HState -> IO (String,[CommandLine])
-getCommandLinesBatch = do
+getCommandLinesBatch st = do
   s <- catch getLine (\e -> if isEOFError e then return "q" else ioError e)
-  return $ (s,pCommandLines s)
+  return $ (s,pCommandLines st s)
 
-pCommandLines :: String -> [CommandLine]
+pCommandLines :: HState -> String -> [CommandLine]
-pCommandLines = map pCommandLine . concatMap (chunks ";;" . wordsLits) . lines
+pCommandLines st = 
+  map (pCommandLine st) . concatMap (chunks ";;" . wordsLits) . lines
 
 -- | Like 'words', but does not split on whitespace inside
 --   double quotes.
@@ -60,23 +61,25 @@ unquote :: String -> String
 unquote (x:xs@(_:_)) | x `elem` "\"'" && x == last xs = init xs
 unquote s = s
 
-pCommandLine :: [String] -> CommandLine
+pCommandLine :: HState -> [String] -> CommandLine
-pCommandLine s = pFirst (chks s) where
+pCommandLine st (dc:c:def) | abbrevCommand dc == "dc" = ((CDefineCommand c def, noOptions),AUnit,[])
+pCommandLine st s = pFirst (chks s) where
   pFirst cos = case cos of
     (c,os,[a]) : cs -> ((c,os), a, pCont cs)
     _               -> ((CVoid,noOptions), AError "no parse", [])
   pCont cos = case cos of
     (c,os,_)   : cs -> (c,os) : pCont cs
     _               -> []
-  chks = map pCommandOpt . chunks "|"
+  chks = map (pCommandOpt st) . chunks "|"
 
-pCommandOpt :: [String] -> (Command, Options, [CommandArg])
+pCommandOpt :: HState -> [String] -> (Command, Options, [CommandArg])
-pCommandOpt (w:ws) = let 
+pCommandOpt st (c@('%':_):args) = pCommandOpt st $ resolveShMacro st c args 
+pCommandOpt _ (w:ws) = let 
   (os, co)     = getOptions "-" ws
   (comm, args) = pCommand (abbrevCommand w:co)
   in
   (comm, os, args)
-pCommandOpt s = (CVoid, noOptions, [AError "no parse"])
+pCommandOpt _ s = (CVoid, noOptions, [AError "no parse"])
 
 pInputString :: String -> [CommandArg]
 pInputString s = case s of
@@ -104,6 +107,7 @@ pCommand ws = case ws of
   "cl" : f : [] -> aUnit   (CConvertLatex f)
 
   "ph" : []     -> aUnit   CPrintHistory
+  "dt" : f : t  -> aTerm   (CDefineTerm (unquote f)) t
 
   "l"  : s      -> aTermLi CLinearize s
 

src/GF/Shell/ShellCommands.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/10/05 20:02:20 $ 
+-- > CVS $Date: 2005/10/06 10:02:34 $ 
 -- > CVS $Author: aarne $
--- > CVS $Revision: 1.40 $
+-- > CVS $Revision: 1.41 $
 --
 -- The datatype of shell commands and the list of their options.
 -----------------------------------------------------------------------------
@@ -40,6 +40,9 @@ data Command =
  | CTransformGrammar FilePath
  | CConvertLatex FilePath
 
+ | CDefineCommand String [String]
+ | CDefineTerm String
+
  | CLinearize [()] ---- parameters
  | CParse
  | CTranslate Language Language
@@ -200,7 +203,7 @@ optionsOfCommand co = case co of
   CPrintMultiGrammar -> both "utf8 utf8id" "printer"
   CPrintSourceGrammar -> both "utf8" "printer"
 
-  CHelp _ -> opts "all filter length lexer unlexer printer transform depth number"
+  CHelp _ -> opts "all defs filter length lexer unlexer printer transform depth number"
 
   CImpure ICEditSession -> both "f" "file"
   CImpure ICTranslateSession -> both "f langs" "cat"

src/HelpFile

@@ -61,6 +61,23 @@ sf, set_flags: sf Flag*
 s,  strip: s
       Prune the state by removing source and resource modules.
 
+dc, define_command Name Anything
+      Add a new defined command. The Name must star with '%'. Later,
+      if 'Name X' is used, it is replaced by Anything where #1 is replaced
+      by X. Currently at most one argument is possible. To see
+      definitions in scope, use help -defs.
+  examples:
+      dc %tnp p -cat=NP -lang=Eng #1 | l -lang=Swe    -- translate NPs
+      %tnp "this man" | p -lang=Swe                   -- translate and parse
+
+dt, define_term Name Tree
+      Add a constant for a tree. The constant can later be called by
+      prefixing it with '$'. It is not yet usable as a subterm. To see
+      definitions in scope, use help -defs.
+  examples:
+      p -cat=NP "this man" | dt tm    -- define tm as parse result
+      l -all $tm                      -- linearize tm in all forms
+
 -- commands that give information about the state
 
 pg, print_grammar: pg
@@ -416,7 +433,8 @@ h, help: h Command?
       Displays the paragraph concerning the command from this help file.
       Without the argument, shows the first lines of all paragraphs.
   options
-       -all  show the whole help file
+       -all   show the whole help file
+       -defs  show user-defined commands and terms
   examples:
        h print_grammar  -- show all information on the pg command