module Language.HERMIT.Context
(
HermitBinding(..)
, hermitBindingDepth
, Context
, initContext
, (@@)
, addAltBindings
, addBinding
, addCaseBinding
, addLambdaBinding
, hermitBindings
, hermitDepth
, hermitPath
, hermitModGuts
, lookupHermitBinding
, listBindings
, boundIn
) where
import Prelude hiding (lookup)
import GhcPlugins hiding (empty)
import Data.Map hiding (map, foldr)
import Language.KURE
data HermitBinding
= BIND Int Bool CoreExpr
| LAM Int
| CASE Int CoreExpr (AltCon,[Id])
hermitBindingDepth :: HermitBinding -> Int
hermitBindingDepth (LAM d) = d
hermitBindingDepth (BIND d _ _) = d
hermitBindingDepth (CASE d _ _) = d
data Context = Context
{ hermitBindings :: Map Id HermitBinding
, hermitDepth :: Int
, hermitPath :: AbsolutePath
, hermitModGuts :: ModGuts
}
instance PathContext Context where
contextPath :: Context -> AbsolutePath
contextPath = hermitPath
initContext :: ModGuts -> Context
initContext modGuts = Context empty 0 rootAbsPath modGuts
(@@) :: Context -> Int -> Context
(@@) env n = env { hermitPath = extendAbsPath n (hermitPath env) }
addBinding :: CoreBind -> Context -> Context
addBinding (NonRec n e) env
= env { hermitBindings = insert n (BIND next_depth False e) (hermitBindings env)
, hermitDepth = next_depth
}
where
next_depth = succ (hermitDepth env)
addBinding (Rec bds) env
= env { hermitBindings = bds_env `union` hermitBindings env
, hermitDepth = next_depth
}
where
next_depth = succ (hermitDepth env)
bds_env = fromList
[ (b,BIND next_depth True e)
| (b,e) <- bds
]
addCaseBinding :: (Id,CoreExpr,CoreAlt) -> Context -> Context
addCaseBinding (n,e,(ac,is,_)) env
= env { hermitBindings = insert n (CASE next_depth e (ac,is)) (hermitBindings env)
, hermitDepth = next_depth
}
where
next_depth = succ (hermitDepth env)
addLambdaBinding :: Id -> Context -> Context
addLambdaBinding n env
= env { hermitBindings = insert n (LAM next_depth) (hermitBindings env)
, hermitDepth = next_depth
}
where
next_depth = succ (hermitDepth env)
addAltBindings :: [Id] -> Context -> Context
addAltBindings ns env
= env { hermitBindings = foldr (\n bds -> insert n (LAM next_depth) bds) (hermitBindings env) ns
, hermitDepth = next_depth
}
where next_depth = succ (hermitDepth env)
lookupHermitBinding :: Id -> Context -> Maybe HermitBinding
lookupHermitBinding n env = lookup n (hermitBindings env)
listBindings :: Context -> [Id]
listBindings = keys . hermitBindings
boundIn :: Id -> Context -> Bool
boundIn i c = i `elem` listBindings c