module HERMIT.Context
(
AbsolutePathH
, LocalPathH
, HermitC
, initHermitC
, HermitBindingSite(..)
, BindingDepth
, HermitBinding
, hermitBindingSiteExpr
, hermitBindingExpr
, AddBindings(..)
, addBindingGroup
, addDefBinding
, addDefBindingsExcept
, addLambdaBinding
, addAltBindings
, addCaseWildBinding
, addForallBinding
, BoundVars(..)
, boundIn
, findBoundVars
, ReadBindings(..)
, lookupHermitBinding
, lookupHermitBindingDepth
, lookupHermitBindingSite
, HasGlobalRdrEnv(..)
, HasCoreRules(..)
) where
import Prelude hiding (lookup)
import Control.Monad (liftM)
import Data.Monoid (mempty)
import Data.Map hiding (map, foldr, filter)
import qualified Language.Haskell.TH as TH
import Language.KURE
import Language.KURE.ExtendableContext
import HERMIT.Core
import HERMIT.GHC hiding (empty)
type BindingDepth = Int
data HermitBindingSite = LAM
| NONREC CoreExpr
| REC CoreExpr
| SELFREC
| CASEALT
| CASEWILD CoreExpr (AltCon,[Var])
| FORALL
type HermitBinding = (BindingDepth, HermitBindingSite)
hermitBindingSiteExpr :: HermitBindingSite -> KureM CoreExpr
hermitBindingSiteExpr b = case b of
LAM -> fail "variable is lambda-bound, not bound to an expression."
NONREC e -> return e
REC e -> return e
SELFREC -> fail "identifier recursively refers to the expression under consideration."
CASEALT -> fail "variable is bound in a case alternative, not bound to an expression."
CASEWILD e _ -> return e
FORALL -> fail "variable is a universally quantified type variable."
hermitBindingExpr :: HermitBinding -> KureM CoreExpr
hermitBindingExpr = hermitBindingSiteExpr . snd
class AddBindings c where
addHermitBindings :: [(Var,HermitBindingSite)] -> c -> c
instance AddBindings (SnocPath crumb) where
addHermitBindings :: [(Var,HermitBindingSite)] -> SnocPath crumb -> SnocPath crumb
addHermitBindings _ = id
instance (AddBindings c, AddBindings e) => AddBindings (ExtendContext c e) where
addHermitBindings :: [(Var,HermitBindingSite)] -> ExtendContext c e -> ExtendContext c e
addHermitBindings bnds c = c
{ baseContext = addHermitBindings bnds (baseContext c)
, extraContext = addHermitBindings bnds (extraContext c)
}
addHermitBinding :: AddBindings c => Var -> HermitBindingSite -> c -> c
addHermitBinding v bd = addHermitBindings [(v,bd)]
addBindingGroup :: AddBindings c => CoreBind -> c -> c
addBindingGroup (NonRec v e) = addHermitBinding v (NONREC e)
addBindingGroup (Rec ies) = addHermitBindings [ (i, REC e) | (i,e) <- ies ]
addDefBinding :: AddBindings c => Id -> c -> c
addDefBinding i = addHermitBinding i SELFREC
addDefBindingsExcept :: AddBindings c => Int -> [(Id,CoreExpr)] -> c -> c
addDefBindingsExcept n ies = addHermitBindings [ (i, REC e) | (m,(i,e)) <- zip [0..] ies, m /= n ]
addCaseWildBinding :: AddBindings c => (Id,CoreExpr,CoreAlt) -> c -> c
addCaseWildBinding (i,e,(con,vs,_)) = addHermitBinding i (CASEWILD e (con,vs))
addLambdaBinding :: AddBindings c => Var -> c -> c
addLambdaBinding v = addHermitBinding v LAM
addAltBindings :: AddBindings c => [Var] -> c -> c
addAltBindings vs = addHermitBindings [ (v, CASEALT) | v <- vs ]
addForallBinding :: AddBindings c => TyVar -> c -> c
addForallBinding v = addHermitBinding v FORALL
class BoundVars c where
boundVars :: c -> VarSet
instance BoundVars VarSet where
boundVars :: VarSet -> VarSet
boundVars = id
findBoundVars :: BoundVars c => TH.Name -> c -> VarSet
findBoundVars nm = filterVarSet (cmpTHName2Var nm) . boundVars
class BoundVars c => ReadBindings c where
hermitDepth :: c -> BindingDepth
hermitBindings :: c -> Map Var HermitBinding
boundIn :: ReadBindings c => Var -> c -> Bool
boundIn i c = i `member` hermitBindings c
lookupHermitBinding :: (ReadBindings c, Monad m) => Var -> c -> m HermitBinding
lookupHermitBinding v = maybe (fail "binding not found in HERMIT context.") return . lookup v . hermitBindings
lookupHermitBindingDepth :: (ReadBindings c, Monad m) => Var -> c -> m BindingDepth
lookupHermitBindingDepth v = liftM fst . lookupHermitBinding v
lookupHermitBindingSite :: (ReadBindings c, Monad m) => Var -> BindingDepth -> c -> m HermitBindingSite
lookupHermitBindingSite v depth c = do (d,bnd) <- lookupHermitBinding v c
guardMsg (d == depth) "lookupHermitBinding succeeded, but depth does not match. The variable has probably been shadowed."
return bnd
class HasCoreRules c where
hermitCoreRules :: c -> [CoreRule]
instance HasCoreRules [CoreRule] where
hermitCoreRules :: [CoreRule] -> [CoreRule]
hermitCoreRules = id
class HasGlobalRdrEnv c where
hermitGlobalRdrEnv :: c -> GlobalRdrEnv
instance HasGlobalRdrEnv GlobalRdrEnv where
hermitGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv
hermitGlobalRdrEnv = id
type AbsolutePathH = AbsolutePath Crumb
type LocalPathH = LocalPath Crumb
data HermitC = HermitC
{ hermitC_bindings :: Map Var HermitBinding
, hermitC_depth :: BindingDepth
, hermitC_path :: AbsolutePathH
, hermitC_globalRdrEnv :: GlobalRdrEnv
, hermitC_coreRules :: [CoreRule]
}
initHermitC :: ModGuts -> HermitC
initHermitC modGuts = HermitC
{ hermitC_bindings = empty
, hermitC_depth = 0
, hermitC_path = mempty
, hermitC_globalRdrEnv = mg_rdr_env modGuts
, hermitC_coreRules = mg_rules modGuts ++ other_rules
}
where other_rules :: [CoreRule]
other_rules = mg_binds modGuts >>= bindToVarExprs >>= (idCoreRules . fst)
instance ReadPath HermitC Crumb where
absPath :: HermitC -> AbsolutePath Crumb
absPath = hermitC_path
instance ExtendPath HermitC Crumb where
(@@) :: HermitC -> Crumb -> HermitC
c @@ n = c { hermitC_path = hermitC_path c @@ n }
instance AddBindings HermitC where
addHermitBindings :: [(Var,HermitBindingSite)] -> HermitC -> HermitC
addHermitBindings vbs c = let nextDepth = succ (hermitC_depth c)
vhbs = [ (v, (nextDepth,b)) | (v,b) <- vbs ]
in c { hermitC_bindings = fromList vhbs `union` hermitC_bindings c
, hermitC_depth = nextDepth
}
instance BoundVars HermitC where
boundVars :: HermitC -> VarSet
boundVars = mkVarSet . keys . hermitC_bindings
instance ReadBindings HermitC where
hermitDepth :: HermitC -> BindingDepth
hermitDepth = hermitC_depth
hermitBindings :: HermitC -> Map Var HermitBinding
hermitBindings = hermitC_bindings
instance HasCoreRules HermitC where
hermitCoreRules :: HermitC -> [CoreRule]
hermitCoreRules = hermitC_coreRules
instance HasGlobalRdrEnv HermitC where
hermitGlobalRdrEnv :: HermitC -> GlobalRdrEnv
hermitGlobalRdrEnv = hermitC_globalRdrEnv