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] 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)
 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 -- This used to be called nearlyEqualTy, but now that
 168 -- we don't need to expand newtypes anymore, it seems
 169 -- like equality to me!
 170 equalTy t1 t2 =  eqTy [] [] t1 t2
 171   where eqTy e1 e2 (Tvar v1) (Tvar v2) =
 172              case (elemIndex v1 e1,elemIndex v2 e2) of
 173                (Just i1, Just i2) -> i1 == i2
 174                (Nothing, Nothing)  -> v1 == v2
 175                _ -> False
 176         eqTy e1 e2 (Tcon c1) (Tcon c2) = c1 == c2
 177         eqTy e1 e2 (Tapp t1a t1b) (Tapp t2a t2b) =
 178               eqTy e1 e2 t1a t2a && eqTy e1 e2 t1b t2b
 179         eqTy e1 e2 (Tforall (tv1,tk1) t1) (Tforall (tv2,tk2) t2) =
 180               tk1 `eqKind` tk2 && eqTy (tv1:e1) (tv2:e2) t1 t2
 181         eqTy _ _ _ _ = False
 182 instance Eq Ty where (==) = equalTy
 183
 184
 185 subKindOf :: Kind -> Kind -> Bool
 186 _ `subKindOf` Kopen = True
 187 (Karrow a1 r1) `subKindOf` (Karrow a2 r2) =
 188   a2 `subKindOf` a1 && (r1 `subKindOf` r2)
 189 k1 `subKindOf` k2 = k1 `eqKind` k2  -- doesn't worry about higher kinds
 190
 191 baseKind :: Kind -> Bool
 192 baseKind (Karrow _ _ ) = False
 193 baseKind _ = True
 194
 195 isPrimVar (Just mn,_) = mn == primMname
 196 isPrimVar _ = False
 197
 198 primMname = mkPrimMname "Prim"
 199 errMname  = mkBaseMname "Err"
 200 mkBaseMname,mkPrimMname :: Id -> AnMname
 201 mkBaseMname mn = M (basePkg, ghcPrefix, mn)
 202 mkPrimMname mn = M (primPkg, ghcPrefix, mn)
 203 basePkg = P "base"
 204 mainPkg = P "main"
 205 primPkg = P $ zEncodeString "ghc-prim"
 206 ghcPrefix = ["GHC"]
 207 mainPrefix = []
 208 baseMname = mkBaseMname "Base"
 209 boolMname = mkPrimMname "Bool"
 210 mainVar = qual mainMname "main"
 211 wrapperMainVar = qual wrapperMainMname "main"
 212 mainMname = M (mainPkg, mainPrefix, "Main")
 213 wrapperMainMname = M (mainPkg, mainPrefix, "ZCMain")
 214 wrapperMainAnMname = Just wrapperMainMname
 215
 216 dcTrue :: Dcon
 217 dcTrue = "True"
 218 dcFalse :: Dcon
 219 dcFalse = "False"
 220
 221 tcArrow :: Qual Tcon
 222 tcArrow = (Just primMname, "ZLzmzgZR")
 223
 224 tArrow :: Ty -> Ty -> Ty
 225 tArrow t1 t2 = Tapp (Tapp (Tcon tcArrow) t1) t2
 226
 227 mkFunTy :: Ty -> Ty -> Ty
 228 mkFunTy randTy resultTy =
 229   Tapp (Tapp (Tcon tcArrow) randTy) resultTy
 230
 231 ktArrow :: Kind
 232 ktArrow = Karrow Kopen (Karrow Kopen Klifted)
 233
 234 {- Unboxed tuples -}
 235
 236 maxUtuple :: Int
 237 maxUtuple = 100
 238
 239 tcUtuple :: Int -> Qual Tcon
 240 tcUtuple n = (Just primMname,"Z"++ (show n) ++ "H")
 241
 242 ktUtuple :: Int -> Kind
 243 ktUtuple n = foldr Karrow Kunlifted (replicate n Kopen)
 244
 245 tUtuple :: [Ty] -> Ty
 246 tUtuple ts = foldl Tapp (Tcon (tcUtuple (length ts))) ts
 247
 248 isUtupleTy :: Ty -> Bool
 249 isUtupleTy (Tapp t _) = isUtupleTy t
 250 isUtupleTy (Tcon tc) = tc `elem` [tcUtuple n | n <- [1..maxUtuple]]
 251 isUtupleTy _ = False
 252
 253 dcUtuple :: Int -> Qual Dcon
 254 -- TODO: Seems like Z2H etc. appears in ext-core files,
 255 -- not $wZ2H etc. Is this right?
 256 dcUtuple n = (Just primMname,"Z" ++ (show n) ++ "H")
 257
 258 isUtupleDc :: Qual Dcon -> Bool
 259 isUtupleDc dc = dc `elem` [dcUtuple n | n <- [1..maxUtuple]]
 260
 261 dcUtupleTy :: Int -> Ty
 262 dcUtupleTy n =
 263      foldr ( \tv t -> Tforall (tv,Kopen) t)
 264            (foldr ( \tv t -> tArrow (Tvar tv) t)
 265                   (tUtuple (map Tvar tvs)) tvs)
 266            tvs
 267      where tvs = map ( \i -> ("a" ++ (show i))) [1..n]
 268
 269 utuple :: [Ty] -> [Exp] -> Exp
 270 utuple ts es = foldl App (foldl Appt (Dcon (dcUtuple (length es))) ts) es
 271
 272 ---- snarfed from GHC's CoreSyn
 273 flattenBinds :: [Vdefg] -> [Vdef]       -- Get all the lhs/rhs pairs
 274 flattenBinds (Nonrec vd : binds) = vd : flattenBinds binds
 275 flattenBinds (Rec prs1   : binds) = prs1 ++ flattenBinds binds
 276 flattenBinds []                   = []