msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

term macro help

Browse Source
This commit is contained in:
aarne
2008-06-18 09:14:31 +00:00
parent b37db6c880
commit 8201f59aeb
3 changed files with 274 additions and 244 deletions
Download Patch File Download Diff File Expand all files Collapse all files

11
src-3.0/GF/Command/Commands.hs
View File

@@ -114,14 +114,21 @@ allCommands pgf = Map.fromList [
}), }),
("dt", emptyCommandInfo { ("dt", emptyCommandInfo {
longname = "define_tree", longname = "define_tree",
syntax = "dt IDENT (TREE | STRING)", -- | '<' COMMANDLINE)", syntax = "dt IDENT (TREE | STRING | \"<\" COMMANDLINE)",
synopsis = "define a tree or string macro", synopsis = "define a tree or string macro",
explanation = unlines [ explanation = unlines [
"Defines IDENT as macro for TREE or STRING, until IDENT gets redefined.", "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 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", "a subtree of another tree. This command must be a line of its own",
"and thus cannot be a part of a pipe." "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 { ("e", emptyCommandInfo {

13
src-3.0/GF/Command/Interpreter.hs
View File

@@ -3,6 +3,7 @@ module GF.Command.Interpreter (
mkCommandEnv, mkCommandEnv,
emptyCommandEnv, emptyCommandEnv,
interpretCommandLine, interpretCommandLine,
interpretPipe,
getCommandOp getCommandOp
) where ) where
@@ -36,15 +37,17 @@ interpretCommandLine :: CommandEnv -> String -> IO ()
interpretCommandLine env line = interpretCommandLine env line =
case readCommandLine line of case readCommandLine line of
Just [] -> return () Just [] -> return ()
Just pipes -> do res <- runInterruptibly (mapM_ interPipe pipes) Just pipes -> do res <- runInterruptibly (mapM_ (interpretPipe env) pipes)
case res of case res of
Left ex -> putStrLnFlush (show ex) Left ex -> putStrLnFlush (show ex)
Right x -> return x Right x -> return x
Nothing -> putStrLnFlush "command not parsed" Nothing -> putStrLnFlush "command not parsed"
where
interPipe cs = do interpretPipe env cs = do
(_,s) <- intercs ([],"") cs v@(_,s) <- intercs ([],"") cs
putStrLnFlush s putStrLnFlush s
return v
where
intercs treess [] = return treess intercs treess [] = return treess
intercs (trees,_) (c:cs) = do intercs (trees,_) (c:cs) = do
treess2 <- interc trees c treess2 <- interc trees c
@@ -52,7 +55,7 @@ interpretCommandLine env line =
interc es comm@(Command co _ arg) = case co of interc es comm@(Command co _ arg) = case co of
'%':f -> case Map.lookup f (commandmacros env) of '%':f -> case Map.lookup f (commandmacros env) of
Just css -> do Just css -> do
mapM_ interPipe (appLine (getCommandArg env arg es) css) mapM_ (interpretPipe env) (appLine (getCommandArg env arg es) css)
return ([],[]) ---- return ? return ([],[]) ---- return ?
_ -> do _ -> do
putStrLn $ "command macro " ++ co ++ " not interpreted" putStrLn $ "command macro " ++ co ++ " not interpreted"

494
src-3.0/GFI.hs
View File

@@ -1,237 +1,257 @@
module GFI (mainGFI) where module GFI (mainGFI) where
import GF.Command.Interpreter import GF.Command.Interpreter
import GF.Command.Importing import GF.Command.Importing
import GF.Command.Commands import GF.Command.Commands
import GF.Command.Abstract import GF.Command.Abstract
import GF.Command.Parse import GF.Command.Parse
import GF.Data.ErrM import GF.Data.ErrM
import GF.Grammar.API -- for cc command import GF.Grammar.API -- for cc command
import GF.Infra.UseIO import GF.Infra.UseIO
import GF.Infra.Option import GF.Infra.Option
import GF.System.Readline import GF.System.Readline
import PGF import PGF
import PGF.Data import PGF.Data
import PGF.Macros import PGF.Macros
import PGF.ExprSyntax (readExp) import PGF.ExprSyntax (readExp)
import Data.Char import Data.Char
import Data.List(isPrefixOf) import Data.List(isPrefixOf)
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Text.ParserCombinators.ReadP as RP import qualified Text.ParserCombinators.ReadP as RP
import System.Cmd import System.Cmd
import System.CPUTime import System.CPUTime
import Control.Exception import Control.Exception
import Data.Version import Data.Version
import Paths_gf import Paths_gf
mainGFI :: Options -> [FilePath] -> IO () mainGFI :: Options -> [FilePath] -> IO ()
mainGFI opts files = do mainGFI opts files = do
putStrLn welcome putStrLn welcome
gfenv <- importInEnv emptyGFEnv opts files gfenv <- importInEnv emptyGFEnv opts files
loop opts gfenv loop opts gfenv
return () return ()
loop :: Options -> GFEnv -> IO GFEnv loop :: Options -> GFEnv -> IO GFEnv
loop opts gfenv0 = do loop opts gfenv0 = do
let env = commandenv gfenv0 let env = commandenv gfenv0
let sgr = sourcegrammar gfenv0 let sgr = sourcegrammar gfenv0
setCompletionFunction (Just (wordCompletion (commandenv gfenv0))) setCompletionFunction (Just (wordCompletion (commandenv gfenv0)))
s <- fetchCommand (prompt env) s <- fetchCommand (prompt env)
let gfenv = gfenv0 {history = s : history gfenv0} let gfenv = gfenv0 {history = s : history gfenv0}
let loopNewCPU gfenv' = do let loopNewCPU gfenv' = do
cpu' <- getCPUTime cpu' <- getCPUTime
putStrLnFlush (show ((cpu' - cputime gfenv') `div` 1000000000) ++ " msec") putStrLnFlush (show ((cpu' - cputime gfenv') `div` 1000000000) ++ " msec")
loop opts $ gfenv' {cputime = cpu'} loop opts $ gfenv' {cputime = cpu'}
let let
pwords = case words s of pwords = case words s of
w:ws -> getCommandOp w :ws w:ws -> getCommandOp w :ws
ws -> ws ws -> ws
case pwords of case pwords of
-- special commands, requiring source grammar in env -- special commands, requiring source grammar in env
"!":ws -> do "!":ws -> do
system $ unwords ws system $ unwords ws
loopNewCPU gfenv loopNewCPU gfenv
"cc":ws -> do "cc":ws -> do
let let
(style,term) = case ws of (style,term) = case ws of
('-':w):ws2 -> (pTermPrintStyle w, ws2) ('-':w):ws2 -> (pTermPrintStyle w, ws2)
_ -> (TermPrintDefault, ws) _ -> (TermPrintDefault, ws)
case pTerm (unwords term) >>= checkTerm sgr >>= computeTerm sgr of ---- pipe! case pTerm (unwords term) >>= checkTerm sgr >>= computeTerm sgr of ---- pipe!
Ok x -> putStrLn (showTerm style x) Ok x -> putStrLnFlush (showTerm style x)
Bad s -> putStrLn s Bad s -> putStrLnFlush s
loopNewCPU gfenv loopNewCPU gfenv
"i":args -> do "i":args -> do
gfenv' <- case parseOptions args of gfenv' <- case parseOptions args of
Ok (opts',files) -> importInEnv gfenv (addOptions opts opts') files Ok (opts',files) -> importInEnv gfenv (addOptions opts opts') files
Bad err -> do putStrLn $ "Command parse error: " ++ err Bad err -> do
return gfenv putStrLn $ "Command parse error: " ++ err
loopNewCPU gfenv' return gfenv
loopNewCPU gfenv'
-- other special commands, working on GFEnv
"e":_ -> loopNewCPU $ gfenv { -- other special commands, working on GFEnv
commandenv=emptyCommandEnv, sourcegrammar = emptyGrammar "e":_ -> loopNewCPU $ gfenv {
} commandenv=emptyCommandEnv, sourcegrammar = emptyGrammar
}
"dc":f:ws -> do
case readCommandLine (unwords ws) of "dc":f:ws -> do
Just comm -> loopNewCPU $ gfenv { case readCommandLine (unwords ws) of
commandenv = env { Just comm -> loopNewCPU $ gfenv {
commandmacros = Map.insert f comm (commandmacros env) commandenv = env {
} commandmacros = Map.insert f comm (commandmacros env)
} }
_ -> putStrLn "command definition not parsed" >> loopNewCPU gfenv }
_ -> putStrLnFlush "command definition not parsed" >> loopNewCPU gfenv
"dt":f:ws -> do
case readExp (unwords ws) of "dt":f:"<":ws -> do
Just exp -> loopNewCPU $ gfenv { case readCommandLine (unwords ws) of
commandenv = env { Just [pip] -> do
expmacros = Map.insert f exp (expmacros env) ip <- interpretPipe env pip
} case ip of
} (exp:es,_) -> do
_ -> putStrLn "value definition not parsed" >> loopNewCPU gfenv if null es then return () else
putStrLnFlush $ "ambiguous definition, selected the first one"
"ph":_ -> mapM_ putStrLn (reverse (history gfenv0)) >> loopNewCPU gfenv loopNewCPU $ gfenv {
"q":_ -> putStrLn "See you." >> return gfenv commandenv = env {
expmacros = Map.insert f exp (expmacros env)
-- ordinary commands, working on CommandEnv }
_ -> do }
interpretCommandLine env s _ -> putStrLnFlush "no value given in definition" >> loopNewCPU gfenv
loopNewCPU gfenv _ -> putStrLnFlush "value definition not parsed" >> loopNewCPU gfenv
importInEnv :: GFEnv -> Options -> [FilePath] -> IO GFEnv "dt":f:ws -> do
importInEnv gfenv opts files case readExp (unwords ws) of
| flag optRetainResource opts = Just exp -> loopNewCPU $ gfenv {
do src <- importSource (sourcegrammar gfenv) opts files commandenv = env {
return $ gfenv {sourcegrammar = src} expmacros = Map.insert f exp (expmacros env)
| otherwise = }
do let opts' = addOptions (setOptimization OptCSE False) opts }
pgf0 = multigrammar (commandenv gfenv) _ -> putStrLnFlush "value definition not parsed" >> loopNewCPU gfenv
pgf1 <- importGrammar pgf0 opts' files
putStrLnFlush $ unwords $ "\nLanguages:" : languages pgf1 "ph":_ -> mapM_ putStrLnFlush (reverse (history gfenv0)) >> loopNewCPU gfenv
return $ gfenv { commandenv = mkCommandEnv pgf1 } "q":_ -> putStrLnFlush "See you." >> return gfenv
welcome = unlines [ -- 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
"This is GF version "++showVersion version++". ", pgf0 = multigrammar cenv0
"Some things may work. " pgf1 <- importGrammar pgf0 opts' files
] putStrLnFlush $ unwords $ "\nLanguages:" : languages pgf1
return $ gfenv { commandenv = (mkCommandEnv pgf1)
prompt env = absname ++ "> " where {commandmacros = commandmacros cenv0, expmacros = expmacros cenv0}}
absname = case abstractName (multigrammar env) of --- return $ gfenv { commandenv = cenv0 {multigrammar = pgf1} } -- WHY NOT
"_" -> "" --- created by new Ident handling 22/5/2008
n -> n welcome = unlines [
" ",
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 = "This is GF version "++showVersion version++". ",
case wc_type (take p line) of "Some things may work. "
CmplCmd pref ]
-> ret ' ' [name | name <- Map.keys (commands cmdEnv), isPrefixOf pref name]
CmplStr (Just (Command _ opts _)) s prompt env = absname ++ "> " where
-> do mb_state0 <- try (evaluate (initState pgf (optLang opts) (optCat opts))) absname = case abstractName (multigrammar env) of
case mb_state0 of "_" -> "" --- created by new Ident handling 22/5/2008
Right state0 -> let ws = words (take (length s - length prefix) s) n -> n
state = foldl nextState state0 ws
compls = getCompletions state prefix data GFEnv = GFEnv {
in ret ' ' (Map.keys compls) sourcegrammar :: Grammar, -- gfo grammar -retain
Left _ -> ret ' ' [] commandenv :: CommandEnv,
CmplOpt (Just (Command n _ _)) pref history :: [String],
-> case Map.lookup n (commands cmdEnv) of cputime :: Integer
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 '=') emptyGFEnv :: GFEnv
(flg_compls++opt_compls) emptyGFEnv = GFEnv emptyGrammar (mkCommandEnv emptyPGF) [] 0
Nothing -> ret ' ' []
CmplIdent (Just (Command "i" _ _)) _ -- HACK: file name completion for command i
-> filenameCompletionFunction prefix wordCompletion cmdEnv line prefix p =
CmplIdent _ pref case wc_type (take p line) of
-> do mb_abs <- try (evaluate (abstract pgf)) CmplCmd pref
case mb_abs of -> ret ' ' [name | name <- Map.keys (commands cmdEnv), isPrefixOf pref name]
Right abs -> ret ' ' [name | cid <- Map.keys (funs abs), let name = prCId cid, isPrefixOf pref name] CmplStr (Just (Command _ opts _)) s
Left _ -> ret ' ' [] -> do mb_state0 <- try (evaluate (initState pgf (optLang opts) (optCat opts)))
_ -> ret ' ' [] case mb_state0 of
where Right state0 -> let ws = words (take (length s - length prefix) s)
pgf = multigrammar cmdEnv state = foldl nextState state0 ws
optLang opts = valIdOpts "lang" (head (languages pgf)) opts compls = getCompletions state prefix
optCat opts = valIdOpts "cat" (lookStartCat pgf) opts in ret ' ' (Map.keys compls)
Left _ -> ret ' ' []
ret c [x] = return [x++[c]] CmplOpt (Just (Command n _ _)) pref
ret _ xs = return xs -> 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]
data CompletionType ret (if null flg_compls then ' ' else '=')
= CmplCmd Ident (flg_compls++opt_compls)
| CmplStr (Maybe Command) String Nothing -> ret ' ' []
| CmplOpt (Maybe Command) Ident CmplIdent (Just (Command "i" _ _)) _ -- HACK: file name completion for command i
| CmplIdent (Maybe Command) Ident -> filenameCompletionFunction prefix
deriving Show CmplIdent _ pref
-> do mb_abs <- try (evaluate (abstract pgf))
wc_type :: String -> CompletionType case mb_abs of
wc_type = cmd_name Right abs -> ret ' ' [name | cid <- Map.keys (funs abs), let name = prCId cid, isPrefixOf pref name]
where Left _ -> ret ' ' []
cmd_name cs = _ -> ret ' ' []
let cs1 = dropWhile isSpace cs where
in go cs1 cs1 pgf = multigrammar cmdEnv
where optLang opts = valIdOpts "lang" (head (languages pgf)) opts
go x [] = CmplCmd x optCat opts = valIdOpts "cat" (lookStartCat pgf) opts
go x (c:cs)
| isIdent c = go x cs ret c [x] = return [x++[c]]
| otherwise = cmd x cs ret _ xs = return xs
cmd x [] = ret CmplIdent x "" 0
cmd _ ('|':cs) = cmd_name cs data CompletionType
cmd _ (';':cs) = cmd_name cs = CmplCmd Ident
cmd x ('"':cs) = str x cs cs | CmplStr (Maybe Command) String
cmd x ('-':cs) = option x cs cs | CmplOpt (Maybe Command) Ident
cmd x (c :cs) | CmplIdent (Maybe Command) Ident
| isIdent c = ident x (c:cs) cs deriving Show
| otherwise = cmd x cs
wc_type :: String -> CompletionType
option x y [] = ret CmplOpt x y 1 wc_type = cmd_name
option x y (c:cs) where
| isIdent c = option x y cs cmd_name cs =
| otherwise = cmd x cs let cs1 = dropWhile isSpace cs
in go cs1 cs1
ident x y [] = ret CmplIdent x y 0 where
ident x y (c:cs) go x [] = CmplCmd x
| isIdent c = ident x y cs go x (c:cs)
| otherwise = cmd x cs | isIdent c = go x cs
| otherwise = cmd x cs
str x y [] = ret CmplStr x y 1
str x y ('\"':cs) = cmd x cs cmd x [] = ret CmplIdent x "" 0
str x y ('\\':c:cs) = str x y cs cmd _ ('|':cs) = cmd_name cs
str x y (c:cs) = str x y cs cmd _ (';':cs) = cmd_name cs
cmd x ('"':cs) = str x cs cs
ret f x y d = f cmd y cmd x ('-':cs) = option x cs cs
where cmd x (c :cs)
x1 = take (length x - length y - d) x | isIdent c = ident x (c:cs) cs
x2 = takeWhile (\c -> isIdent c || isSpace c || c == '-' || c == '=') x1 | otherwise = cmd x cs
cmd = case [x | (x,cs) <- RP.readP_to_S pCommand x2, all isSpace cs] of option x y [] = ret CmplOpt x y 1
[x] -> Just x option x y (c:cs)
_ -> Nothing | isIdent c = option x y cs
| otherwise = cmd x cs
isIdent c = c == '_' || c == '\'' || isAlphaNum c
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