module Language.HERMIT.Context
(
HermitC
, initHermitC
, HermitBindingSite(..)
, BindingDepth
, HermitBinding
, hermitBindingSiteExpr
, hermitBindingExpr
, AddBindings(..)
, addBindingGroup
, addLambdaBinding
, addAltBindings
, addCaseWildBinding
, addForallBinding
, BoundVars(..)
, boundIn
, findBoundVars
, ReadBindings(..)
, lookupHermitBinding
, HasGlobalRdrEnv(..)
, HasCoreRules(..)
) where
import Prelude hiding (lookup)
import GhcPlugins hiding (empty)
import Data.Monoid (mempty)
import Data.Map hiding (map, foldr, filter)
import qualified Data.Set as S
import qualified Language.Haskell.TH as TH
import Language.KURE
import Language.HERMIT.Core
import Language.HERMIT.GHC
type BindingDepth = Int
data HermitBindingSite
= REC CoreExpr
| NONREC CoreExpr
| LAM
| CASEALT
| FORALL
| CASEWILD CoreExpr (AltCon,[Var])
type HermitBinding = (BindingDepth, HermitBindingSite)
hermitBindingSiteExpr :: HermitBindingSite -> Maybe CoreExpr
hermitBindingSiteExpr b = case b of
REC e -> Just e
NONREC e -> Just e
CASEWILD e _ -> Just e
_ -> Nothing
hermitBindingExpr :: HermitBinding -> Maybe 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
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 ]
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 -> S.Set Var
findBoundVars :: BoundVars c => TH.Name -> c -> [Var]
findBoundVars nm = filter (cmpTHName2Var nm) . S.toList . 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 => Var -> c -> Maybe HermitBinding
lookupHermitBinding v = lookup v . hermitBindings
class HasCoreRules c where
hermitCoreRules :: c -> [CoreRule]
class HasGlobalRdrEnv c where
hermitGlobalRdrEnv :: c -> GlobalRdrEnv
data HermitC = HermitC
{ hermitC_bindings :: Map Var HermitBinding
, hermitC_depth :: BindingDepth
, hermitC_path :: AbsolutePath Crumb
, 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 >>= bindToIdExprs >>= (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 -> S.Set Var
boundVars = keysSet . 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