module GF.Command.Interpreter (
CommandEnv(..),mkCommandEnv,
interpretCommandLine,
getCommandOp
) where
import GF.Command.CommandInfo
import GF.Command.Abstract
import GF.Command.Parse
import PGF.Internal(Expr(..))
import GF.Infra.UseIO(putStrLnE)
import Control.Monad(when)
import qualified Data.Map as Map
import GF.Infra.UseIO (Output)
import qualified Control.Monad.Fail as Fail
data CommandEnv m = CommandEnv {
CommandEnv m -> Map String (CommandInfo m)
commands :: Map.Map String (CommandInfo m),
CommandEnv m -> Map String CommandLine
commandmacros :: Map.Map String CommandLine,
CommandEnv m -> Map String Expr
expmacros :: Map.Map String Expr
}
mkCommandEnv :: Map String (CommandInfo m) -> CommandEnv m
mkCommandEnv Map String (CommandInfo m)
cmds = Map String (CommandInfo m)
-> Map String CommandLine -> Map String Expr -> CommandEnv m
forall (m :: * -> *).
Map String (CommandInfo m)
-> Map String CommandLine -> Map String Expr -> CommandEnv m
CommandEnv Map String (CommandInfo m)
cmds Map String CommandLine
forall k a. Map k a
Map.empty Map String Expr
forall k a. Map k a
Map.empty
interpretCommandLine :: (Fail.MonadFail m, Output m, TypeCheckArg m) => CommandEnv m -> String -> m ()
interpretCommandLine :: CommandEnv m -> String -> m ()
interpretCommandLine CommandEnv m
env String
line =
case String -> Maybe CommandLine
readCommandLine String
line of
Just [] -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just CommandLine
pipes -> ([Command] -> m ()) -> CommandLine -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (CommandEnv m -> [Command] -> m ()
forall (m :: * -> *).
(TypeCheckArg m, Output m, MonadFail m) =>
CommandEnv m -> [Command] -> m ()
interpretPipe CommandEnv m
env) CommandLine
pipes
Maybe CommandLine
Nothing -> String -> m ()
forall (m :: * -> *). Output m => String -> m ()
putStrLnE (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"command not parsed: "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
line
interpretPipe :: CommandEnv m -> [Command] -> m ()
interpretPipe CommandEnv m
env [Command]
cs = do
Piped v :: (CommandArguments, String)
v@(CommandArguments
_,String
s) <- [Command] -> CommandOutput -> m CommandOutput
intercs [Command]
cs CommandOutput
void
String -> m ()
forall (m :: * -> *). Output m => String -> m ()
putStrLnE String
s
() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
intercs :: [Command] -> CommandOutput -> m CommandOutput
intercs [] CommandOutput
args = CommandOutput -> m CommandOutput
forall (m :: * -> *) a. Monad m => a -> m a
return CommandOutput
args
intercs (Command
c:[Command]
cs) (Piped (CommandArguments
args,String
_)) = Command -> CommandArguments -> m CommandOutput
interc Command
c CommandArguments
args m CommandOutput
-> (CommandOutput -> m CommandOutput) -> m CommandOutput
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Command] -> CommandOutput -> m CommandOutput
intercs [Command]
cs
interc :: Command -> CommandArguments -> m CommandOutput
interc comm :: Command
comm@(Command String
co [Option]
opts Argument
arg) CommandArguments
args =
case String
co of
Char
'%':String
f -> case String -> Map String CommandLine -> Maybe CommandLine
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
f (CommandEnv m -> Map String CommandLine
forall (m :: * -> *). CommandEnv m -> Map String CommandLine
commandmacros CommandEnv m
env) of
Just CommandLine
css ->
do CommandArguments
args <- CommandEnv m
-> Bool -> Argument -> CommandArguments -> m CommandArguments
forall (m :: * -> *) (m :: * -> *).
TypeCheckArg m =>
CommandEnv m
-> Bool -> Argument -> CommandArguments -> m CommandArguments
getCommandTrees CommandEnv m
env Bool
False Argument
arg CommandArguments
args
([Command] -> m ()) -> CommandLine -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (CommandEnv m -> [Command] -> m ()
interpretPipe CommandEnv m
env) (CommandArguments -> CommandLine -> CommandLine
appLine CommandArguments
args CommandLine
css)
CommandOutput -> m CommandOutput
forall (m :: * -> *) a. Monad m => a -> m a
return CommandOutput
void
Maybe CommandLine
Nothing -> do
String -> m ()
forall (m :: * -> *). Output m => String -> m ()
putStrLnE (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"command macro " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
co String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" not interpreted"
CommandOutput -> m CommandOutput
forall (m :: * -> *) a. Monad m => a -> m a
return CommandOutput
void
String
_ -> CommandEnv m -> CommandArguments -> Command -> m CommandOutput
forall (m :: * -> *).
(MonadFail m, TypeCheckArg m, Output m) =>
CommandEnv m -> CommandArguments -> Command -> m CommandOutput
interpret CommandEnv m
env CommandArguments
args Command
comm
appLine :: CommandArguments -> CommandLine -> CommandLine
appLine = ([Command] -> [Command]) -> CommandLine -> CommandLine
forall a b. (a -> b) -> [a] -> [b]
map (([Command] -> [Command]) -> CommandLine -> CommandLine)
-> (CommandArguments -> [Command] -> [Command])
-> CommandArguments
-> CommandLine
-> CommandLine
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Command -> Command) -> [Command] -> [Command]
forall a b. (a -> b) -> [a] -> [b]
map ((Command -> Command) -> [Command] -> [Command])
-> (CommandArguments -> Command -> Command)
-> CommandArguments
-> [Command]
-> [Command]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CommandArguments -> Command -> Command
appCommand
appCommand :: CommandArguments -> Command -> Command
appCommand :: CommandArguments -> Command -> Command
appCommand CommandArguments
args c :: Command
c@(Command String
i [Option]
os Argument
arg) = case Argument
arg of
AExpr Expr
e -> String -> [Option] -> Argument -> Command
Command String
i [Option]
os (Expr -> Argument
AExpr (Expr -> Expr
app Expr
e))
Argument
_ -> Command
c
where
xs :: [Expr]
xs = CommandArguments -> [Expr]
toExprs CommandArguments
args
app :: Expr -> Expr
app Expr
e = case Expr
e of
EAbs BindType
b CId
x Expr
e -> BindType -> CId -> Expr -> Expr
EAbs BindType
b CId
x (Expr -> Expr
app Expr
e)
EApp Expr
e1 Expr
e2 -> Expr -> Expr -> Expr
EApp (Expr -> Expr
app Expr
e1) (Expr -> Expr
app Expr
e2)
ELit Literal
l -> Literal -> Expr
ELit Literal
l
EMeta MetaId
i -> [Expr]
xs [Expr] -> MetaId -> Expr
forall a. [a] -> MetaId -> a
!! MetaId
i
EFun CId
x -> CId -> Expr
EFun CId
x
interpret :: CommandEnv m -> CommandArguments -> Command -> m CommandOutput
interpret CommandEnv m
env CommandArguments
trees Command
comm =
do (CommandInfo m
info,[Option]
opts,CommandArguments
trees) <- CommandEnv m
-> CommandArguments
-> Command
-> m (CommandInfo m, [Option], CommandArguments)
forall (m :: * -> *) (m :: * -> *).
(MonadFail m, TypeCheckArg m) =>
CommandEnv m
-> CommandArguments
-> Command
-> m (CommandInfo m, [Option], CommandArguments)
getCommand CommandEnv m
env CommandArguments
trees Command
comm
tss :: CommandOutput
tss@(Piped (CommandArguments
_,String
s)) <- CommandInfo m -> [Option] -> CommandArguments -> m CommandOutput
forall (m :: * -> *).
CommandInfo m -> [Option] -> CommandArguments -> m CommandOutput
exec CommandInfo m
info [Option]
opts CommandArguments
trees
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String -> [Option] -> Bool
isOpt String
"tr" [Option]
opts) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> m ()
forall (m :: * -> *). Output m => String -> m ()
putStrLnE String
s
CommandOutput -> m CommandOutput
forall (m :: * -> *) a. Monad m => a -> m a
return CommandOutput
tss
getCommand :: CommandEnv m
-> CommandArguments
-> Command
-> m (CommandInfo m, [Option], CommandArguments)
getCommand CommandEnv m
env CommandArguments
es co :: Command
co@(Command String
c [Option]
opts Argument
arg) =
do CommandInfo m
info <- CommandEnv m -> String -> m (CommandInfo m)
forall (m :: * -> *) (m :: * -> *).
MonadFail m =>
CommandEnv m -> String -> m (CommandInfo m)
getCommandInfo CommandEnv m
env String
c
CommandInfo m -> [Option] -> m ()
forall (m :: * -> *) (m :: * -> *).
MonadFail m =>
CommandInfo m -> [Option] -> m ()
checkOpts CommandInfo m
info [Option]
opts
CommandArguments
es <- CommandEnv m
-> Bool -> Argument -> CommandArguments -> m CommandArguments
forall (m :: * -> *) (m :: * -> *).
TypeCheckArg m =>
CommandEnv m
-> Bool -> Argument -> CommandArguments -> m CommandArguments
getCommandTrees CommandEnv m
env (CommandInfo m -> Bool
forall (m :: * -> *). CommandInfo m -> Bool
needsTypeCheck CommandInfo m
info) Argument
arg CommandArguments
es
(CommandInfo m, [Option], CommandArguments)
-> m (CommandInfo m, [Option], CommandArguments)
forall (m :: * -> *) a. Monad m => a -> m a
return (CommandInfo m
info,[Option]
opts,CommandArguments
es)
getCommandInfo :: CommandEnv m -> String -> m (CommandInfo m)
getCommandInfo CommandEnv m
env String
cmd =
case String -> Map String (CommandInfo m) -> Maybe (CommandInfo m)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (String -> String
getCommandOp String
cmd) (CommandEnv m -> Map String (CommandInfo m)
forall (m :: * -> *). CommandEnv m -> Map String (CommandInfo m)
commands CommandEnv m
env) of
Just CommandInfo m
info -> CommandInfo m -> m (CommandInfo m)
forall (m :: * -> *) a. Monad m => a -> m a
return CommandInfo m
info
Maybe (CommandInfo m)
Nothing -> String -> m (CommandInfo m)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m (CommandInfo m)) -> String -> m (CommandInfo m)
forall a b. (a -> b) -> a -> b
$ String
"command not found: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cmd
checkOpts :: CommandInfo m -> [Option] -> m ()
checkOpts CommandInfo m
info [Option]
opts =
case
[String
o | OOpt String
o <- [Option]
opts, String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem String
o (String
"tr" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ((String, String) -> String) -> [(String, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, String) -> String
forall a b. (a, b) -> a
fst (CommandInfo m -> [(String, String)]
forall (m :: * -> *). CommandInfo m -> [(String, String)]
options CommandInfo m
info))] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
[String
o | OFlag String
o Value
_ <- [Option]
opts, String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem String
o (((String, String) -> String) -> [(String, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, String) -> String
forall a b. (a, b) -> a
fst (CommandInfo m -> [(String, String)]
forall (m :: * -> *). CommandInfo m -> [(String, String)]
flags CommandInfo m
info))]
of
[] -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
[String
o] -> String -> m ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"option not interpreted: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
o
[String]
os -> String -> m ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"options not interpreted: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
os
getCommandTrees :: CommandEnv m
-> Bool -> Argument -> CommandArguments -> m CommandArguments
getCommandTrees CommandEnv m
env Bool
needsTypeCheck Argument
a CommandArguments
args =
case Argument
a of
AMacro String
m -> case String -> Map String Expr -> Maybe Expr
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
m (CommandEnv m -> Map String Expr
forall (m :: * -> *). CommandEnv m -> Map String Expr
expmacros CommandEnv m
env) of
Just Expr
e -> Expr -> m CommandArguments
forall (m :: * -> *). Monad m => Expr -> m CommandArguments
one Expr
e
Maybe Expr
_ -> CommandArguments -> m CommandArguments
forall (m :: * -> *) a. Monad m => a -> m a
return ([Expr] -> CommandArguments
Exprs [])
AExpr Expr
e -> if Bool
needsTypeCheck
then Expr -> m CommandArguments
forall (m :: * -> *). Monad m => Expr -> m CommandArguments
one (Expr -> m CommandArguments) -> m Expr -> m CommandArguments
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Expr -> m Expr
forall (m :: * -> *). TypeCheckArg m => Expr -> m Expr
typeCheckArg Expr
e
else Expr -> m CommandArguments
forall (m :: * -> *). Monad m => Expr -> m CommandArguments
one Expr
e
ATerm Term
t -> CommandArguments -> m CommandArguments
forall (m :: * -> *) a. Monad m => a -> m a
return (Term -> CommandArguments
Term Term
t)
Argument
ANoArg -> CommandArguments -> m CommandArguments
forall (m :: * -> *) a. Monad m => a -> m a
return CommandArguments
args
where
one :: Expr -> m CommandArguments
one Expr
e = CommandArguments -> m CommandArguments
forall (m :: * -> *) a. Monad m => a -> m a
return ([Expr] -> CommandArguments
Exprs [Expr
e])