module Language.Core.Prims(initialEnv, primEnv, primId,
tIntzh, tInt64zh, tCharzh, tFloatzh, tAddrzh, tDoublezh, tcStatezh,
tWordzh, tWord64zh, tByteArrayzh,
tcStablePtrzh, tcIO, mkInitialEnv, mkTypeEnv, tRWS, tBool, tcBool,
ioBaseMname) where
import Control.Monad
import Language.Core.Core
import Language.Core.Encoding
import Language.Core.Env
import Language.Core.Check
import Language.Core.PrimCoercions
import Language.Core.PrimEnv
initialEnv :: Menv
initialEnv = efromlist [(primMname,primEnv),
(errMname,errorEnv),
(boolMname,boolEnv)]
primEnv :: Envs
primEnv = Envs {tcenv_=efromlist $ map (\ (t,k) -> (t,Kind k)) $
[(snd tcByteArrayzh,ktByteArrayzh),
(snd tcMutableArrayzh, ktMutableArrayzh),
(snd tcMutableByteArrayzh, ktMutableByteArrayzh)] ++
([(snd $ tcUtuple n, ktUtuple n) | n <- [1..maxUtuple]]
++ ((snd tcArrow,ktArrow):primTcs)),
cenv_=efromlist primDcs,
venv_=efromlist (opsState ++ primVals)}
errorEnv :: Envs
errorEnv = Envs {tcenv_=eempty,
cenv_=eempty,
venv_=efromlist errorVals}
boolEnv :: Envs
boolEnv = Envs {tcenv_=efromlist boolTcs,
cenv_=efromlist boolDcs,
venv_=eempty}
boolTcs :: [(Tcon, KindOrCoercion)]
boolTcs = [(snd tcBool, Kind Klifted)]
boolDcs :: [(Dcon, Ty)]
boolDcs = [(dcTrue, tBool),
(dcFalse, tBool)]
primDcs :: [(Dcon,Ty)]
primDcs = map (\ ((_,c),t) -> (c,t))
[(dcUtuple n, dcUtupleTy n) | n <- [1..maxUtuple]]
tRWS :: Ty
tRWS = tStatezh tRealWorld
opsState :: [(Var, Ty)]
opsState = [
("realWorldzh", tRWS)]
tcByteArrayzh, tcMutableArrayzh, tcMutableByteArrayzh :: Qual Tcon
ktByteArrayzh, ktMutableArrayzh, ktMutableByteArrayzh :: Kind
tcByteArrayzh = pvz "ByteArray"
ktByteArrayzh = Kunlifted
tcMutableArrayzh = pvz "MutableArray"
ktMutableArrayzh = Karrow Klifted (Karrow Klifted Kunlifted)
tcMutableByteArrayzh = pvz "MutableByteArray"
ktMutableByteArrayzh = Karrow Klifted Kunlifted
tcRealWorld :: Qual Tcon
tcRealWorld = pv "RealWorld"
tRealWorld :: Ty
tRealWorld = Tcon tcRealWorld
tcStatezh :: Qual Tcon
tcStatezh = pvz "State"
tStatezh :: Ty -> Ty
tStatezh t = Tapp (Tcon tcStatezh) t
errorVals :: [(Var, Ty)]
errorVals = []
tBool :: Ty
tBool = Tcon tcBool
tcBool :: Qual Tcon
tcBool = (Just boolMname, "Bool")
tIntzh, tInt64zh, tWordzh, tWord64zh, tCharzh, tFloatzh, tDoublezh,
tByteArrayzh :: Ty
tIntzh = Tcon (primId "Int#")
tInt64zh = Tcon (primId "Int64#")
tWordzh = Tcon (primId "Word#")
tWord64zh = Tcon (primId "Word64#")
tByteArrayzh = Tcon (primId "ByteArray#")
tCharzh = Tcon (primId "Char#")
tFloatzh = Tcon (primId "Float#")
tDoublezh = Tcon (primId "Double#")
tcStablePtrzh, tcIO :: Qual Tcon
tcStablePtrzh = pvz "StablePtr"
tcIO = (Just (mkBaseMname "IOBase"), "IO")
primId :: String -> Qual Id
primId = pv . zEncodeString
mkInitialEnv :: [Module] -> IO Menv
mkInitialEnv libs = foldM mkTypeEnv initialEnv libs
mkTypeEnv :: Menv -> Module -> IO Menv
mkTypeEnv globalEnv m@(Module mn _ _) =
catch (return (envsModule globalEnv m)) handler
where handler e = do
putStrLn ("WARNING: mkTypeEnv caught an exception " ++ show e
++ " while processing " ++ show mn)
return globalEnv
ioBaseMname :: AnMname
ioBaseMname = mkBaseMname "IOBase"