module HERMIT.Shell.Interpreter
(
Interp
, interp
, interpExprH
) where
import Control.Monad.Error
import Control.Monad.State
import Data.Char
import Data.Dynamic
import qualified Data.Map as M
import HERMIT.External
import HERMIT.Parser
import HERMIT.Kure
import HERMIT.Shell.Dictionary
import HERMIT.Shell.Types
data Interp :: * -> * where
Interp :: Typeable a => (a -> cmd) -> Interp cmd
interp :: Typeable a => (a -> cmd) -> Interp cmd
interp = Interp
instance Functor Interp where
fmap :: (a -> b) -> Interp a -> Interp b
fmap f (Interp g) = Interp (f . g)
interpExprH :: MonadState CommandLineState m => [Interp b] -> ExprH -> m b
interpExprH interps e = interpExpr e >>= runInterp e interps
runInterp :: Monad m => ExprH -> [Interp b] -> [Dynamic] -> m b
runInterp e interps dyns = case [f a | Interp f <- interps, Just a <- map fromDynamic dyns] of
[] -> fail $ "Does not type-check: " ++ unparseExprH e ++ "\n"
b:_ -> return b
interpExpr :: MonadState CommandLineState m => ExprH -> m [Dynamic]
interpExpr = interpExpr' False
fromDynList :: [[Dynamic]] -> [[Dynamic]]
fromDynList [] = [[]]
fromDynList (hs:dynss) = [ h:t | h <- hs, t <- fromDynList dynss ]
toBoxedList :: (Extern a, Typeable b) => [[Dynamic]] -> ([a] -> b) -> [Dynamic]
toBoxedList dyns boxCon = [ toDyn $ boxCon (map unbox l) | dl <- dyns, Just l <- [mapM fromDynamic dl] ]
interpExpr' :: MonadState CommandLineState m => Bool -> ExprH -> m [Dynamic]
interpExpr' _ (SrcName str) = return [ toDyn $ StringBox str ]
interpExpr' _ (CoreH str) = return [ toDyn $ CoreBox (CoreString str) ]
interpExpr' _ (ListH exprs) = do
dyns <- liftM fromDynList $ mapM (interpExpr' True) exprs
return $ toBoxedList dyns StringListBox
++ toBoxedList dyns (PathBox . pathToSnocPath)
++ toBoxedList dyns (TransformCorePathBox . return . pathToSnocPath)
++ toBoxedList dyns IntListBox
++ toBoxedList dyns RewriteCoreListBox
interpExpr' rhs (CmdName str)
| all isDigit str = do
let i = read str
return [
toDyn $ IntBox i
, toDyn $ TransformCorePathBox (deprecatedIntToPathT i)
]
| otherwise = do
dict <- gets (mkDict . cl_externals)
case M.lookup str dict of
Just dyns -> do
dyns' <- mapM provideState dyns
return $ if rhs then toDyn (StringBox str) : dyns' else dyns'
Nothing | rhs -> return [toDyn $ StringBox str]
| otherwise -> fail $ "User error, unrecognised HERMIT command: " ++ show str
interpExpr' _ (AppH e1 e2) = liftM2 dynCrossApply (interpExpr' False e1) (interpExpr' True e2)
provideState :: MonadState CommandLineState m => Dynamic -> m Dynamic
provideState dyn = do
st <- get
case dynApply dyn (toDyn $ box st) of
Just d -> return d
Nothing -> return dyn
dynCrossApply :: [Dynamic] -> [Dynamic] -> [Dynamic]
dynCrossApply fs xs = [ r | f <- fs, x <- xs, Just r <- return (dynApply f x)]