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] 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)
| 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.
data KindOrCoercion = Kind Kind | Coercion CoercionKind
data Lit = Literal CoreLit Ty
- deriving Eq -- with nearlyEqualTy
+ deriving (Data, Typeable, Eq)
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)
-- 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?
-
+eqKind (Keq t1 t2) (Keq u1 u2) = t1 == u1
+ && t2 == u2
+eqKind _ _ = False
splitTyConApp_maybe :: Ty -> Maybe (Qual Tcon,[Ty])
splitTyConApp_maybe (Tvar _) = Nothing
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
+
+-- This used to be called nearlyEqualTy, but now that
+-- we don't need to expand newtypes anymore, it seems
+-- like equality to me!
+equalTy t1 t2 = eqTy [] [] t1 t2
where eqTy e1 e2 (Tvar v1) (Tvar v2) =
case (elemIndex v1 e1,elemIndex v2 e2) of
(Just i1, Just i2) -> i1 == i2
eqTy e1 e2 (Tforall (tv1,tk1) t1) (Tforall (tv2,tk2) t2) =
tk1 `eqKind` tk2 && eqTy (tv1:e1) (tv2:e2) t1 t2
eqTy _ _ _ _ = False
-instance Eq Ty where (==) = nearlyEqualTy
+instance Eq Ty where (==) = equalTy
subKindOf :: Kind -> Kind -> Bool
primMname = mkPrimMname "Prim"
errMname = mkBaseMname "Err"
mkBaseMname,mkPrimMname :: Id -> AnMname
-mkBaseMname mn = (basePkg, ghcPrefix, mn)
-mkPrimMname mn = (primPkg, ghcPrefix, mn)
-basePkg = "base"
-mainPkg = "main"
-primPkg = zEncodeString "ghc-prim"
+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")
-wrapperMainMname = Just (mainPkg, mainPrefix, "ZCMain")
+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)
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 [] = []