utils/ext-core/Core.hs

   1 module Core where
   2
   3 import List (elemIndex)
   4
   5 data Module
   6  = Module Mname [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   | App Exp Exp
  26   | Appt Exp Ty
  27   | Lam Bind Exp
  28   | Let Vdefg Exp
  29   | Case Exp Vbind [Alt] {- non-empty list -}
  30   | Coerce Ty Exp
  31   | Note String Exp
  32   | External String Ty
  33
  34 data Bind
  35   = Vb Vbind
  36   | Tb Tbind
  37
  38 data Alt
  39   = Acon (Qual Dcon) [Tbind] [Vbind] Exp
  40   | Alit Lit Exp
  41   | Adefault Exp
  42
  43 type Vbind = (Var,Ty)
  44 type Tbind = (Tvar,Kind)
  45
  46 data Ty
  47   = Tvar Tvar
  48   | Tcon (Qual Tcon)
  49   | Tapp Ty Ty
  50   | Tforall Tbind Ty
  51
  52 data Kind
  53   = Klifted
  54   | Kunlifted
  55   | Kopen
  56   | Karrow Kind Kind
  57   deriving (Eq)
  58
  59 data Lit
  60   = Lint Integer Ty
  61   | Lrational Rational Ty
  62   | Lchar Char Ty
  63   | Lstring String Ty
  64   deriving (Eq)  -- with nearlyEqualTy
  65
  66 type Mname = Id
  67 type Var = Id
  68 type Tvar = Id
  69 type Tcon = Id
  70 type Dcon = Id
  71
  72 type Qual t = (Mname,t)
  73
  74 type Id = String
  75
  76 {- Doesn't expand out fully applied newtype synonyms
  77    (for which an environment is needed). -}
  78 nearlyEqualTy t1 t2 =  eqTy [] [] t1 t2
  79   where eqTy e1 e2 (Tvar v1) (Tvar v2) =
  80              case (elemIndex v1 e1,elemIndex v2 e2) of
  81                (Just i1, Just i2) -> i1 == i2
  82                (Nothing, Nothing)  -> v1 == v2
  83                _ -> False
  84         eqTy e1 e2 (Tcon c1) (Tcon c2) = c1 == c2
  85         eqTy e1 e2 (Tapp t1a t1b) (Tapp t2a t2b) =
  86               eqTy e1 e2 t1a t2a && eqTy e1 e2 t1b t2b
  87         eqTy e1 e2 (Tforall (tv1,tk1) t1) (Tforall (tv2,tk2) t2) =
  88               tk1 == tk2 && eqTy (tv1:e1) (tv2:e2) t1 t2
  89         eqTy _ _ _ _ = False
  90 instance Eq Ty where (==) = nearlyEqualTy
  91
  92
  93 subKindOf :: Kind -> Kind -> Bool
  94 _ `subKindOf` Kopen = True
  95 k1 `subKindOf` k2 = k1 == k2  -- doesn't worry about higher kinds
  96
  97 instance Ord Kind where (<=) = subKindOf
  98
  99 baseKind :: Kind -> Bool
 100 baseKind (Karrow _ _ ) = False
 101 baseKind _ = True
 102
 103 primMname = "PrelGHC"
 104
 105 tcArrow :: Qual Tcon
 106 tcArrow = (primMname, "ZLzmzgZR")
 107
 108 tArrow :: Ty -> Ty -> Ty
 109 tArrow t1 t2 = Tapp (Tapp (Tcon tcArrow) t1) t2
 110
 111 ktArrow :: Kind
 112 ktArrow = Karrow Kopen (Karrow Kopen Klifted)
 113
 114 {- Unboxed tuples -}
 115
 116 maxUtuple :: Int
 117 maxUtuple = 100
 118
 119 tcUtuple :: Int -> Qual Tcon
 120 tcUtuple n = (primMname,"Z"++ (show n) ++ "H")
 121
 122 ktUtuple :: Int -> Kind
 123 ktUtuple n = foldr Karrow Kunlifted (replicate n Kopen)
 124
 125 tUtuple :: [Ty] -> Ty
 126 tUtuple ts = foldl Tapp (Tcon (tcUtuple (length ts))) ts
 127
 128 isUtupleTy :: Ty -> Bool
 129 isUtupleTy (Tapp t _) = isUtupleTy t
 130 isUtupleTy (Tcon tc) = tc `elem` [tcUtuple n | n <- [1..maxUtuple]]
 131 isUtupleTy _ = False
 132
 133 dcUtuple :: Int -> Qual Dcon
 134 dcUtuple n = (primMname,"ZdwZ" ++ (show n) ++ "H")
 135
 136 isUtupleDc :: Qual Dcon -> Bool
 137 isUtupleDc dc = dc `elem` [dcUtuple n | n <- [1..maxUtuple]]
 138
 139 dcUtupleTy :: Int -> Ty
 140 dcUtupleTy n =
 141      foldr ( \tv t -> Tforall (tv,Kopen) t)
 142            (foldr ( \tv t -> tArrow (Tvar tv) t)
 143                   (tUtuple (map Tvar tvs)) tvs)
 144            tvs
 145      where tvs = map ( \i -> ("a" ++ (show i))) [1..n]
 146
 147 utuple :: [Ty] -> [Exp] -> Exp
 148 utuple ts es = foldl App (foldl Appt (Dcon (dcUtuple (length es))) ts) es
 149
 150