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 primEnv = Envs {tcenv_=efromlist $ map (\ (t,k) -> (t,Kind k))
  22                  ([(snd $ tcUtuple n, ktUtuple n) | n <- [1..maxUtuple]]
  23                    ++ ((snd tcArrow,ktArrow):primTcs)),
  24                 cenv_=efromlist primDcs,
  25                 venv_=efromlist (newPrimVars ++ opsState ++ primVals)}
  26
  27 errorEnv :: Envs
  28 errorEnv = Envs {tcenv_=eempty,
  29                  cenv_=eempty,
  30                  venv_=efromlist errorVals}
  31
  32
  33 newPrimVars :: [(Id, Ty)]
  34 newPrimVars = map (\ (v, ty) -> (zEncodeString v, ty))
  35   [("hPutChar#", mkFunTy tIntzh (mkFunTy tCharzh tIOUnit)),
  36    ("isSpace#", mkFunTy tCharzh tBool)]
  37
  38
  39 primDcs :: [(Dcon,Ty)]
  40 primDcs = map (\ ((_,c),t) -> (c,t))
  41               [(dcUtuple n, dcUtupleTy n) | n <- [1..maxUtuple]]
  42
  43 tRWS :: Ty
  44 tRWS = tStatezh tRealWorld
  45
  46 opsState :: [(Var, Ty)]
  47 opsState = [
  48   ("realWorldzh", tRWS)]
  49
  50 {- Real world and state. -}
  51
  52 -- tjc: why isn't this one unboxed?
  53 tcRealWorld :: Qual Tcon
  54 tcRealWorld = pv "RealWorld"
  55 tRealWorld :: Ty
  56 tRealWorld = Tcon tcRealWorld
  57
  58 tcStatezh :: Qual Tcon
  59 tcStatezh = pvz "State"
  60 tStatezh :: Ty -> Ty
  61 tStatezh t = Tapp (Tcon tcStatezh) t
  62
  63 {- Properly defined in PrelError, but needed in many modules before that. -}
  64 errorVals :: [(Var, Ty)]
  65 errorVals = [
  66  ("error", Tforall ("a",Kopen) (tArrow tString (Tvar "a"))),
  67  ("irrefutPatError", str2A),
  68  ("patError", str2A),
  69  ("divZZeroError", forallAA),
  70  ("overflowError", forallAA)]
  71
  72 {- Non-primitive, but mentioned in the types of primitives. -}
  73
  74 bv :: a -> Qual a
  75 bv = qual baseMname
  76
  77 str2A, forallAA :: Ty
  78 str2A = Tforall ("a",Kopen) (tArrow tAddrzh (Tvar "a"))
  79 forallAA = Tforall ("a",Kopen) (Tvar "a")
  80
  81 tBool :: Ty
  82 tBool = Tcon (Just boolMname, "Bool")
  83 tcChar :: Qual Tcon
  84 tcChar = bv "Char"
  85 tChar :: Ty
  86 tChar = Tcon tcChar
  87 tcList :: Qual Tcon
  88 tcList = bv "ZMZN"
  89 tList :: Ty -> Ty
  90 tList t = Tapp (Tcon tcList) t
  91 tString :: Ty
  92 tString = tList tChar
  93 tIntzh, tCharzh, tIOUnit :: Ty
  94 tIntzh = Tcon (primId "Int#")
  95 tCharzh = Tcon (primId "Char#")
  96 tIOUnit = Tapp (Tcon (Just (mkBaseMname "IOBase"), "IO"))
  97                (Tcon (bv "Z0T"))
  98
  99 primId :: String -> Qual Id
 100 primId = pv . zEncodeString