module HERMIT.Context
(
AbsolutePathH
, LocalPathH
, HermitC
, topLevelHermitC
, HermitBindingSite(..)
, BindingDepth
, HermitBinding
, hbDepth
, hbSite
, hbPath
, hermitBindingSiteExpr
, hermitBindingSummary
, hermitBindingExpr
, AddBindings(..)
, addBindingGroup
, addDefBinding
, addDefBindingsExcept
, addLambdaBinding
, addAltBindings
, addCaseBinderBinding
, addForallBinding
, BoundVars(..)
, boundIn
, findBoundVars
, ReadBindings(..)
, lookupHermitBinding
, lookupHermitBindingDepth
, lookupHermitBindingSite
, inScope
, HasCoreRules(..)
, HasEmptyContext(..)
) where
import Prelude hiding (lookup)
import Control.Monad (liftM)
import Data.Monoid (mempty)
import Data.Map hiding (map, foldr, filter)
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
| MUTUALREC CoreExpr
| CASEALT
| CASEBINDER CoreExpr (AltCon,[Var])
| FORALL
| TOPLEVEL CoreExpr
data HermitBinding = HB { hbDepth :: BindingDepth
, hbSite :: HermitBindingSite
, hbPath :: AbsolutePathH
}
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
MUTUALREC 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."
CASEBINDER e _ -> return e
FORALL -> fail "variable is a universally quantified type variable."
TOPLEVEL e -> return e
hermitBindingSummary :: HermitBinding -> String
hermitBindingSummary b = show (hbDepth b) ++ "$" ++ case hbSite b of
LAM -> "LAM"
NONREC {} -> "NONREC"
REC {} -> "REC"
MUTUALREC {} -> "MUTUALREC"
SELFREC {} -> "SELFREC"
CASEALT -> "CASEALT"
CASEBINDER {} -> "CASEBINDER"
FORALL -> "FORALL"
TOPLEVEL {} -> "TOPLEVEL"
hermitBindingExpr :: HermitBinding -> KureM CoreExpr
hermitBindingExpr = hermitBindingSiteExpr . hbSite
class AddBindings c where
addHermitBindings :: [(Var,HermitBindingSite,AbsolutePathH)] -> c -> c
instance AddBindings (SnocPath crumb) where
addHermitBindings :: [(Var,HermitBindingSite,AbsolutePathH)] -> SnocPath crumb -> SnocPath crumb
addHermitBindings _ = id
instance ReadPath c Crumb => ReadPath (ExtendContext c e) Crumb where
absPath = absPath . baseContext
instance (AddBindings c, AddBindings e) => AddBindings (ExtendContext c e) where
addHermitBindings :: [(Var,HermitBindingSite,AbsolutePathH)] -> ExtendContext c e -> ExtendContext c e
addHermitBindings bnds c = c
{ baseContext = addHermitBindings bnds (baseContext c)
, extraContext = addHermitBindings bnds (extraContext c)
}
addBindingGroup :: (AddBindings c, ReadPath c Crumb) => CoreBind -> c -> c
addBindingGroup (NonRec v e) c = addHermitBindings [(v,NONREC e,absPath c @@ Let_Bind)] c
addBindingGroup (Rec ies) c = addHermitBindings [ (i, REC e, absPath c @@ Let_Bind) | (i,e) <- ies ] c
addDefBinding :: (AddBindings c, ReadPath c Crumb) => Id -> c -> c
addDefBinding i c = addHermitBindings [(i,SELFREC,absPath c @@ Def_Id)] c
addDefBindingsExcept :: (AddBindings c, ReadPath c Crumb) => Int -> [(Id,CoreExpr)] -> c -> c
addDefBindingsExcept n ies c = addHermitBindings [ (i, MUTUALREC e, absPath c @@ Rec_Def m) | (m,(i,e)) <- zip [0..] ies, m /= n ] c
addCaseBinderBinding :: (AddBindings c, ReadPath c Crumb) => (Id,CoreExpr,CoreAlt) -> c -> c
addCaseBinderBinding (i,e,(con,vs,_)) c = addHermitBindings [(i,CASEBINDER e (con,vs),absPath c @@ Case_Binder)] c
addLambdaBinding :: (AddBindings c, ReadPath c Crumb) => Var -> c -> c
addLambdaBinding v c = addHermitBindings [(v,LAM,absPath c @@ Lam_Var)] c
addAltBindings :: (AddBindings c, ReadPath c Crumb) => [Var] -> c -> c
addAltBindings vs c = addHermitBindings [ (v, CASEALT, absPath c @@ Alt_Var i) | (v,i) <- zip vs [1..] ] c
addForallBinding :: (AddBindings c, ReadPath c Crumb) => TyVar -> c -> c
addForallBinding v c = addHermitBindings [(v,FORALL,absPath c @@ ForAllTy_Var)] c
class BoundVars c where
boundVars :: c -> VarSet
instance BoundVars VarSet where
boundVars :: VarSet -> VarSet
boundVars = id
findBoundVars :: BoundVars c => (Var -> Bool) -> c -> VarSet
findBoundVars p = filterVarSet p . 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
inScope :: BoundVars c => c -> Var -> Bool
inScope c v = not (isDeadBinder v || (isLocalVar v && (v `notElemVarSet` boundVars 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 hbDepth . lookupHermitBinding v
lookupHermitBindingSite :: (ReadBindings c, Monad m) => Var -> BindingDepth -> c -> m HermitBindingSite
lookupHermitBindingSite v depth c = do HB 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 HasEmptyContext c where
setEmptyContext :: c -> c
type AbsolutePathH = AbsolutePath Crumb
type LocalPathH = LocalPath Crumb
data HermitC = HermitC
{ hermitC_bindings :: Map Var HermitBinding
, hermitC_depth :: BindingDepth
, hermitC_path :: AbsolutePathH
, hermitC_specRules :: [CoreRule]
}
instance HasEmptyContext HermitC where
setEmptyContext :: HermitC -> HermitC
setEmptyContext c = c
{ hermitC_bindings = empty
, hermitC_depth = 0
, hermitC_path = mempty
, hermitC_specRules = []
}
topLevelHermitC :: ModGuts -> HermitC
topLevelHermitC mg = let ies = concatMap bindToVarExprs (mg_binds mg)
in HermitC
{ hermitC_bindings = fromList [ (i , HB 0 (TOPLEVEL e) mempty) | (i,e) <- ies ]
, hermitC_depth = 0
, hermitC_path = mempty
, hermitC_specRules = concatMap (idCoreRules . fst) ies
}
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,AbsolutePathH)] -> HermitC -> HermitC
addHermitBindings vbs c =
let nextDepth = succ (hermitC_depth c)
vhbs = [ (v, HB nextDepth b p) | (v,b,p) <- vbs ]
in c { hermitC_bindings = fromList vhbs `union` hermitC_bindings c
, hermitC_depth = nextDepth
, hermitC_specRules = concat [ idCoreRules i | (i,_,_) <- vbs, isId i ] ++ hermitC_specRules c
}
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_specRules