utils/ext-core/Core.hs

   1 module Core where
   2
   3 import Encoding
   4
   5 import Data.Generics
   6 import List (elemIndex)
   7
   8 data Module
   9  = Module AnMname [Tdef] [Vdefg]
  10   deriving (Data, Typeable)
  11
  12 data Tdef
  13   = Data (Qual Tcon) [Tbind] [Cdef]
  14     -- type constructor; coercion name; type arguments; type rep
  15     -- If we have: (Newtype tc co tbs (Just t))
  16     -- there is an implicit axiom:
  17     --  co tbs :: tc tbs :=: t
  18   | Newtype (Qual Tcon) (Qual Tcon) [Tbind] (Maybe Ty)
  19  deriving (Data, Typeable)
  20
  21 data Cdef
  22   = Constr (Qual Dcon) [Tbind] [Ty]
  23   deriving (Data, Typeable)
  24
  25 data Vdefg
  26   = Rec [Vdef]
  27   | Nonrec Vdef
  28   deriving (Data, Typeable)
  29
  30 newtype Vdef = Vdef (Qual Var,Ty,Exp)
  31   deriving (Data, Typeable)
  32
  33 data Exp
  34   = Var (Qual Var)
  35   | Dcon (Qual Dcon)
  36   | Lit Lit
  37   | App Exp Exp
  38   | Appt Exp Ty
  39   | Lam Bind Exp
  40   | Let Vdefg Exp
  41   | Case Exp Vbind Ty [Alt] {- non-empty list -}
  42   | Cast Exp Ty
  43   | Note String Exp
  44   | External String Ty
  45   deriving (Data, Typeable)
  46
  47 data Bind
  48   = Vb Vbind
  49   | Tb Tbind
  50   deriving (Data, Typeable)
  51
  52 data Alt
  53   = Acon (Qual Dcon) [Tbind] [Vbind] Exp
  54   | Alit Lit Exp
  55   | Adefault Exp
  56   deriving (Data, Typeable)
  57
  58 type Vbind = (Var,Ty)
  59 type Tbind = (Tvar,Kind)
  60
  61 data Ty
  62   = Tvar Tvar
  63   | Tcon (Qual Tcon)
  64   | Tapp Ty Ty
  65   | Tforall Tbind Ty
  66 -- Wired-in coercions:
  67 -- These are primitive tycons in GHC, but in ext-core,
  68 -- we make them explicit, to make the typechecker
  69 -- somewhat more clear.
  70   | TransCoercion Ty Ty
  71   | SymCoercion Ty
  72   | UnsafeCoercion Ty Ty
  73   | InstCoercion Ty Ty
  74   | LeftCoercion Ty
  75   | RightCoercion Ty
  76   deriving (Data, Typeable)
  77
  78 data Kind
  79   = Klifted
  80   | Kunlifted
  81   | Kopen
  82   | Karrow Kind Kind
  83   | Keq Ty Ty
  84   deriving (Data, Typeable)
  85
  86 -- A CoercionKind isn't really a Kind at all, but rather,
  87 -- corresponds to an arbitrary user-declared axiom.
  88 -- A tycon whose CoercionKind is (DefinedCoercion <tbs> (from, to))
  89 -- represents a tycon with arity (length tbs), whose kind is
  90 -- (from :=: to) (modulo substituting type arguments.
  91 -- It's not a Kind because a coercion must always be fully applied:
  92 -- whenever we see a tycon that has such a CoercionKind, it must
  93 -- be fully applied if it's to be assigned an actual Kind.
  94 -- So, a CoercionKind *only* appears in the environment (mapping
  95 -- newtype axioms onto CoercionKinds).
  96 -- Was that clear??
  97 data CoercionKind =
  98    DefinedCoercion [Tbind] (Ty,Ty)
  99
 100 -- The type constructor environment maps names that are
 101 -- either type constructors or coercion names onto either
 102 -- kinds or coercion kinds.
 103 data KindOrCoercion = Kind Kind | Coercion CoercionKind
 104
 105 data Lit = Literal CoreLit Ty
 106   deriving (Data, Typeable, Eq)   -- with nearlyEqualTy
 107
 108 data CoreLit = Lint Integer
 109   | Lrational Rational
 110   | Lchar Char
 111   | Lstring String
 112   deriving (Data, Typeable, Eq)
 113
 114 -- Right now we represent module names as triples:
 115 -- (package name, hierarchical names, leaf name)
 116 -- An alternative to this would be to flatten the
 117 -- module namespace, either when printing out
 118 -- Core or (probably preferably) in a
 119 -- preprocessor.
 120 -- We represent the empty module name (as in an unqualified name)
 121 -- with Nothing.
 122
 123 type Mname = Maybe AnMname
 124 newtype AnMname = M (Pname, [Id], Id)
 125   deriving (Eq, Ord, Data, Typeable)
 126 newtype Pname = P Id
 127   deriving (Eq, Ord, Data, Typeable)
 128 type Var = Id
 129 type Tvar = Id
 130 type Tcon = Id
 131 type Dcon = Id
 132
 133 type Qual t = (Mname,t)
 134
 135 qual :: AnMname -> t -> Qual t
 136 qual mn t = (Just mn, t)
 137
 138 unqual :: t -> Qual t
 139 unqual = (,) Nothing
 140
 141 getModule :: Qual t -> Mname
 142 getModule = fst
 143
 144 type Id = String
 145
 146 eqKind :: Kind -> Kind -> Bool
 147 eqKind Klifted Klifted = True
 148 eqKind Kunlifted Kunlifted = True
 149 eqKind Kopen Kopen = True
 150 eqKind (Karrow k1 k2) (Karrow l1 l2) = k1 `eqKind` l1
 151                                    &&  k2 `eqKind` l2
 152 eqKind (Keq t1 t2) (Keq u1 u2) = t1 == u1
 153                               && t2 == u2
 154 eqKind _ _ = False
 155
 156 splitTyConApp_maybe :: Ty -> Maybe (Qual Tcon,[Ty])
 157 splitTyConApp_maybe (Tvar _) = Nothing
 158 splitTyConApp_maybe (Tcon t) = Just (t,[])
 159 splitTyConApp_maybe (Tapp rator rand) =
 160    case (splitTyConApp_maybe rator) of
 161       Just (r,rs) -> Just (r,rs++[rand])
 162       Nothing     -> case rator of
 163                        Tcon tc -> Just (tc,[rand])
 164                        _       -> Nothing
 165 splitTyConApp_maybe t@(Tforall _ _) = Nothing
 166
 167 {- Doesn't expand out fully applied newtype synonyms
 168    (for which an environment is needed). -}
 169 nearlyEqualTy t1 t2 =  eqTy [] [] t1 t2
 170   where eqTy e1 e2 (Tvar v1) (Tvar v2) =
 171              case (elemIndex v1 e1,elemIndex v2 e2) of
 172                (Just i1, Just i2) -> i1 == i2
 173                (Nothing, Nothing)  -> v1 == v2
 174                _ -> False
 175         eqTy e1 e2 (Tcon c1) (Tcon c2) = c1 == c2
 176         eqTy e1 e2 (Tapp t1a t1b) (Tapp t2a t2b) =
 177               eqTy e1 e2 t1a t2a && eqTy e1 e2 t1b t2b
 178         eqTy e1 e2 (Tforall (tv1,tk1) t1) (Tforall (tv2,tk2) t2) =
 179               tk1 `eqKind` tk2 && eqTy (tv1:e1) (tv2:e2) t1 t2
 180         eqTy _ _ _ _ = False
 181 instance Eq Ty where (==) = nearlyEqualTy
 182
 183
 184 subKindOf :: Kind -> Kind -> Bool
 185 _ `subKindOf` Kopen = True
 186 (Karrow a1 r1) `subKindOf` (Karrow a2 r2) =
 187   a2 `subKindOf` a1 && (r1 `subKindOf` r2)
 188 k1 `subKindOf` k2 = k1 `eqKind` k2  -- doesn't worry about higher kinds
 189
 190 baseKind :: Kind -> Bool
 191 baseKind (Karrow _ _ ) = False
 192 baseKind _ = True
 193
 194 isPrimVar (Just mn,_) = mn == primMname
 195 isPrimVar _ = False
 196
 197 primMname = mkPrimMname "Prim"
 198 errMname  = mkBaseMname "Err"
 199 mkBaseMname,mkPrimMname :: Id -> AnMname
 200 mkBaseMname mn = M (basePkg, ghcPrefix, mn)
 201 mkPrimMname mn = M (primPkg, ghcPrefix, mn)
 202 basePkg = P "base"
 203 mainPkg = P "main"
 204 primPkg = P $ zEncodeString "ghc-prim"
 205 ghcPrefix = ["GHC"]
 206 mainPrefix = []
 207 baseMname = mkBaseMname "Base"
 208 boolMname = mkPrimMname "Bool"
 209 mainVar = qual mainMname "main"
 210 wrapperMainVar = qual wrapperMainMname "main"
 211 mainMname = M (mainPkg, mainPrefix, "Main")
 212 wrapperMainMname = M (mainPkg, mainPrefix, "ZCMain")
 213 wrapperMainAnMname = Just wrapperMainMname
 214
 215 dcTrue :: Dcon
 216 dcTrue = "True"
 217 dcFalse :: Dcon
 218 dcFalse = "False"
 219
 220 tcArrow :: Qual Tcon
 221 tcArrow = (Just primMname, "ZLzmzgZR")
 222
 223 tArrow :: Ty -> Ty -> Ty
 224 tArrow t1 t2 = Tapp (Tapp (Tcon tcArrow) t1) t2
 225
 226 mkFunTy :: Ty -> Ty -> Ty
 227 mkFunTy randTy resultTy =
 228   Tapp (Tapp (Tcon tcArrow) randTy) resultTy
 229
 230 ktArrow :: Kind
 231 ktArrow = Karrow Kopen (Karrow Kopen Klifted)
 232
 233 {- Unboxed tuples -}
 234
 235 maxUtuple :: Int
 236 maxUtuple = 100
 237
 238 tcUtuple :: Int -> Qual Tcon
 239 tcUtuple n = (Just primMname,"Z"++ (show n) ++ "H")
 240
 241 ktUtuple :: Int -> Kind
 242 ktUtuple n = foldr Karrow Kunlifted (replicate n Kopen)
 243
 244 tUtuple :: [Ty] -> Ty
 245 tUtuple ts = foldl Tapp (Tcon (tcUtuple (length ts))) ts
 246
 247 isUtupleTy :: Ty -> Bool
 248 isUtupleTy (Tapp t _) = isUtupleTy t
 249 isUtupleTy (Tcon tc) = tc `elem` [tcUtuple n | n <- [1..maxUtuple]]
 250 isUtupleTy _ = False
 251
 252 dcUtuple :: Int -> Qual Dcon
 253 -- TODO: Seems like Z2H etc. appears in ext-core files,
 254 -- not $wZ2H etc. Is this right?
 255 dcUtuple n = (Just primMname,"Z" ++ (show n) ++ "H")
 256
 257 isUtupleDc :: Qual Dcon -> Bool
 258 isUtupleDc dc = dc `elem` [dcUtuple n | n <- [1..maxUtuple]]
 259
 260 dcUtupleTy :: Int -> Ty
 261 dcUtupleTy n =
 262      foldr ( \tv t -> Tforall (tv,Kopen) t)
 263            (foldr ( \tv t -> tArrow (Tvar tv) t)
 264                   (tUtuple (map Tvar tvs)) tvs)
 265            tvs
 266      where tvs = map ( \i -> ("a" ++ (show i))) [1..n]
 267
 268 utuple :: [Ty] -> [Exp] -> Exp
 269 utuple ts es = foldl App (foldl Appt (Dcon (dcUtuple (length es))) ts) es
 270
 271 ---- snarfed from GHC's CoreSyn
 272 flattenBinds :: [Vdefg] -> [Vdef]       -- Get all the lhs/rhs pairs
 273 flattenBinds (Nonrec vd : binds) = vd : flattenBinds binds
 274 flattenBinds (Rec prs1   : binds) = prs1 ++ flattenBinds binds
 275 flattenBinds []                   = []