module HERMIT.Monad
(
HermitM
, runHM
, liftCoreM
, newGlobalIdH
, newIdH
, newTyVarH
, newCoVarH
, newVarH
, cloneVarH
, Label
, DefStash
, saveDef
, lookupDef
, getStash
, HasHermitMEnv(..)
, HasModGuts(..)
, HasHscEnv(..)
, HermitMEnv(..)
, DebugMessage(..)
, mkHermitMEnv
, sendDebugMessage
) where
import Prelude hiding (lookup)
import Data.Map
import Control.Monad
import Control.Monad.IO.Class
import Control.Applicative
import Control.Arrow
import Language.KURE
import HERMIT.Core
import HERMIT.Context
import HERMIT.Kure.SumTypes
import HERMIT.GHC
#if __GLASGOW_HASKELL__ > 706
import HERMIT.GHC.Typechecker
#endif
type Label = String
type DefStash = Map Label CoreDef
newtype HermitMEnv = HermitMEnv { hs_debugChan :: DebugMessage -> HermitM () }
newtype HermitM a = HermitM ((ModGuts,HermitMEnv) -> DefStash -> CoreM (KureM (DefStash, a)))
runHermitM :: HermitM a -> (ModGuts,HermitMEnv) -> DefStash -> CoreM (KureM (DefStash, a))
runHermitM (HermitM f) = f
runHM :: (ModGuts,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
getStash :: HermitM DefStash
getStash = HermitM (\ _ s -> return $ return (s, s))
putStash :: DefStash -> HermitM ()
putStash s = HermitM (\ _ _ -> return $ return (s, ()))
class HasHermitMEnv m where
getHermitMEnv :: m HermitMEnv
instance HasHermitMEnv HermitM where
getHermitMEnv = HermitM (\ rdr s -> return $ return (s, snd rdr))
class HasModGuts m where
getModGuts :: m ModGuts
instance HasModGuts HermitM where
getModGuts = HermitM (\ rdr s -> return $ return (s, fst rdr))
class HasHscEnv m where
getHscEnv :: m HscEnv
instance HasHscEnv CoreM where
getHscEnv = getHscEnvCoreM
instance HasHscEnv HermitM where
getHscEnv = liftCoreM getHscEnv
sendDebugMessage :: DebugMessage -> HermitM ()
sendDebugMessage msg = do env <- getHermitMEnv
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)
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 nm = do
#if __GLASGOW_HASKELL__ < 708
liftCoreM (lookupThing nm)
#else
guts <- getModGuts
liftCoreM $ runTcMtoCoreM guts $ tcLookupGlobal nm
#endif
instance HasDynFlags HermitM where
getDynFlags :: HermitM DynFlags
getDynFlags = liftCoreM getDynFlags
newName :: String -> HermitM Name
newName nm = mkSystemVarName <$> getUniqueM <*> pure (mkFastString nm)
newGlobalIdH :: String -> Type -> HermitM Id
newGlobalIdH nm ty = mkVanillaGlobal <$> newName nm <*> pure ty
newIdH :: String -> Type -> HermitM Id
newIdH nm ty = mkLocalId <$> newName nm <*> pure ty
newTyVarH :: String -> Kind -> HermitM TyVar
newTyVarH nm k = mkTyVar <$> newName nm <*> pure k
newCoVarH :: String -> Type -> HermitM TyVar
newCoVarH nm ty = mkCoVar <$> newName nm <*> pure ty
newVarH :: String -> KindOrType -> HermitM Var
newVarH name tk | isCoVarType tk = newCoVarH name tk
| isKind tk = newTyVarH name tk
| otherwise = newIdH name tk
cloneVarH :: (String -> String) -> Var -> HermitM Var
cloneVarH nameMod v | isTyVar v = newTyVarH name ty
| isCoVar v = newCoVarH name ty
| isId v = newIdH name ty
| otherwise = fail "If this variable isn't a type, coercion or identifier, then what is it?"
where
name = nameMod (uqName v)
ty = varType v
data DebugMessage = DebugTick String
| DebugCore String HermitC CoreTC
mkHermitMEnv :: (DebugMessage -> HermitM ()) -> HermitMEnv
mkHermitMEnv debugger = HermitMEnv { hs_debugChan = debugger }