term macro help

3 files changed, 274 insertions, 244 deletions

diff --git a/src-3.0/GF/Command/Commands.hs b/src-3.0/GF/Command/Commands.hs
index 6fd4a1fb2..7441e6fb5 100644
--- a/src-3.0/GF/Command/Commands.hs
+++ b/src-3.0/GF/Command/Commands.hs
@@ -114,14 +114,21 @@ allCommands pgf = Map.fromList [
      }),
   ("dt",  emptyCommandInfo {
      longname = "define_tree",
-     syntax = "dt IDENT (TREE | STRING)", -- | '<' COMMANDLINE)",
+     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 '<'.",
+       "The defining value can also come from a command, preceded by \"<\".",
+       "If the command gives many values, the first one is selected.",
        "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."
+       ],
+     examples = [
+       ("dt ex \"hello world\"                    -- define ex as string"),
+       ("dt ex UseN man_N                         -- define ex as string"),
+       ("dt ex < p -cat=NP \"the man in the car\" -- define ex as parse result"),
+       ("l -lang=LangSwe %ex | ps -to_utf8        -- linearize the tree ex")
        ] 
      }),
   ("e",  emptyCommandInfo {
diff --git a/src-3.0/GF/Command/Interpreter.hs b/src-3.0/GF/Command/Interpreter.hs
index 3e774a693..ee354bd45 100644
--- a/src-3.0/GF/Command/Interpreter.hs
+++ b/src-3.0/GF/Command/Interpreter.hs
@@ -3,6 +3,7 @@ module GF.Command.Interpreter (
   mkCommandEnv,
   emptyCommandEnv,
   interpretCommandLine,
+  interpretPipe,
   getCommandOp
   ) where
 
@@ -36,15 +37,17 @@ interpretCommandLine :: CommandEnv -> String -> IO ()
 interpretCommandLine env line =
   case readCommandLine line of
     Just []    -> return ()
-    Just pipes -> do res <- runInterruptibly (mapM_ interPipe pipes)
+    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"
- where
-   interPipe cs = do
-     (_,s) <- intercs ([],"") cs
+
+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
@@ -52,7 +55,7 @@ interpretCommandLine env line =
    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) 
+         mapM_ (interpretPipe env) (appLine (getCommandArg env arg es) css) 
          return ([],[]) ---- return ?
        _ -> do
          putStrLn $ "command macro " ++ co ++ " not interpreted"
diff --git a/src-3.0/GFI.hs b/src-3.0/GFI.hs
index c9d9db0b3..27a825c12 100644
--- a/src-3.0/GFI.hs
+++ b/src-3.0/GFI.hs
@@ -1,237 +1,257 @@
-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 -> 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 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
-
-  -- 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
+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