utils/ext-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 Prims(initialEnv, primEnv, newPrimVars) where
   8
   9 import Core
  10 import Encoding
  11 import Env
  12 import Check
  13 import PrimCoercions
  14
  15 import PrimEnv
  16
  17 initialEnv :: Menv
  18 initialEnv = efromlist [(primMname,primEnv),
  19                      (errMname,errorEnv)]
  20
  21 primEnv :: Envs
  22 -- Tediously, we add defs for ByteArray# etc. because these are
  23 -- declared as ByteArr# (etc.) in primops.txt, and GHC has
  24 -- ByteArray# etc. wired-in.
  25 -- At least this is better than when all primops were wired-in here.
  26 primEnv = Envs {tcenv_=efromlist $ map (\ (t,k) -> (t,Kind k)) $
  27                   [(snd tcByteArrayzh,ktByteArrayzh),
  28                    (snd tcMutableArrayzh, ktMutableArrayzh),
  29                    (snd tcMutableByteArrayzh, ktMutableByteArrayzh)] ++
  30                  ([(snd $ tcUtuple n, ktUtuple n) | n <- [1..maxUtuple]]
  31                    ++ ((snd tcArrow,ktArrow):primTcs)),
  32                 cenv_=efromlist primDcs,
  33                 venv_=efromlist (newPrimVars ++ opsState ++ primVals)}
  34
  35 errorEnv :: Envs
  36 errorEnv = Envs {tcenv_=eempty,
  37                  cenv_=eempty,
  38                  venv_=efromlist errorVals}
  39
  40
  41 newPrimVars :: [(Id, Ty)]
  42 newPrimVars = map (\ (v, ty) -> (zEncodeString v, ty))
  43   [("hPutChar#", mkFunTy tIntzh (mkFunTy tCharzh tIOUnit)),
  44    ("isSpace#", mkFunTy tCharzh tBool)]
  45
  46
  47 primDcs :: [(Dcon,Ty)]
  48 primDcs = map (\ ((_,c),t) -> (c,t))
  49               [(dcUtuple n, dcUtupleTy n) | n <- [1..maxUtuple]]
  50
  51 tRWS :: Ty
  52 tRWS = tStatezh tRealWorld
  53
  54 opsState :: [(Var, Ty)]
  55 opsState = [
  56   ("realWorldzh", tRWS)]
  57
  58 {- Arrays -}
  59
  60 tcByteArrayzh, tcMutableArrayzh, tcMutableByteArrayzh :: Qual Tcon
  61 ktByteArrayzh, ktMutableArrayzh, ktMutableByteArrayzh :: Kind
  62
  63 tcByteArrayzh = pvz "ByteArray"
  64 ktByteArrayzh = Kunlifted
  65
  66 tcMutableArrayzh = pvz "MutableArray"
  67 ktMutableArrayzh = Karrow Klifted (Karrow Klifted Kunlifted)
  68
  69 tcMutableByteArrayzh = pvz "MutableByteArray"
  70 ktMutableByteArrayzh = Karrow Klifted Kunlifted
  71
  72 {- Real world and state. -}
  73
  74 -- tjc: why isn't this one unboxed?
  75 tcRealWorld :: Qual Tcon
  76 tcRealWorld = pv "RealWorld"
  77 tRealWorld :: Ty
  78 tRealWorld = Tcon tcRealWorld
  79
  80 tcStatezh :: Qual Tcon
  81 tcStatezh = pvz "State"
  82 tStatezh :: Ty -> Ty
  83 tStatezh t = Tapp (Tcon tcStatezh) t
  84
  85 {- Properly defined in PrelError, but needed in many modules before that. -}
  86 errorVals :: [(Var, Ty)]
  87 errorVals = [
  88  ("error", Tforall ("a",Kopen) (tArrow tString (Tvar "a"))),
  89  ("irrefutPatError", str2A),
  90  ("patError", str2A),
  91  ("divZZeroError", forallAA),
  92  ("overflowError", forallAA)]
  93
  94 {- Non-primitive, but mentioned in the types of primitives. -}
  95
  96 bv :: a -> Qual a
  97 bv = qual baseMname
  98
  99 str2A, forallAA :: Ty
 100 str2A = Tforall ("a",Kopen) (tArrow tAddrzh (Tvar "a"))
 101 forallAA = Tforall ("a",Kopen) (Tvar "a")
 102
 103 tBool :: Ty
 104 tBool = Tcon (Just boolMname, "Bool")
 105 tcChar :: Qual Tcon
 106 tcChar = bv "Char"
 107 tChar :: Ty
 108 tChar = Tcon tcChar
 109 tcList :: Qual Tcon
 110 tcList = bv "ZMZN"
 111 tList :: Ty -> Ty
 112 tList t = Tapp (Tcon tcList) t
 113 tString :: Ty
 114 tString = tList tChar
 115 tIntzh, tCharzh, tIOUnit :: Ty
 116 tIntzh = Tcon (primId "Int#")
 117 tCharzh = Tcon (primId "Char#")
 118 tIOUnit = Tapp (Tcon (Just (mkBaseMname "IOBase"), "IO"))
 119                (Tcon (bv "Z0T"))
 120
 121 primId :: String -> Qual Id
 122 primId = pv . zEncodeString