module Language.HERMIT.Monad
(
HermitM
, runHM
, liftCoreM
, newIdH
, newTyVarH
, cloneVarH
, Label
, DefStash
, saveDef
, lookupDef
, getStash
, HermitMEnv(..)
, DebugMessage(..)
, mkHermitMEnv
, sendDebugMessage
) where
import Prelude hiding (lookup)
import Data.Map
import GhcPlugins hiding (empty)
import MonadUtils
import Control.Monad
import Control.Arrow
import Language.KURE
import Language.HERMIT.Core
import Language.HERMIT.Context
import Language.HERMIT.Kure.SumTypes
type Label = String
type DefStash = Map Label CoreDef
newtype HermitMEnv = HermitMEnv { hs_debugChan :: DebugMessage -> HermitM () }
newtype HermitM a = HermitM (HermitMEnv -> DefStash -> CoreM (KureM (DefStash, a)))
runHermitM :: HermitM a -> HermitMEnv -> DefStash -> CoreM (KureM (DefStash, a))
runHermitM (HermitM f) = f
getStash :: HermitM DefStash
getStash = HermitM (\ _ s -> return $ return (s, s))
putStash :: DefStash -> HermitM ()
putStash s = HermitM (\ _ _ -> return $ return (s, ()))
sendDebugMessage :: DebugMessage -> HermitM ()
sendDebugMessage msg = do env <- HermitM $ \ ch s -> return $ return (s, ch)
hs_debugChan env msg
saveDef :: Label -> CoreDef -> HermitM ()
saveDef l d = getStash >>= (insert l d >>> putStash)
lookupDef :: Label -> HermitM CoreDef
lookupDef l = getStash >>= (lookup l >>> maybe (fail "Definition not found.") return)
runHM :: HermitMEnv -> DefStash -> (DefStash -> a -> CoreM b) -> (String -> CoreM b) -> HermitM a -> CoreM b
runHM env s success failure ma = runHermitM ma env s >>= runKureM (\ (a,b) -> success a b) failure
instance Functor HermitM where
fmap :: (a -> b) -> HermitM a -> HermitM b
fmap = liftM
instance Applicative HermitM where
pure :: a -> HermitM a
pure = return
(<*>) :: HermitM (a -> b) -> HermitM a -> HermitM b
(<*>) = ap
instance Monad HermitM where
return :: a -> HermitM a
return a = HermitM $ \ _ s -> return (return (s,a))
(>>=) :: HermitM a -> (a -> HermitM b) -> HermitM b
(HermitM gcm) >>= f = HermitM $ \ env -> gcm env >=> runKureM (\ (s', a) -> runHermitM (f a) env s') (return . fail)
fail :: String -> HermitM a
fail msg = HermitM $ \ _ _ -> return (fail msg)
instance MonadCatch HermitM where
catchM :: HermitM a -> (String -> HermitM a) -> HermitM a
(HermitM gcm) `catchM` f = HermitM $ \ env s -> gcm env s >>= runKureM (return.return) (\ msg -> runHermitM (f msg) env s)
liftCoreM :: CoreM a -> HermitM a
liftCoreM ma = HermitM $ \ _ s -> do a <- ma
return (return (s,a))
instance MonadIO HermitM where
liftIO :: IO a -> HermitM a
liftIO = liftCoreM . liftIO
instance MonadUnique HermitM where
getUniqueSupplyM :: HermitM UniqSupply
getUniqueSupplyM = liftCoreM getUniqueSupplyM
instance MonadThings HermitM where
lookupThing :: Name -> HermitM TyThing
lookupThing = liftCoreM . lookupThing
instance HasDynFlags HermitM where
getDynFlags :: HermitM DynFlags
getDynFlags = liftCoreM getDynFlags
newName :: String -> HermitM Name
newName name = do uq <- getUniqueM
return $ mkSystemVarName uq $ mkFastString name
newIdH :: String -> Type -> HermitM Id
newIdH name ty = do name' <- newName name
return $ mkLocalId name' ty
newTyVarH :: String -> Kind -> HermitM TyVar
newTyVarH name kind = do name' <- newName name
return $ mkTyVar name' kind
cloneVarH :: (String -> String) -> Var -> HermitM Var
cloneVarH nameMod v =
let name = nameMod (getOccString v)
ty = varType v
in
if isTyVar v
then newTyVarH name ty
else newIdH name ty
data DebugMessage = DebugTick String
| DebugCore String HermitC Core
mkHermitMEnv :: (DebugMessage -> HermitM ()) -> HermitMEnv
mkHermitMEnv debugger = HermitMEnv
{ hs_debugChan = debugger
}