module Core where
+import Encoding
+
+import Data.Generics
import List (elemIndex)
data Module
= Module AnMname [Tdef] [Vdefg]
+ deriving (Data, Typeable)
data Tdef
= Data (Qual Tcon) [Tbind] [Cdef]
- | Newtype (Qual Tcon) [Tbind] Axiom (Maybe Ty)
+ -- type constructor; coercion name; type arguments; type rep
+ -- If we have: (Newtype tc co tbs (Just t))
+ -- there is an implicit axiom:
+ -- co tbs :: tc tbs :=: t
+ | Newtype (Qual Tcon) (Qual Tcon) [Tbind] (Maybe Ty)
+ deriving (Data, Typeable)
data Cdef
= Constr (Qual Dcon) [Tbind] [Ty]
-
--- Newtype coercion
-type Axiom = (Qual Tcon, Kind)
+ deriving (Data, Typeable)
data Vdefg
= Rec [Vdef]
| Nonrec Vdef
+ deriving (Data, Typeable)
newtype Vdef = Vdef (Qual Var,Ty,Exp)
+ deriving (Data, Typeable)
data Exp
= Var (Qual Var)
| Cast Exp Ty
| Note String Exp
| External String Ty
+ deriving (Data, Typeable)
data Bind
= Vb Vbind
| Tb Tbind
+ deriving (Data, Typeable)
data Alt
= Acon (Qual Dcon) [Tbind] [Vbind] Exp
| Alit Lit Exp
| Adefault Exp
+ deriving (Data, Typeable)
type Vbind = (Var,Ty)
type Tbind = (Tvar,Kind)
| Tcon (Qual Tcon)
| Tapp Ty Ty
| Tforall Tbind Ty
+-- Wired-in coercions:
+-- These are primitive tycons in GHC, but in ext-core,
+-- we make them explicit, to make the typechecker
+-- somewhat more clear.
+ | TransCoercion Ty Ty
+ | SymCoercion Ty
+ | UnsafeCoercion Ty Ty
+ | InstCoercion Ty Ty
+ | LeftCoercion Ty
+ | RightCoercion Ty
+ deriving (Data, Typeable)
data Kind
= Klifted
| Kopen
| Karrow Kind Kind
| Keq Ty Ty
-
+ deriving (Data, Typeable)
+
+-- A CoercionKind isn't really a Kind at all, but rather,
+-- corresponds to an arbitrary user-declared axiom.
+-- A tycon whose CoercionKind is (DefinedCoercion <tbs> (from, to))
+-- represents a tycon with arity (length tbs), whose kind is
+-- (from :=: to) (modulo substituting type arguments.
+-- It's not a Kind because a coercion must always be fully applied:
+-- whenever we see a tycon that has such a CoercionKind, it must
+-- be fully applied if it's to be assigned an actual Kind.
+-- So, a CoercionKind *only* appears in the environment (mapping
+-- newtype axioms onto CoercionKinds).
+-- Was that clear??
+data CoercionKind =
+ DefinedCoercion [Tbind] (Ty,Ty)
+
+-- The type constructor environment maps names that are
+-- either type constructors or coercion names onto either
+-- kinds or coercion kinds.
+data KindOrCoercion = Kind Kind | Coercion CoercionKind
+
data Lit = Literal CoreLit Ty
- deriving Eq -- with nearlyEqualTy
+ deriving (Data, Typeable, Eq) -- with nearlyEqualTy
data CoreLit = Lint Integer
| Lrational Rational
| Lchar Char
| Lstring String
- deriving Eq
+ deriving (Data, Typeable, Eq)
-- Right now we represent module names as triples:
-- (package name, hierarchical names, leaf name)
-- module namespace, either when printing out
-- Core or (probably preferably) in a
-- preprocessor.
--- The empty module name (as in an unqualified name)
--- is represented as Nothing.
+-- We represent the empty module name (as in an unqualified name)
+-- with Nothing.
type Mname = Maybe AnMname
-type AnMname = (Pname, [Id], Id)
-type Pname = Id
+newtype AnMname = M (Pname, [Id], Id)
+ deriving (Eq, Ord, Data, Typeable)
+newtype Pname = P Id
+ deriving (Eq, Ord, Data, Typeable)
type Var = Id
type Tvar = Id
type Tcon = Id
unqual :: t -> Qual t
unqual = (,) Nothing
+getModule :: Qual t -> Mname
+getModule = fst
+
type Id = String
eqKind :: Kind -> Kind -> Bool
eqKind Kopen Kopen = True
eqKind (Karrow k1 k2) (Karrow l1 l2) = k1 `eqKind` l1
&& k2 `eqKind` l2
-eqKind _ _ = False -- no Keq kind is ever equal to any other...
- -- maybe ok for now?
-
---- tjc: I haven't looked at the rest of this file. ---
-
+eqKind (Keq t1 t2) (Keq u1 u2) = t1 == u1
+ && t2 == u2
+eqKind _ _ = False
+
+splitTyConApp_maybe :: Ty -> Maybe (Qual Tcon,[Ty])
+splitTyConApp_maybe (Tvar _) = Nothing
+splitTyConApp_maybe (Tcon t) = Just (t,[])
+splitTyConApp_maybe (Tapp rator rand) =
+ case (splitTyConApp_maybe rator) of
+ Just (r,rs) -> Just (r,rs++[rand])
+ Nothing -> case rator of
+ Tcon tc -> Just (tc,[rand])
+ _ -> Nothing
+splitTyConApp_maybe t@(Tforall _ _) = Nothing
+
{- Doesn't expand out fully applied newtype synonyms
(for which an environment is needed). -}
nearlyEqualTy t1 t2 = eqTy [] [] t1 t2
subKindOf :: Kind -> Kind -> Bool
_ `subKindOf` Kopen = True
+(Karrow a1 r1) `subKindOf` (Karrow a2 r2) =
+ a2 `subKindOf` a1 && (r1 `subKindOf` r2)
k1 `subKindOf` k2 = k1 `eqKind` k2 -- doesn't worry about higher kinds
baseKind :: Kind -> Bool
isPrimVar (Just mn,_) = mn == primMname
isPrimVar _ = False
-primMname = mkBaseMname "Prim"
+primMname = mkPrimMname "Prim"
errMname = mkBaseMname "Err"
-mkBaseMname :: Id -> AnMname
-mkBaseMname mn = (basePkg, ghcPrefix, mn)
-basePkg = "base"
-mainPkg = "main"
+mkBaseMname,mkPrimMname :: Id -> AnMname
+mkBaseMname mn = M (basePkg, ghcPrefix, mn)
+mkPrimMname mn = M (primPkg, ghcPrefix, mn)
+basePkg = P "base"
+mainPkg = P "main"
+primPkg = P $ zEncodeString "ghc-prim"
ghcPrefix = ["GHC"]
mainPrefix = []
baseMname = mkBaseMname "Base"
+boolMname = mkPrimMname "Bool"
mainVar = qual mainMname "main"
-mainMname = (mainPkg, mainPrefix, "Main")
+wrapperMainVar = qual wrapperMainMname "main"
+mainMname = M (mainPkg, mainPrefix, "Main")
+wrapperMainMname = M (mainPkg, mainPrefix, "ZCMain")
+wrapperMainAnMname = Just wrapperMainMname
+
+dcTrue :: Dcon
+dcTrue = "True"
+dcFalse :: Dcon
+dcFalse = "False"
tcArrow :: Qual Tcon
tcArrow = (Just primMname, "ZLzmzgZR")
tArrow :: Ty -> Ty -> Ty
tArrow t1 t2 = Tapp (Tapp (Tcon tcArrow) t1) t2
+mkFunTy :: Ty -> Ty -> Ty
+mkFunTy randTy resultTy =
+ Tapp (Tapp (Tcon tcArrow) randTy) resultTy
ktArrow :: Kind
ktArrow = Karrow Kopen (Karrow Kopen Klifted)
{- Unboxed tuples -}
--- tjc: not sure whether anything that follows is right
-
maxUtuple :: Int
maxUtuple = 100
isUtupleTy _ = False
dcUtuple :: Int -> Qual Dcon
-dcUtuple n = (Just primMname,"ZdwZ" ++ (show n) ++ "H")
+-- TODO: Seems like Z2H etc. appears in ext-core files,
+-- not $wZ2H etc. Is this right?
+dcUtuple n = (Just primMname,"Z" ++ (show n) ++ "H")
isUtupleDc :: Qual Dcon -> Bool
isUtupleDc dc = dc `elem` [dcUtuple n | n <- [1..maxUtuple]]
utuple :: [Ty] -> [Exp] -> Exp
utuple ts es = foldl App (foldl Appt (Dcon (dcUtuple (length es))) ts) es
-
+---- snarfed from GHC's CoreSyn
+flattenBinds :: [Vdefg] -> [Vdef] -- Get all the lhs/rhs pairs
+flattenBinds (Nonrec vd : binds) = vd : flattenBinds binds
+flattenBinds (Rec prs1 : binds) = prs1 ++ flattenBinds binds
+flattenBinds [] = []
projects / ghc-hetmet.git / blobdiff