module HERMIT.Interp
(
Interp
, interp
, interpExprH
) where
import Control.Monad (liftM, liftM2)
import Data.Char
import Data.Dynamic
import qualified Data.Map as M
import qualified Language.Haskell.TH as TH
import HERMIT.External
import HERMIT.Parser
import HERMIT.Kure (deprecatedIntToPathT,pathToSnocPath)
interpExprH :: Monad m => Dictionary -> [Interp a] -> ExprH -> m a
interpExprH dict interps e = do dyns <- interpExpr dict e
runInterp dyns interps
runInterp :: Monad m => [Dynamic] -> [Interp b] -> m b
runInterp dyns interps = case [f a | Interp f <- interps, Just a <- map fromDynamic dyns] of
[] -> fail "User error, HERMIT command does not type-check."
b:_ -> return b
data Interp :: * -> * where
Interp :: Typeable a => (a -> b) -> Interp b
interp :: Typeable a => (a -> b) -> Interp b
interp = Interp
instance Functor Interp where
fmap :: (a -> b) -> Interp a -> Interp b
fmap f (Interp g) = Interp (f . g)
interpExpr :: Monad m => Dictionary -> 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' :: Monad m => Bool -> Dictionary -> ExprH -> m [Dynamic]
interpExpr' _ _ (SrcName str) = return [ toDyn $ NameBox $ TH.mkName str ]
interpExpr' _ _ (CoreH str) = return [ toDyn $ CoreBox (CoreString str) ]
interpExpr' _ dict (ListH exprs) = do dyns <- liftM fromDynList $ mapM (interpExpr' True dict) exprs
return $ toBoxedList dyns NameListBox
++ toBoxedList dyns StringListBox
++ toBoxedList dyns (PathBox . pathToSnocPath)
++ toBoxedList dyns (TranslateCorePathBox . return . pathToSnocPath)
++ toBoxedList dyns IntListBox
++ toBoxedList dyns RewriteCoreListBox
interpExpr' rhs dict (CmdName str)
| all isDigit str = let i = read str in
return [ toDyn $ IntBox i
, toDyn $ TranslateCorePathBox (deprecatedIntToPathT i)
]
| Just dyn <- M.lookup str dict = return $ if rhs
then toDyn (StringBox str) : dyn
else dyn
| rhs = return [toDyn $ StringBox str]
| otherwise = fail $ "User error, unrecognised HERMIT command: " ++ show str
interpExpr' _ env (AppH e1 e2) = dynAppMsg (interpExpr' False env e1) (interpExpr' True env e2)
dynAppMsg :: Monad m => m [Dynamic] -> m [Dynamic] -> m [Dynamic]
dynAppMsg = liftM2 dynApply'
where
dynApply' :: [Dynamic] -> [Dynamic] -> [Dynamic]
dynApply' fs xs = [ r | f <- fs, x <- xs, Just r <- return (dynApply f x)]