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