5 import List (elemIndex)
8 = Module AnMname [Tdef] [Vdefg]
11 = Data (Qual Tcon) [Tbind] [Cdef]
12 | Newtype (Qual Tcon) [Tbind] Axiom (Maybe Ty)
15 = Constr (Qual Dcon) [Tbind] [Ty]
18 type Axiom = (Qual Tcon, [Tbind], (Ty,Ty))
24 newtype Vdef = Vdef (Qual Var,Ty,Exp)
34 | Case Exp Vbind Ty [Alt] {- non-empty list -}
44 = Acon (Qual Dcon) [Tbind] [Vbind] Exp
49 type Tbind = (Tvar,Kind)
56 -- Wired-in coercions:
57 -- These are primitive tycons in GHC, but in ext-core,
58 -- we make them explicit, to make the typechecker
59 -- somewhat more clear.
62 | UnsafeCoercion Ty Ty
73 -- A CoercionKind isn't really a Kind at all, but rather,
74 -- corresponds to an arbitrary user-declared axiom.
75 -- A tycon whose CoercionKind is (DefinedCoercion <tbs> (from, to))
76 -- represents a tycon with arity (length tbs), whose kind is
77 -- (from :=: to) (modulo substituting type arguments.
78 -- It's not a Kind because a coercion must always be fully applied:
79 -- whenever we see a tycon that has such a CoercionKind, it must
80 -- be fully applied if it's to be assigned an actual Kind.
81 -- So, a CoercionKind *only* appears in the environment (mapping
82 -- newtype axioms onto CoercionKinds).
85 DefinedCoercion [Tbind] (Ty,Ty)
87 -- The type constructor environment maps names that are
88 -- either type constructors or coercion names onto either
89 -- kinds or coercion kinds.
90 data KindOrCoercion = Kind Kind | Coercion CoercionKind
92 data Lit = Literal CoreLit Ty
93 deriving Eq -- with nearlyEqualTy
95 data CoreLit = Lint Integer
101 -- Right now we represent module names as triples:
102 -- (package name, hierarchical names, leaf name)
103 -- An alternative to this would be to flatten the
104 -- module namespace, either when printing out
105 -- Core or (probably preferably) in a
107 -- We represent the empty module name (as in an unqualified name)
110 type Mname = Maybe AnMname
111 type AnMname = (Pname, [Id], Id)
118 type Qual t = (Mname,t)
120 qual :: AnMname -> t -> Qual t
121 qual mn t = (Just mn, t)
123 unqual :: t -> Qual t
128 eqKind :: Kind -> Kind -> Bool
129 eqKind Klifted Klifted = True
130 eqKind Kunlifted Kunlifted = True
131 eqKind Kopen Kopen = True
132 eqKind (Karrow k1 k2) (Karrow l1 l2) = k1 `eqKind` l1
134 eqKind _ _ = False -- no Keq kind is ever equal to any other...
138 splitTyConApp_maybe :: Ty -> Maybe (Qual Tcon,[Ty])
139 splitTyConApp_maybe (Tvar _) = Nothing
140 splitTyConApp_maybe (Tcon t) = Just (t,[])
141 splitTyConApp_maybe (Tapp rator rand) =
142 case (splitTyConApp_maybe rator) of
143 Just (r,rs) -> Just (r,rs++[rand])
144 Nothing -> case rator of
145 Tcon tc -> Just (tc,[rand])
147 splitTyConApp_maybe t@(Tforall _ _) = Nothing
149 {- Doesn't expand out fully applied newtype synonyms
150 (for which an environment is needed). -}
151 nearlyEqualTy t1 t2 = eqTy [] [] t1 t2
152 where eqTy e1 e2 (Tvar v1) (Tvar v2) =
153 case (elemIndex v1 e1,elemIndex v2 e2) of
154 (Just i1, Just i2) -> i1 == i2
155 (Nothing, Nothing) -> v1 == v2
157 eqTy e1 e2 (Tcon c1) (Tcon c2) = c1 == c2
158 eqTy e1 e2 (Tapp t1a t1b) (Tapp t2a t2b) =
159 eqTy e1 e2 t1a t2a && eqTy e1 e2 t1b t2b
160 eqTy e1 e2 (Tforall (tv1,tk1) t1) (Tforall (tv2,tk2) t2) =
161 tk1 `eqKind` tk2 && eqTy (tv1:e1) (tv2:e2) t1 t2
163 instance Eq Ty where (==) = nearlyEqualTy
166 subKindOf :: Kind -> Kind -> Bool
167 _ `subKindOf` Kopen = True
168 (Karrow a1 r1) `subKindOf` (Karrow a2 r2) =
169 a2 `subKindOf` a1 && (r1 `subKindOf` r2)
170 k1 `subKindOf` k2 = k1 `eqKind` k2 -- doesn't worry about higher kinds
172 baseKind :: Kind -> Bool
173 baseKind (Karrow _ _ ) = False
176 isPrimVar (Just mn,_) = mn == primMname
179 primMname = mkPrimMname "Prim"
180 errMname = mkBaseMname "Err"
181 mkBaseMname,mkPrimMname :: Id -> AnMname
182 mkBaseMname mn = (basePkg, ghcPrefix, mn)
183 mkPrimMname mn = (primPkg, ghcPrefix, mn)
186 primPkg = zEncodeString "ghc-prim"
189 baseMname = mkBaseMname "Base"
190 boolMname = mkPrimMname "Bool"
191 mainVar = qual mainMname "main"
192 mainMname = (mainPkg, mainPrefix, "Main")
193 wrapperMainMname = Just (mainPkg, mainPrefix, "ZCMain")
196 tcArrow = (Just primMname, "ZLzmzgZR")
198 tArrow :: Ty -> Ty -> Ty
199 tArrow t1 t2 = Tapp (Tapp (Tcon tcArrow) t1) t2
203 ktArrow = Karrow Kopen (Karrow Kopen Klifted)
210 tcUtuple :: Int -> Qual Tcon
211 tcUtuple n = (Just primMname,"Z"++ (show n) ++ "H")
213 ktUtuple :: Int -> Kind
214 ktUtuple n = foldr Karrow Kunlifted (replicate n Kopen)
216 tUtuple :: [Ty] -> Ty
217 tUtuple ts = foldl Tapp (Tcon (tcUtuple (length ts))) ts
219 isUtupleTy :: Ty -> Bool
220 isUtupleTy (Tapp t _) = isUtupleTy t
221 isUtupleTy (Tcon tc) = tc `elem` [tcUtuple n | n <- [1..maxUtuple]]
224 dcUtuple :: Int -> Qual Dcon
225 -- TODO: Seems like Z2H etc. appears in ext-core files,
226 -- not $wZ2H etc. Is this right?
227 dcUtuple n = (Just primMname,"Z" ++ (show n) ++ "H")
229 isUtupleDc :: Qual Dcon -> Bool
230 isUtupleDc dc = dc `elem` [dcUtuple n | n <- [1..maxUtuple]]
232 dcUtupleTy :: Int -> Ty
234 foldr ( \tv t -> Tforall (tv,Kopen) t)
235 (foldr ( \tv t -> tArrow (Tvar tv) t)
236 (tUtuple (map Tvar tvs)) tvs)
238 where tvs = map ( \i -> ("a" ++ (show i))) [1..n]
240 utuple :: [Ty] -> [Exp] -> Exp
241 utuple ts es = foldl App (foldl Appt (Dcon (dcUtuple (length es))) ts) es