mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-10 13:29:32 -06:00
84 lines
2.5 KiB
Haskell
84 lines
2.5 KiB
Haskell
module GF.Command.Interpreter (
|
|
CommandEnv (..),
|
|
mkCommandEnv,
|
|
interpretCommandLine
|
|
) where
|
|
|
|
import GF.Command.Commands
|
|
import GF.Command.Abstract
|
|
import GF.Command.Parse
|
|
import PGF
|
|
import PGF.Data
|
|
import PGF.Macros
|
|
import GF.System.Signal
|
|
import GF.Infra.UseIO
|
|
|
|
import GF.Data.ErrM ----
|
|
|
|
import qualified Data.Map as Map
|
|
|
|
data CommandEnv = CommandEnv {
|
|
multigrammar :: PGF,
|
|
commands :: Map.Map String CommandInfo
|
|
}
|
|
|
|
mkCommandEnv :: PGF -> CommandEnv
|
|
mkCommandEnv pgf = CommandEnv pgf (allCommands pgf)
|
|
|
|
interpretCommandLine :: CommandEnv -> String -> IO ()
|
|
interpretCommandLine env line =
|
|
case readCommandLine line of
|
|
Just [] -> return ()
|
|
Just pipes -> do res <- runInterruptibly (mapM_ interPipe 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
|
|
putStrLnFlush s
|
|
intercs treess [] = return treess
|
|
intercs (trees,_) (c:cs) = do
|
|
treess2 <- interc trees c
|
|
intercs treess2 cs
|
|
interc = interpret env
|
|
|
|
-- 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 ([],[])
|
|
where
|
|
optTrace = if isOpt "tr" opts then putStrLn else const (return ())
|
|
(co,opts,trees) = getCommand comm trees0
|
|
comms = commands env
|
|
checkOpts info =
|
|
case
|
|
[o | OOpt o <- opts, notElem o ("tr" : options info)] ++
|
|
[o | OFlag o _ <- opts, notElem o (flags info)]
|
|
of
|
|
[] -> return ()
|
|
[o] -> putStrLn $ "option not interpreted: " ++ o
|
|
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) -> (getOp c,opts,[t]) -- ignore piped
|
|
Command c opts ANoArg -> (getOp c,opts,ts) -- use piped
|
|
where
|
|
-- abbreviation convention from gf
|
|
getOp s = case break (=='_') s of
|
|
(a:_,_:b:_) -> [a,b] -- axx_byy --> ab
|
|
_ -> case s of
|
|
[a,b] -> s -- ab --> ab
|
|
a:_ -> [a] -- axx --> a
|
|
|