1 module Environment
    2        (Env, emptyEnv, extendLocal, extendGlobal,
    3         makeEnv, unmakeEnv, lookupEnv, domEnv, freeTVarEnv)
    4        where
    5 
    6 import Shows
    7 import Parse
    8 import Term           (VarId, readsId)
    9 import Type           (TVarId, TConId, MonoType, PolyType (All), freeTVarPoly)
   10 import FiniteMap      (FM, emptyFM, lookupFM, extendFM, makeFM, unmakeFM,
   11                        mapFM, domFM, ranFM)
   12 data  Env             =   MkEnv (FM VarId PolyType)
   13 rep                   ::  Env -> FM VarId PolyType
   14 rep (MkEnv f)         =   f
   15 emptyEnv              ::  Env
   16 emptyEnv              =   MkEnv emptyFM
   17 extendLocal           ::  Env -> VarId -> MonoType -> Env
   18 extendLocal env x t   =   MkEnv (extendFM (rep env) x (All [] t))
   19 extendGlobal          ::  Env -> VarId -> PolyType -> Env
   20 extendGlobal env x t  =   MkEnv (extendFM (rep env) x t)
   21 makeEnv               ::  [(VarId, PolyType)] -> Env
   22 makeEnv               =   MkEnv . makeFM
   23 unmakeEnv             ::  Env -> [(VarId, PolyType)]
   24 unmakeEnv             =   unmakeFM . rep
   25 lookupEnv             ::  Env -> VarId -> PolyType
   26 lookupEnv env x       =   lookupFM (rep env) x
   27 domEnv                ::  Env -> [VarId]
   28 domEnv env            =   domFM (rep env)
   29 freeTVarEnv           ::  Env -> [TVarId]
   30 freeTVarEnv env       =   concat (map freeTVarPoly (ranFM (rep env)))
   31 instance  Read Env  where
   32       readsPrec d  =  readsEnv
   33 instance  Show Env  where
   34       showsPrec d  =  showsEnv
   35 readsEnv              :: Parses Env
   36 readsEnv              =  listP readsPair `eachP` makeEnv
   37 readsPair             :: Parses (VarId, PolyType)
   38 readsPair             =       readsId         `thenP` (\x ->
   39                               lexP ":"        `thenP` (\_ ->
   40                               reads           `thenP` (\t ->
   41                                               returnP (x,t))))
   42 showsEnv              :: Shows Env
   43 showsEnv              =  showsSurround "[" (showsStarSep ",\n " showsPair) "]"
   44                       .  unmakeEnv
   45 showsPair             :: Shows (VarId, PolyType)
   46 showsPair (x,t)       =  showsString x . showsString " : " . shows t