utils/ext-core/Language/Core/Core.hs

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