1 {-# OPTIONS -fno-warn-missing-signatures #-}
2 module Language.Core.Core where
4 import Language.Core.Encoding
7 import Data.List (elemIndex)
11 = Module AnMname [Tdef] [Vdefg]
12 deriving (Data, Typeable)
15 = Data (Qual Tcon) [Tbind] [Cdef]
16 -- type constructor; coercion name; type arguments; type rep
17 -- If we have: (Newtype tc co tbs (Just t))
18 -- there is an implicit axiom:
19 -- co tbs :: tc tbs :=: t
20 | Newtype (Qual Tcon) (Qual Tcon) [Tbind] Ty
21 deriving (Data, Typeable)
24 = Constr (Qual Dcon) [Tbind] [Ty]
25 deriving (Data, Typeable)
30 deriving (Data, Typeable)
32 newtype Vdef = Vdef (Qual Var,Ty,Exp)
33 deriving (Data, Typeable)
43 | Case Exp Vbind Ty [Alt] {- non-empty list -}
47 deriving (Data, Typeable)
52 deriving (Data, Typeable)
55 = Acon (Qual Dcon) [Tbind] [Vbind] Exp
58 deriving (Data, Typeable)
61 type Tbind = (Tvar,Kind)
68 -- Wired-in coercions:
69 -- These are primitive tycons in GHC, but in ext-core,
70 -- we make them explicit, to make the typechecker
71 -- somewhat more clear.
74 | UnsafeCoercion Ty Ty
78 deriving (Data, Typeable)
86 deriving (Data, Typeable)
88 -- A CoercionKind isn't really a Kind at all, but rather,
89 -- corresponds to an arbitrary user-declared axiom.
90 -- A tycon whose CoercionKind is (DefinedCoercion <tbs> (from, to))
91 -- represents a tycon with arity (length tbs), whose kind is
92 -- (from :=: to) (modulo substituting type arguments.
93 -- It's not a Kind because a coercion must always be fully applied:
94 -- whenever we see a tycon that has such a CoercionKind, it must
95 -- be fully applied if it's to be assigned an actual Kind.
96 -- So, a CoercionKind *only* appears in the environment (mapping
97 -- newtype axioms onto CoercionKinds).
100 DefinedCoercion [Tbind] (Ty,Ty)
102 -- The type constructor environment maps names that are
103 -- either type constructors or coercion names onto either
104 -- kinds or coercion kinds.
105 data KindOrCoercion = Kind Kind | Coercion CoercionKind
107 data Lit = Literal CoreLit Ty
108 deriving (Data, Typeable, Eq)
110 data CoreLit = Lint Integer
114 deriving (Data, Typeable, Eq)
116 -- Right now we represent module names as triples:
117 -- (package name, hierarchical names, leaf name)
118 -- An alternative to this would be to flatten the
119 -- module namespace, either when printing out
120 -- Core or (probably preferably) in a
122 -- We represent the empty module name (as in an unqualified name)
125 type Mname = Maybe AnMname
126 newtype AnMname = M (Pname, [Id], Id)
127 deriving (Eq, Ord, Data, Typeable)
129 deriving (Eq, Ord, Data, Typeable)
135 type Qual t = (Mname,t)
137 qual :: AnMname -> t -> Qual t
138 qual mn t = (Just mn, t)
140 unqual :: t -> Qual t
143 getModule :: Qual t -> Mname
148 eqKind :: Kind -> Kind -> Bool
149 eqKind Klifted Klifted = True
150 eqKind Kunlifted Kunlifted = True
151 eqKind Kopen Kopen = True
152 eqKind (Karrow k1 k2) (Karrow l1 l2) = k1 `eqKind` l1
154 eqKind (Keq t1 t2) (Keq u1 u2) = t1 == u1
158 splitTyConApp_maybe :: Ty -> Maybe (Qual Tcon,[Ty])
159 splitTyConApp_maybe (Tvar _) = Nothing
160 splitTyConApp_maybe (Tcon t) = Just (t,[])
161 splitTyConApp_maybe (Tapp rator rand) =
162 case (splitTyConApp_maybe rator) of
163 Just (r,rs) -> Just (r,rs++[rand])
164 Nothing -> case rator of
165 Tcon tc -> Just (tc,[rand])
167 splitTyConApp_maybe (Tforall _ _) = Nothing
169 splitTyConApp_maybe _ = Nothing
171 -- This used to be called nearlyEqualTy, but now that
172 -- we don't need to expand newtypes anymore, it seems
173 -- like equality to me!
174 equalTy :: Ty -> Ty -> Bool
175 equalTy t1 t2 = eqTy [] [] t1 t2
176 where eqTy e1 e2 (Tvar v1) (Tvar v2) =
177 case (elemIndex v1 e1,elemIndex v2 e2) of
178 (Just i1, Just i2) -> i1 == i2
179 (Nothing, Nothing) -> v1 == v2
181 eqTy _ _ (Tcon c1) (Tcon c2) = c1 == c2
182 eqTy e1 e2 (Tapp t1a t1b) (Tapp t2a t2b) =
183 eqTy e1 e2 t1a t2a && eqTy e1 e2 t1b t2b
184 eqTy e1 e2 (Tforall (tv1,tk1) b1) (Tforall (tv2,tk2) b2) =
185 tk1 `eqKind` tk2 && eqTy (tv1:e1) (tv2:e2) b1 b2
187 instance Eq Ty where (==) = equalTy
190 subKindOf :: Kind -> Kind -> Bool
191 _ `subKindOf` Kopen = True
192 (Karrow a1 r1) `subKindOf` (Karrow a2 r2) =
193 a2 `subKindOf` a1 && (r1 `subKindOf` r2)
194 k1 `subKindOf` k2 = k1 `eqKind` k2 -- doesn't worry about higher kinds
196 baseKind :: Kind -> Bool
197 baseKind (Karrow _ _ ) = False
200 isPrimVar (Just mn,_) = mn == primMname
203 primMname = mkPrimMname "Prim"
204 errMname = mkBaseMname "Err"
205 mkBaseMname,mkPrimMname :: Id -> AnMname
206 mkBaseMname mn = M (basePkg, ghcPrefix, mn)
207 mkPrimMname mn = M (primPkg, ghcPrefix, mn)
210 primPkg = P $ zEncodeString "ghc-prim"
213 baseMname = error "Somebody called baseMname!" -- mkBaseMname "Base"
214 boolMname = mkPrimMname "Bool"
215 mainVar = qual mainMname "main"
216 wrapperMainVar = qual wrapperMainMname "main"
217 mainMname = M (mainPkg, mainPrefix, "Main")
218 wrapperMainMname = M (mainPkg, mainPrefix, "ZCMain")
219 wrapperMainAnMname = Just wrapperMainMname
227 tcArrow = (Just primMname, "ZLzmzgZR")
229 tArrow :: Ty -> Ty -> Ty
230 tArrow t1 t2 = Tapp (Tapp (Tcon tcArrow) t1) t2
232 mkFunTy :: Ty -> Ty -> Ty
233 mkFunTy randTy resultTy =
234 Tapp (Tapp (Tcon tcArrow) randTy) resultTy
237 ktArrow = Karrow Kopen (Karrow Kopen Klifted)
244 tcUtuple :: Int -> Qual Tcon
245 tcUtuple n = (Just primMname,"Z"++ (show n) ++ "H")
247 ktUtuple :: Int -> Kind
248 ktUtuple n = foldr Karrow Kunlifted (replicate n Kopen)
250 tUtuple :: [Ty] -> Ty
251 tUtuple ts = foldl Tapp (Tcon (tcUtuple (length ts))) ts
253 isUtupleTy :: Ty -> Bool
254 isUtupleTy (Tapp t _) = isUtupleTy t
255 isUtupleTy (Tcon tc) =
257 (Just pm, 'Z':rest) | pm == primMname && last rest == 'H' ->
258 let mid = take ((length rest) - 1) rest in
259 all isDigit mid && (let num = read mid in
260 1 <= num && num <= maxUtuple)
262 -- The above is ugly, but less ugly than this:
263 --tc `elem` [tcUtuple n | n <- [1..maxUtuple]]
266 dcUtuple :: Int -> Qual Dcon
267 -- TODO: Seems like Z2H etc. appears in ext-core files,
268 -- not $wZ2H etc. Is this right?
269 dcUtuple n = (Just primMname,"Z" ++ (show n) ++ "H")
271 isUtupleDc :: Qual Dcon -> Bool
272 isUtupleDc dc = dc `elem` [dcUtuple n | n <- [1..maxUtuple]]
274 dcUtupleTy :: Int -> Ty
276 foldr ( \tv t -> Tforall (tv,Kopen) t)
277 (foldr ( \tv t -> tArrow (Tvar tv) t)
278 (tUtuple (map Tvar tvs)) tvs)
280 where tvs = map ( \i -> ("a" ++ (show i))) [1..n]
282 utuple :: [Ty] -> [Exp] -> Exp
283 utuple ts es = foldl App (foldl Appt (Dcon (dcUtuple (length es))) ts) es
285 ---- snarfed from GHC's CoreSyn
286 flattenBinds :: [Vdefg] -> [Vdef] -- Get all the lhs/rhs pairs
287 flattenBinds (Nonrec vd : binds) = vd : flattenBinds binds
288 flattenBinds (Rec prs1 : binds) = prs1 ++ flattenBinds binds
292 unitMname = mkPrimMname "Unit"