utils/ext-core/Core.hs

   1 module Core where
   2
   3 import List (elemIndex)
   4
   5 data Module
   6  = Module AnMname [Tdef] [Vdefg]
   7
   8 data Tdef
   9   = Data (Qual Tcon) [Tbind] [Cdef]
  10   | Newtype (Qual Tcon) [Tbind] Axiom (Maybe Ty)
  11
  12 data Cdef
  13   = Constr (Qual Dcon) [Tbind] [Ty]
  14
  15 -- Newtype coercion
  16 type Axiom = (Qual Tcon, Kind)
  17
  18 data Vdefg
  19   = Rec [Vdef]
  20   | Nonrec Vdef
  21
  22 newtype Vdef = Vdef (Qual Var,Ty,Exp)
  23
  24 data Exp
  25   = Var (Qual Var)
  26   | Dcon (Qual Dcon)
  27   | Lit Lit
  28   | App Exp Exp
  29   | Appt Exp Ty
  30   | Lam Bind Exp
  31   | Let Vdefg Exp
  32   | Case Exp Vbind Ty [Alt] {- non-empty list -}
  33   | Cast Exp Ty
  34   | Note String Exp
  35   | External String Ty
  36
  37 data Bind
  38   = Vb Vbind
  39   | Tb Tbind
  40
  41 data Alt
  42   = Acon (Qual Dcon) [Tbind] [Vbind] Exp
  43   | Alit Lit Exp
  44   | Adefault Exp
  45
  46 type Vbind = (Var,Ty)
  47 type Tbind = (Tvar,Kind)
  48
  49 data Ty
  50   = Tvar Tvar
  51   | Tcon (Qual Tcon)
  52   | Tapp Ty Ty
  53   | Tforall Tbind Ty
  54
  55 data Kind
  56   = Klifted
  57   | Kunlifted
  58   | Kopen
  59   | Karrow Kind Kind
  60   | Keq Ty Ty
  61
  62 data Lit = Literal CoreLit Ty
  63   deriving Eq   -- with nearlyEqualTy
  64
  65 data CoreLit = Lint Integer
  66   | Lrational Rational
  67   | Lchar Char
  68   | Lstring String
  69   deriving Eq
  70
  71 -- Right now we represent module names as triples:
  72 -- (package name, hierarchical names, leaf name)
  73 -- An alternative to this would be to flatten the
  74 -- module namespace, either when printing out
  75 -- Core or (probably preferably) in a
  76 -- preprocessor.
  77 -- The empty module name (as in an unqualified name)
  78 -- is represented as Nothing.
  79
  80 type Mname = Maybe AnMname
  81 type AnMname = (Pname, [Id], Id)
  82 type Pname = Id
  83 type Var = Id
  84 type Tvar = Id
  85 type Tcon = Id
  86 type Dcon = Id
  87
  88 type Qual t = (Mname,t)
  89
  90 qual :: AnMname -> t -> Qual t
  91 qual mn t = (Just mn, t)
  92
  93 unqual :: t -> Qual t
  94 unqual = (,) Nothing
  95
  96 type Id = String
  97
  98 eqKind :: Kind -> Kind -> Bool
  99 eqKind Klifted Klifted = True
 100 eqKind Kunlifted Kunlifted = True
 101 eqKind Kopen Kopen = True
 102 eqKind (Karrow k1 k2) (Karrow l1 l2) = k1 `eqKind` l1
 103                                    &&  k2 `eqKind` l2
 104 eqKind _ _ = False -- no Keq kind is ever equal to any other...
 105                    -- maybe ok for now?
 106
 107 --- tjc: I haven't looked at the rest of this file. ---
 108
 109 {- Doesn't expand out fully applied newtype synonyms
 110    (for which an environment is needed). -}
 111 nearlyEqualTy t1 t2 =  eqTy [] [] t1 t2
 112   where eqTy e1 e2 (Tvar v1) (Tvar v2) =
 113              case (elemIndex v1 e1,elemIndex v2 e2) of
 114                (Just i1, Just i2) -> i1 == i2
 115                (Nothing, Nothing)  -> v1 == v2
 116                _ -> False
 117         eqTy e1 e2 (Tcon c1) (Tcon c2) = c1 == c2
 118         eqTy e1 e2 (Tapp t1a t1b) (Tapp t2a t2b) =
 119               eqTy e1 e2 t1a t2a && eqTy e1 e2 t1b t2b
 120         eqTy e1 e2 (Tforall (tv1,tk1) t1) (Tforall (tv2,tk2) t2) =
 121               tk1 `eqKind` tk2 && eqTy (tv1:e1) (tv2:e2) t1 t2
 122         eqTy _ _ _ _ = False
 123 instance Eq Ty where (==) = nearlyEqualTy
 124
 125
 126 subKindOf :: Kind -> Kind -> Bool
 127 _ `subKindOf` Kopen = True
 128 k1 `subKindOf` k2 = k1 `eqKind` k2  -- doesn't worry about higher kinds
 129
 130 baseKind :: Kind -> Bool
 131 baseKind (Karrow _ _ ) = False
 132 baseKind _ = True
 133
 134 isPrimVar (Just mn,_) = mn == primMname
 135 isPrimVar _ = False
 136
 137 primMname = mkBaseMname "Prim"
 138 errMname  = mkBaseMname "Err"
 139 mkBaseMname :: Id -> AnMname
 140 mkBaseMname mn = (basePkg, ghcPrefix, mn)
 141 basePkg = "base"
 142 mainPkg = "main"
 143 ghcPrefix = ["GHC"]
 144 mainPrefix = []
 145 baseMname = mkBaseMname "Base"
 146 mainVar = qual mainMname "main"
 147 mainMname = (mainPkg, mainPrefix, "Main")
 148
 149 tcArrow :: Qual Tcon
 150 tcArrow = (Just primMname, "ZLzmzgZR")
 151
 152 tArrow :: Ty -> Ty -> Ty
 153 tArrow t1 t2 = Tapp (Tapp (Tcon tcArrow) t1) t2
 154
 155
 156 ktArrow :: Kind
 157 ktArrow = Karrow Kopen (Karrow Kopen Klifted)
 158
 159 {- Unboxed tuples -}
 160
 161 -- tjc: not sure whether anything that follows is right
 162
 163 maxUtuple :: Int
 164 maxUtuple = 100
 165
 166 tcUtuple :: Int -> Qual Tcon
 167 tcUtuple n = (Just primMname,"Z"++ (show n) ++ "H")
 168
 169 ktUtuple :: Int -> Kind
 170 ktUtuple n = foldr Karrow Kunlifted (replicate n Kopen)
 171
 172 tUtuple :: [Ty] -> Ty
 173 tUtuple ts = foldl Tapp (Tcon (tcUtuple (length ts))) ts
 174
 175 isUtupleTy :: Ty -> Bool
 176 isUtupleTy (Tapp t _) = isUtupleTy t
 177 isUtupleTy (Tcon tc) = tc `elem` [tcUtuple n | n <- [1..maxUtuple]]
 178 isUtupleTy _ = False
 179
 180 dcUtuple :: Int -> Qual Dcon
 181 dcUtuple n = (Just primMname,"ZdwZ" ++ (show n) ++ "H")
 182
 183 isUtupleDc :: Qual Dcon -> Bool
 184 isUtupleDc dc = dc `elem` [dcUtuple n | n <- [1..maxUtuple]]
 185
 186 dcUtupleTy :: Int -> Ty
 187 dcUtupleTy n =
 188      foldr ( \tv t -> Tforall (tv,Kopen) t)
 189            (foldr ( \tv t -> tArrow (Tvar tv) t)
 190                   (tUtuple (map Tvar tvs)) tvs)
 191            tvs
 192      where tvs = map ( \i -> ("a" ++ (show i))) [1..n]
 193
 194 utuple :: [Ty] -> [Exp] -> Exp
 195 utuple ts es = foldl App (foldl Appt (Dcon (dcUtuple (length es))) ts) es
 196
 197