3 {- This module contains a few primitive types that need to be wired in.
4 Most are defined in PrimEnv, which is automatically generated from
7 module Language.Core.Prims(initialEnv, primEnv, primId, bv,
8 tIntzh, tInt64zh, tCharzh, tFloatzh, tAddrzh, tDoublezh, tcStatezh,
9 tWordzh, tWord64zh, tByteArrayzh,
10 tcStablePtrzh, tcIO, mkInitialEnv, mkTypeEnv, tRWS, tBool, tcBool,
15 import Language.Core.Core
16 import Language.Core.Encoding
17 import Language.Core.Env
18 import Language.Core.Check
19 import Language.Core.PrimCoercions
20 import Language.Core.PrimEnv
23 initialEnv = efromlist [(primMname,primEnv),
28 -- Tediously, we add defs for ByteArray# etc. because these are
29 -- declared as ByteArr# (etc.) in primops.txt, and GHC has
30 -- ByteArray# etc. wired-in.
31 -- At least this is better than when all primops were wired-in here.
32 primEnv = Envs {tcenv_=efromlist $ map (\ (t,k) -> (t,Kind k)) $
33 [(snd tcByteArrayzh,ktByteArrayzh),
34 (snd tcMutableArrayzh, ktMutableArrayzh),
35 (snd tcMutableByteArrayzh, ktMutableByteArrayzh)] ++
36 ([(snd $ tcUtuple n, ktUtuple n) | n <- [1..maxUtuple]]
37 ++ ((snd tcArrow,ktArrow):primTcs)),
38 cenv_=efromlist primDcs,
39 venv_=efromlist (opsState ++ primVals)}
42 errorEnv = Envs {tcenv_=eempty,
44 venv_=efromlist errorVals}
46 -- Unpleasantly, we wire in the Bool type because some people
47 -- (i.e. me) need to depend on it being primitive. This shouldn't
48 -- hurt anything, since if someone pulls in the GHC.Bool module,
49 -- it will override this definition.
51 boolEnv = Envs {tcenv_=efromlist boolTcs,
52 cenv_=efromlist boolDcs,
55 boolTcs :: [(Tcon, KindOrCoercion)]
56 boolTcs = [(snd tcBool, Kind Klifted)]
58 boolDcs :: [(Dcon, Ty)]
59 boolDcs = [(dcTrue, tBool),
62 primDcs :: [(Dcon,Ty)]
63 primDcs = map (\ ((_,c),t) -> (c,t))
64 [(dcUtuple n, dcUtupleTy n) | n <- [1..maxUtuple]]
67 tRWS = tStatezh tRealWorld
69 opsState :: [(Var, Ty)]
71 ("realWorldzh", tRWS)]
75 tcByteArrayzh, tcMutableArrayzh, tcMutableByteArrayzh :: Qual Tcon
76 ktByteArrayzh, ktMutableArrayzh, ktMutableByteArrayzh :: Kind
78 tcByteArrayzh = pvz "ByteArray"
79 ktByteArrayzh = Kunlifted
81 tcMutableArrayzh = pvz "MutableArray"
82 ktMutableArrayzh = Karrow Klifted (Karrow Klifted Kunlifted)
84 tcMutableByteArrayzh = pvz "MutableByteArray"
85 ktMutableByteArrayzh = Karrow Klifted Kunlifted
87 {- Real world and state. -}
89 -- tjc: why isn't this one unboxed?
90 tcRealWorld :: Qual Tcon
91 tcRealWorld = pv "RealWorld"
93 tRealWorld = Tcon tcRealWorld
95 tcStatezh :: Qual Tcon
96 tcStatezh = pvz "State"
98 tStatezh t = Tapp (Tcon tcStatezh) t
100 {- Properly defined in PrelError, but needed in many modules before that. -}
101 errorVals :: [(Var, Ty)]
105 ("error", Tforall ("a",Kopen) (tArrow tString (Tvar "a"))),
106 ("irrefutPatError", str2A),
108 ("divZZeroError", forallAA),
109 ("overflowError", forallAA)]
112 {- Non-primitive, but mentioned in the types of primitives. -}
117 str2A, forallAA :: Ty
118 str2A = Tforall ("a",Kopen) (tArrow tAddrzh (Tvar "a"))
119 forallAA = Tforall ("a",Kopen) (Tvar "a")
124 tcBool = (Just boolMname, "Bool")
132 tList t = Tapp (Tcon tcList) t
134 tString = tList tChar
135 tIntzh, tInt64zh, tWordzh, tWord64zh, tCharzh, tFloatzh, tDoublezh, {-tIOUnit,-}
137 tIntzh = Tcon (primId "Int#")
138 tInt64zh = Tcon (primId "Int64#")
139 tWordzh = Tcon (primId "Word#")
140 tWord64zh = Tcon (primId "Word64#")
141 tByteArrayzh = Tcon (primId "ByteArray#")
142 tCharzh = Tcon (primId "Char#")
143 tFloatzh = Tcon (primId "Float#")
144 tDoublezh = Tcon (primId "Double#")
145 tcStablePtrzh, tcIO :: Qual Tcon
146 tcStablePtrzh = pvz "StablePtr"
147 tcIO = (Just (mkBaseMname "IOBase"), "IO")
149 primId :: String -> Qual Id
150 primId = pv . zEncodeString
152 --- doesn't really belong here... sigh
154 mkInitialEnv :: [Module] -> IO Menv
155 mkInitialEnv libs = foldM mkTypeEnv initialEnv libs
157 mkTypeEnv :: Menv -> Module -> IO Menv
158 mkTypeEnv globalEnv m@(Module mn _ _) =
159 catch (return (envsModule globalEnv m)) handler
161 putStrLn ("WARNING: mkTypeEnv caught an exception " ++ show e
162 ++ " while processing " ++ show mn)
166 ioBaseMname :: AnMname
167 ioBaseMname = mkBaseMname "IOBase"