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                 tsenv_=eempty,
  33                 cenv_=efromlist primDcs,
  34                 venv_=efromlist (newPrimVars ++ opsState ++ primVals)}
  35
  36 errorEnv :: Envs
  37 errorEnv = Envs {tcenv_=eempty,
  38                  tsenv_=eempty,
  39                  cenv_=eempty,
  40                  venv_=efromlist errorVals}
  41
  42
  43 newPrimVars :: [(Id, Ty)]
  44 newPrimVars = map (\ (v, ty) -> (zEncodeString v, ty))
  45   [("hPutChar#", mkFunTy tIntzh (mkFunTy tCharzh tIOUnit)),
  46    ("isSpace#", mkFunTy tCharzh tBool)]
  47
  48
  49 primDcs :: [(Dcon,Ty)]
  50 primDcs = map (\ ((_,c),t) -> (c,t))
  51               [(dcUtuple n, dcUtupleTy n) | n <- [1..maxUtuple]]
  52
  53 tRWS :: Ty
  54 tRWS = tStatezh tRealWorld
  55
  56 opsState :: [(Var, Ty)]
  57 opsState = [
  58   ("realWorldzh", tRWS)]
  59
  60 {- Arrays -}
  61
  62 tcByteArrayzh, tcMutableArrayzh, tcMutableByteArrayzh :: Qual Tcon
  63 ktByteArrayzh, ktMutableArrayzh, ktMutableByteArrayzh :: Kind
  64
  65 tcByteArrayzh = pvz "ByteArray"
  66 ktByteArrayzh = Kunlifted
  67
  68 tcMutableArrayzh = pvz "MutableArray"
  69 ktMutableArrayzh = Karrow Klifted (Karrow Klifted Kunlifted)
  70
  71 tcMutableByteArrayzh = pvz "MutableByteArray"
  72 ktMutableByteArrayzh = Karrow Klifted Kunlifted
  73
  74 {- Real world and state. -}
  75
  76 -- tjc: why isn't this one unboxed?
  77 tcRealWorld :: Qual Tcon
  78 tcRealWorld = pv "RealWorld"
  79 tRealWorld :: Ty
  80 tRealWorld = Tcon tcRealWorld
  81
  82 tcStatezh :: Qual Tcon
  83 tcStatezh = pvz "State"
  84 tStatezh :: Ty -> Ty
  85 tStatezh t = Tapp (Tcon tcStatezh) t
  86
  87 {- Properly defined in PrelError, but needed in many modules before that. -}
  88 errorVals :: [(Var, Ty)]
  89 errorVals = [
  90  ("error", Tforall ("a",Kopen) (tArrow tString (Tvar "a"))),
  91  ("irrefutPatError", str2A),
  92  ("patError", str2A),
  93  ("divZZeroError", forallAA),
  94  ("overflowError", forallAA)]
  95
  96 {- Non-primitive, but mentioned in the types of primitives. -}
  97
  98 bv :: a -> Qual a
  99 bv = qual baseMname
 100
 101 str2A, forallAA :: Ty
 102 str2A = Tforall ("a",Kopen) (tArrow tAddrzh (Tvar "a"))
 103 forallAA = Tforall ("a",Kopen) (Tvar "a")
 104
 105 tBool :: Ty
 106 tBool = Tcon (Just boolMname, "Bool")
 107 tcChar :: Qual Tcon
 108 tcChar = bv "Char"
 109 tChar :: Ty
 110 tChar = Tcon tcChar
 111 tcList :: Qual Tcon
 112 tcList = bv "ZMZN"
 113 tList :: Ty -> Ty
 114 tList t = Tapp (Tcon tcList) t
 115 tString :: Ty
 116 tString = tList tChar
 117 tIntzh, tCharzh, tIOUnit :: Ty
 118 tIntzh = Tcon (primId "Int#")
 119 tCharzh = Tcon (primId "Char#")
 120 tIOUnit = Tapp (Tcon (Just (mkBaseMname "IOBase"), "IO"))
 121                (Tcon (bv "Z0T"))
 122
 123 primId :: String -> Qual Id
 124 primId = pv . zEncodeString