6 import List (elemIndex)
9 = Module AnMname [Tdef] [Vdefg]
10 deriving (Data, Typeable)
13 = Data (Qual Tcon) [Tbind] [Cdef]
14 -- type constructor; coercion name; type arguments; type rep
15 -- If we have: (Newtype tc co tbs (Just t))
16 -- there is an implicit axiom:
17 -- co tbs :: tc tbs :=: t
18 | Newtype (Qual Tcon) (Qual Tcon) [Tbind] (Maybe Ty)
19 deriving (Data, Typeable)
22 = Constr (Qual Dcon) [Tbind] [Ty]
23 deriving (Data, Typeable)
28 deriving (Data, Typeable)
30 newtype Vdef = Vdef (Qual Var,Ty,Exp)
31 deriving (Data, Typeable)
41 | Case Exp Vbind Ty [Alt] {- non-empty list -}
45 deriving (Data, Typeable)
50 deriving (Data, Typeable)
53 = Acon (Qual Dcon) [Tbind] [Vbind] Exp
56 deriving (Data, Typeable)
59 type Tbind = (Tvar,Kind)
66 -- Wired-in coercions:
67 -- These are primitive tycons in GHC, but in ext-core,
68 -- we make them explicit, to make the typechecker
69 -- somewhat more clear.
72 | UnsafeCoercion Ty Ty
76 deriving (Data, Typeable)
84 deriving (Data, Typeable)
86 -- A CoercionKind isn't really a Kind at all, but rather,
87 -- corresponds to an arbitrary user-declared axiom.
88 -- A tycon whose CoercionKind is (DefinedCoercion <tbs> (from, to))
89 -- represents a tycon with arity (length tbs), whose kind is
90 -- (from :=: to) (modulo substituting type arguments.
91 -- It's not a Kind because a coercion must always be fully applied:
92 -- whenever we see a tycon that has such a CoercionKind, it must
93 -- be fully applied if it's to be assigned an actual Kind.
94 -- So, a CoercionKind *only* appears in the environment (mapping
95 -- newtype axioms onto CoercionKinds).
98 DefinedCoercion [Tbind] (Ty,Ty)
100 -- The type constructor environment maps names that are
101 -- either type constructors or coercion names onto either
102 -- kinds or coercion kinds.
103 data KindOrCoercion = Kind Kind | Coercion CoercionKind
105 data Lit = Literal CoreLit Ty
106 deriving (Data, Typeable, Eq) -- with nearlyEqualTy
108 data CoreLit = Lint Integer
112 deriving (Data, Typeable, Eq)
114 -- Right now we represent module names as triples:
115 -- (package name, hierarchical names, leaf name)
116 -- An alternative to this would be to flatten the
117 -- module namespace, either when printing out
118 -- Core or (probably preferably) in a
120 -- We represent the empty module name (as in an unqualified name)
123 type Mname = Maybe AnMname
124 newtype AnMname = M (Pname, [Id], Id)
125 deriving (Eq, Ord, Data, Typeable)
127 deriving (Eq, Ord, Data, Typeable)
133 type Qual t = (Mname,t)
135 qual :: AnMname -> t -> Qual t
136 qual mn t = (Just mn, t)
138 unqual :: t -> Qual t
141 getModule :: Qual t -> Mname
146 eqKind :: Kind -> Kind -> Bool
147 eqKind Klifted Klifted = True
148 eqKind Kunlifted Kunlifted = True
149 eqKind Kopen Kopen = True
150 eqKind (Karrow k1 k2) (Karrow l1 l2) = k1 `eqKind` l1
152 eqKind (Keq t1 t2) (Keq u1 u2) = t1 == u1
156 splitTyConApp_maybe :: Ty -> Maybe (Qual Tcon,[Ty])
157 splitTyConApp_maybe (Tvar _) = Nothing
158 splitTyConApp_maybe (Tcon t) = Just (t,[])
159 splitTyConApp_maybe (Tapp rator rand) =
160 case (splitTyConApp_maybe rator) of
161 Just (r,rs) -> Just (r,rs++[rand])
162 Nothing -> case rator of
163 Tcon tc -> Just (tc,[rand])
165 splitTyConApp_maybe t@(Tforall _ _) = Nothing
167 {- Doesn't expand out fully applied newtype synonyms
168 (for which an environment is needed). -}
169 nearlyEqualTy t1 t2 = eqTy [] [] t1 t2
170 where eqTy e1 e2 (Tvar v1) (Tvar v2) =
171 case (elemIndex v1 e1,elemIndex v2 e2) of
172 (Just i1, Just i2) -> i1 == i2
173 (Nothing, Nothing) -> v1 == v2
175 eqTy e1 e2 (Tcon c1) (Tcon c2) = c1 == c2
176 eqTy e1 e2 (Tapp t1a t1b) (Tapp t2a t2b) =
177 eqTy e1 e2 t1a t2a && eqTy e1 e2 t1b t2b
178 eqTy e1 e2 (Tforall (tv1,tk1) t1) (Tforall (tv2,tk2) t2) =
179 tk1 `eqKind` tk2 && eqTy (tv1:e1) (tv2:e2) t1 t2
181 instance Eq Ty where (==) = nearlyEqualTy
184 subKindOf :: Kind -> Kind -> Bool
185 _ `subKindOf` Kopen = True
186 (Karrow a1 r1) `subKindOf` (Karrow a2 r2) =
187 a2 `subKindOf` a1 && (r1 `subKindOf` r2)
188 k1 `subKindOf` k2 = k1 `eqKind` k2 -- doesn't worry about higher kinds
190 baseKind :: Kind -> Bool
191 baseKind (Karrow _ _ ) = False
194 isPrimVar (Just mn,_) = mn == primMname
197 primMname = mkPrimMname "Prim"
198 errMname = mkBaseMname "Err"
199 mkBaseMname,mkPrimMname :: Id -> AnMname
200 mkBaseMname mn = M (basePkg, ghcPrefix, mn)
201 mkPrimMname mn = M (primPkg, ghcPrefix, mn)
204 primPkg = P $ zEncodeString "ghc-prim"
207 baseMname = mkBaseMname "Base"
208 boolMname = mkPrimMname "Bool"
209 mainVar = qual mainMname "main"
210 wrapperMainVar = qual wrapperMainMname "main"
211 mainMname = M (mainPkg, mainPrefix, "Main")
212 wrapperMainMname = M (mainPkg, mainPrefix, "ZCMain")
213 wrapperMainAnMname = Just wrapperMainMname
221 tcArrow = (Just primMname, "ZLzmzgZR")
223 tArrow :: Ty -> Ty -> Ty
224 tArrow t1 t2 = Tapp (Tapp (Tcon tcArrow) t1) t2
226 mkFunTy :: Ty -> Ty -> Ty
227 mkFunTy randTy resultTy =
228 Tapp (Tapp (Tcon tcArrow) randTy) resultTy
231 ktArrow = Karrow Kopen (Karrow Kopen Klifted)
238 tcUtuple :: Int -> Qual Tcon
239 tcUtuple n = (Just primMname,"Z"++ (show n) ++ "H")
241 ktUtuple :: Int -> Kind
242 ktUtuple n = foldr Karrow Kunlifted (replicate n Kopen)
244 tUtuple :: [Ty] -> Ty
245 tUtuple ts = foldl Tapp (Tcon (tcUtuple (length ts))) ts
247 isUtupleTy :: Ty -> Bool
248 isUtupleTy (Tapp t _) = isUtupleTy t
249 isUtupleTy (Tcon tc) = tc `elem` [tcUtuple n | n <- [1..maxUtuple]]
252 dcUtuple :: Int -> Qual Dcon
253 -- TODO: Seems like Z2H etc. appears in ext-core files,
254 -- not $wZ2H etc. Is this right?
255 dcUtuple n = (Just primMname,"Z" ++ (show n) ++ "H")
257 isUtupleDc :: Qual Dcon -> Bool
258 isUtupleDc dc = dc `elem` [dcUtuple n | n <- [1..maxUtuple]]
260 dcUtupleTy :: Int -> Ty
262 foldr ( \tv t -> Tforall (tv,Kopen) t)
263 (foldr ( \tv t -> tArrow (Tvar tv) t)
264 (tUtuple (map Tvar tvs)) tvs)
266 where tvs = map ( \i -> ("a" ++ (show i))) [1..n]
268 utuple :: [Ty] -> [Exp] -> Exp
269 utuple ts es = foldl App (foldl Appt (Dcon (dcUtuple (length es))) ts) es
271 ---- snarfed from GHC's CoreSyn
272 flattenBinds :: [Vdefg] -> [Vdef] -- Get all the lhs/rhs pairs
273 flattenBinds (Nonrec vd : binds) = vd : flattenBinds binds
274 flattenBinds (Rec prs1 : binds) = prs1 ++ flattenBinds binds