+++ /dev/null
-{-# OPTIONS -fno-warn-missing-signatures #-}
-module Language.Core.Core where
-
-import Language.Core.Encoding
-
-import Data.Generics
-import Data.List (elemIndex)
-import Data.Char
-
-data Module
- = Module AnMname [Tdef] [Vdefg]
- deriving (Data, Typeable)
-
-data Tdef
- = Data (Qual Tcon) [Tbind] [Cdef]
- -- 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]
- 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)
- | Dcon (Qual Dcon)
- | Lit Lit
- | App Exp Exp
- | Appt Exp Ty
- | Lam Bind Exp
- | Let Vdefg Exp
- | Case Exp Vbind Ty [Alt] {- non-empty list -}
- | 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)
-
-data Ty
- = Tvar Tvar
- | 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
- | Kunlifted
- | 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 (Data, Typeable, Eq)
-
-data CoreLit = Lint Integer
- | Lrational Rational
- | Lchar Char
- | Lstring String
- deriving (Data, Typeable, Eq)
-
--- Right now we represent module names as triples:
--- (package name, hierarchical names, leaf name)
--- An alternative to this would be to flatten the
--- module namespace, either when printing out
--- Core or (probably preferably) in a
--- preprocessor.
--- We represent the empty module name (as in an unqualified name)
--- with Nothing.
-
-type Mname = Maybe AnMname
-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
-type Dcon = Id
-
-type Qual t = (Mname,t)
-
-qual :: AnMname -> t -> Qual t
-qual mn t = (Just mn, t)
-
-unqual :: t -> Qual t
-unqual = (,) Nothing
-
-getModule :: Qual t -> Mname
-getModule = fst
-
-type Id = String
-
-eqKind :: Kind -> Kind -> Bool
-eqKind Klifted Klifted = True
-eqKind Kunlifted Kunlifted = True
-eqKind Kopen Kopen = True
-eqKind (Karrow k1 k2) (Karrow l1 l2) = k1 `eqKind` l1
- && k2 `eqKind` l2
-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 (Tforall _ _) = Nothing
--- coercions
-splitTyConApp_maybe _ = Nothing
-
--- This used to be called nearlyEqualTy, but now that
--- we don't need to expand newtypes anymore, it seems
--- like equality to me!
-equalTy :: Ty -> Ty -> Bool
-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
- (Nothing, Nothing) -> v1 == v2
- _ -> False
- eqTy _ _ (Tcon c1) (Tcon c2) = c1 == c2
- eqTy e1 e2 (Tapp t1a t1b) (Tapp t2a t2b) =
- eqTy e1 e2 t1a t2a && eqTy e1 e2 t1b t2b
- eqTy e1 e2 (Tforall (tv1,tk1) b1) (Tforall (tv2,tk2) b2) =
- tk1 `eqKind` tk2 && eqTy (tv1:e1) (tv2:e2) b1 b2
- eqTy _ _ _ _ = False
-instance Eq Ty where (==) = equalTy
-
-
-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
-baseKind (Karrow _ _ ) = False
-baseKind _ = True
-
-isPrimVar (Just mn,_) = mn == primMname
-isPrimVar _ = False
-
-primMname = mkPrimMname "Prim"
-errMname = mkBaseMname "Err"
-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 = error "Somebody called baseMname!" -- mkBaseMname "Base"
-boolMname = mkPrimMname "Bool"
-mainVar = qual mainMname "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 -}
-
-maxUtuple :: Int
-maxUtuple = 100
-
-tcUtuple :: Int -> Qual Tcon
-tcUtuple n = (Just primMname,"Z"++ (show n) ++ "H")
-
-ktUtuple :: Int -> Kind
-ktUtuple n = foldr Karrow Kunlifted (replicate n Kopen)
-
-tUtuple :: [Ty] -> Ty
-tUtuple ts = foldl Tapp (Tcon (tcUtuple (length ts))) ts
-
-isUtupleTy :: Ty -> Bool
-isUtupleTy (Tapp t _) = isUtupleTy t
-isUtupleTy (Tcon tc) =
- case tc of
- (Just pm, 'Z':rest) | pm == primMname && last rest == 'H' ->
- let mid = take ((length rest) - 1) rest in
- all isDigit mid && (let num = read mid in
- 1 <= num && num <= maxUtuple)
- _ -> False
--- The above is ugly, but less ugly than this:
---tc `elem` [tcUtuple n | n <- [1..maxUtuple]]
-isUtupleTy _ = False
-
-dcUtuple :: Int -> Qual Dcon
--- 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]]
-
-dcUtupleTy :: Int -> Ty
-dcUtupleTy n =
- foldr ( \tv t -> Tforall (tv,Kopen) t)
- (foldr ( \tv t -> tArrow (Tvar tv) t)
- (tUtuple (map Tvar tvs)) tvs)
- tvs
- where tvs = map ( \i -> ("a" ++ (show i))) [1..n]
-
-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 [] = []
-
-unitMname :: AnMname
-unitMname = mkPrimMname "Unit"
projects / ghc-hetmet.git / blobdiff