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, [Tbind], (Ty,Ty))
+ 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)
| 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.
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)
type Mname = Maybe AnMname
newtype AnMname = M (Pname, [Id], Id)
- deriving (Eq, Ord)
-type Pname = 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
mkBaseMname,mkPrimMname :: Id -> AnMname
mkBaseMname mn = M (basePkg, ghcPrefix, mn)
mkPrimMname mn = M (primPkg, ghcPrefix, mn)
-basePkg = "base"
-mainPkg = "main"
-primPkg = zEncodeString "ghc-prim"
+basePkg = P "base"
+mainPkg = P "main"
+primPkg = P $ zEncodeString "ghc-prim"
ghcPrefix = ["GHC"]
mainPrefix = []
baseMname = mkBaseMname "Base"
boolMname = mkPrimMname "Bool"
mainVar = qual mainMname "main"
+wrapperMainVar = qual wrapperMainMname "main"
mainMname = M (mainPkg, mainPrefix, "Main")
-wrapperMainMname = Just $ M (mainPkg, mainPrefix, "ZCMain")
+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)
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 [] = []