utils/ext-core/Language/Core/Prims.hs

   1 {-# OPTIONS -Wall #-}
   2
   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
   5    GHC's primops.txt. -}
   6
   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,
  11              ioBaseMname) where
  12
  13 import Control.Monad
  14
  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
  21
  22 initialEnv :: Menv
  23 initialEnv = efromlist [(primMname,primEnv),
  24                      (errMname,errorEnv),
  25                      (boolMname,boolEnv)]
  26
  27 primEnv :: Envs
  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)}
  40
  41 errorEnv :: Envs
  42 errorEnv = Envs {tcenv_=eempty,
  43                  cenv_=eempty,
  44                  venv_=efromlist errorVals}
  45
  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.
  50 boolEnv :: Envs
  51 boolEnv = Envs {tcenv_=efromlist boolTcs,
  52                 cenv_=efromlist boolDcs,
  53                 venv_=eempty}
  54
  55 boolTcs :: [(Tcon, KindOrCoercion)]
  56 boolTcs = [(snd tcBool, Kind Klifted)]
  57
  58 boolDcs :: [(Dcon, Ty)]
  59 boolDcs = [(dcTrue, tBool),
  60            (dcFalse, tBool)]
  61
  62 primDcs :: [(Dcon,Ty)]
  63 primDcs = map (\ ((_,c),t) -> (c,t))
  64               [(dcUtuple n, dcUtupleTy n) | n <- [1..maxUtuple]]
  65
  66 tRWS :: Ty
  67 tRWS = tStatezh tRealWorld
  68
  69 opsState :: [(Var, Ty)]
  70 opsState = [
  71   ("realWorldzh", tRWS)]
  72
  73 {- Arrays -}
  74
  75 tcByteArrayzh, tcMutableArrayzh, tcMutableByteArrayzh :: Qual Tcon
  76 ktByteArrayzh, ktMutableArrayzh, ktMutableByteArrayzh :: Kind
  77
  78 tcByteArrayzh = pvz "ByteArray"
  79 ktByteArrayzh = Kunlifted
  80
  81 tcMutableArrayzh = pvz "MutableArray"
  82 ktMutableArrayzh = Karrow Klifted (Karrow Klifted Kunlifted)
  83
  84 tcMutableByteArrayzh = pvz "MutableByteArray"
  85 ktMutableByteArrayzh = Karrow Klifted Kunlifted
  86
  87 {- Real world and state. -}
  88
  89 -- tjc: why isn't this one unboxed?
  90 tcRealWorld :: Qual Tcon
  91 tcRealWorld = pv "RealWorld"
  92 tRealWorld :: Ty
  93 tRealWorld = Tcon tcRealWorld
  94
  95 tcStatezh :: Qual Tcon
  96 tcStatezh = pvz "State"
  97 tStatezh :: Ty -> Ty
  98 tStatezh t = Tapp (Tcon tcStatezh) t
  99
 100 {- Properly defined in PrelError, but needed in many modules before that. -}
 101 errorVals :: [(Var, Ty)]
 102 errorVals = []
 103 {-
 104  [
 105  ("error", Tforall ("a",Kopen) (tArrow tString (Tvar "a"))),
 106  ("irrefutPatError", str2A),
 107  ("patError", str2A),
 108  ("divZZeroError", forallAA),
 109  ("overflowError", forallAA)]
 110 -}
 111
 112 {- Non-primitive, but mentioned in the types of primitives. -}
 113
 114 bv :: a -> Qual a
 115 bv = qual baseMname
 116
 117 str2A, forallAA :: Ty
 118 str2A = Tforall ("a",Kopen) (tArrow tAddrzh (Tvar "a"))
 119 forallAA = Tforall ("a",Kopen) (Tvar "a")
 120
 121 tBool :: Ty
 122 tBool = Tcon tcBool
 123 tcBool :: Qual Tcon
 124 tcBool = (Just boolMname, "Bool")
 125 tcChar :: Qual Tcon
 126 tcChar = bv "Char"
 127 tChar :: Ty
 128 tChar = Tcon tcChar
 129 tcList :: Qual Tcon
 130 tcList = bv "ZMZN"
 131 tList :: Ty -> Ty
 132 tList t = Tapp (Tcon tcList) t
 133 tString :: Ty
 134 tString = tList tChar
 135 tIntzh, tInt64zh, tWordzh, tWord64zh, tCharzh, tFloatzh, tDoublezh, {-tIOUnit,-}
 136   tByteArrayzh :: Ty
 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")
 148
 149 primId :: String -> Qual Id
 150 primId = pv . zEncodeString
 151
 152 --- doesn't really belong here... sigh
 153
 154 mkInitialEnv :: [Module] -> IO Menv
 155 mkInitialEnv libs = foldM mkTypeEnv initialEnv libs
 156
 157 mkTypeEnv :: Menv -> Module -> IO Menv
 158 mkTypeEnv globalEnv m@(Module mn _ _) =
 159     catch (return (envsModule globalEnv m)) handler
 160         where handler e = do
 161                 putStrLn ("WARNING: mkTypeEnv caught an exception " ++ show e
 162                                     ++ " while processing " ++ show mn)
 163                 return globalEnv
 164
 165 ----- move this
 166 ioBaseMname :: AnMname
 167 ioBaseMname = mkBaseMname "IOBase"