From 8201f59aeb382c20b43ea67842feb9a363797606 Mon Sep 17 00:00:00 2001 From: aarne Date: Wed, 18 Jun 2008 09:14:31 +0000 Subject: [PATCH] term macro help --- src-3.0/GF/Command/Commands.hs | 11 +- src-3.0/GF/Command/Interpreter.hs | 13 +- src-3.0/GFI.hs | 494 ++++++++++++++++-------------- 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