module DDC.Type.Env
( Env(..)
, empty
, extend, extends
, setPrimFun, isPrim
, fromList
, union
, member, memberBind
, lookup, lookupName
, depth
, wrapTForalls)
where
import DDC.Type.Exp
import Data.Maybe
import Data.Map (Map)
import Prelude hiding (lookup)
import qualified Data.Map as Map
import qualified Prelude as P
import Control.Monad
data Env n
= Env
{
envMap :: Map n (Type n)
, envStack :: [Type n]
, envStackLength :: Int
, envPrimFun :: n -> Maybe (Type n) }
empty :: Env n
empty = Env
{ envMap = Map.empty
, envStack = []
, envStackLength = 0
, envPrimFun = \_ -> Nothing }
extend :: Ord n => Bind n -> Env n -> Env n
extend bb env
= case bb of
BName n k -> env { envMap = Map.insert n k (envMap env) }
BAnon k -> env { envStack = k : envStack env
, envStackLength = envStackLength env + 1 }
BNone{} -> env
extends :: Ord n => [Bind n] -> Env n -> Env n
extends bs env
= foldl (flip extend) env bs
setPrimFun :: (n -> Maybe (Type n)) -> Env n -> Env n
setPrimFun f env
= env { envPrimFun = f }
isPrim :: Env n -> n -> Bool
isPrim env n
= isJust $ envPrimFun env n
fromList :: Ord n => [Bind n] -> Env n
fromList bs
= foldr extend empty bs
union :: Ord n => Env n -> Env n -> Env n
union env1 env2
= Env
{ envMap = envMap env1 `Map.union` envMap env2
, envStack = envStack env2 ++ envStack env1
, envStackLength = envStackLength env2 + envStackLength env1
, envPrimFun = \n -> envPrimFun env2 n `mplus` envPrimFun env1 n }
member :: Ord n => Bound n -> Env n -> Bool
member uu env
= isJust $ lookup uu env
memberBind :: Ord n => Bind n -> Env n -> Bool
memberBind uu env
= case uu of
BName n _ -> Map.member n (envMap env)
_ -> False
lookup :: Ord n => Bound n -> Env n -> Maybe (Type n)
lookup uu env
= case uu of
UName n _
-> Map.lookup n (envMap env)
`mplus` envPrimFun env n
UIx i _
-> P.lookup i (zip [0..] (envStack env))
UPrim n _
-> envPrimFun env n
lookupName :: Ord n => n -> Env n -> Maybe (Type n)
lookupName n env
= Map.lookup n (envMap env)
depth :: Env n -> Int
depth env = envStackLength env
wrapTForalls :: Ord n => Env n -> Type n -> Type n
wrapTForalls env tBody
= let bsNamed = [BName b t | (b, t) <- Map.toList $ envMap env ]
bsAnon = [BAnon t | t <- envStack env]
tInner = foldr TForall tBody (reverse bsAnon)
in foldr TForall tInner bsNamed