module Language.HERMIT.Interp
(
Interp
, interp
, interpExprH
) where
import Control.Monad (liftM2)
import Data.Char
import Data.Dynamic
import qualified Data.Map as M
import qualified Language.Haskell.TH as TH
import Language.HERMIT.External
import Language.HERMIT.Expr
interpExprH :: M.Map String [Dynamic] -> [Interp a] -> ExprH -> Either String a
interpExprH env interps =
either Left (\ dyns -> runInterp dyns (map (fmap Right) interps) (Left "User error, HERMIT command does not type-check."))
. interpExpr env
runInterp :: [Dynamic] -> [Interp b] -> b -> b
runInterp dyns interps bad = head $
[f a
| Interp f <- interps
, Just a <- map fromDynamic dyns
] ++ [ bad ]
data Interp :: * -> * where
Interp :: Typeable a => (a -> b) -> Interp b
interp :: Typeable a => (a -> b) -> Interp b
interp = Interp
instance Functor Interp where
fmap f (Interp g) = Interp (f . g)
interpExpr :: M.Map String [Dynamic] -> ExprH -> Either String [Dynamic]
interpExpr = interpExpr' False
interpExpr' :: Bool -> M.Map String [Dynamic] -> ExprH -> Either String [Dynamic]
interpExpr' _ _ (SrcName str) = return [ toDyn $ NameBox $ TH.mkName str ]
interpExpr' rhs env (CmdName str)
| all isDigit str = return [ toDyn $ IntBox $ read str ]
| Just dyn <- M.lookup str env = return $ if rhs
then toDyn (StringBox str) : dyn
else dyn
| rhs = return [toDyn $ StringBox str]
| otherwise = Left $ "User error, unrecognised HERMIT command: " ++ show str
interpExpr' _ env (AppH e1 e2) = dynAppMsg (interpExpr' False env e1) (interpExpr' True env e2)
dynAppMsg :: Either String [Dynamic] -> Either String [Dynamic] -> Either String [Dynamic]
dynAppMsg = liftM2 dynApply'
where
dynApply' :: [Dynamic] -> [Dynamic] -> [Dynamic]
dynApply' fs xs = [ r | f <- fs, x <- xs, Just r <- return (dynApply f x)]