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