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 :: PGFEnv -> CommandEnv
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 :: CommandEnv -> String -> SIO ()
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

-- | macro definition applications: replace ?i by (exps !! i)
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

-- | return the trees to be sent in pipe, and the output possibly printed
--interpret :: CommandEnv -> [Expr] -> Command -> SIO CommandOutput
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

-- | analyse command parse tree to a uniform datastructure, normalizing comm name
--- the env is needed for macro lookup
--getCommand :: CommandEnv -> [Expr] -> Command -> Either String (CommandInfo PGFEnv,[Option],[Expr])
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 -> String -> Either String (CommandInfo PGFEnv)
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 env -> [Option] -> Either String ()
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 -> Bool -> Argument -> [Expr] -> Either String [Expr]
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 []) -- report error?
    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  -- use piped
  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]) -- ignore piped