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