3 import List (elemIndex)
6 = Module AnMname [Tdef] [Vdefg]
9 = Data (Qual Tcon) [Tbind] [Cdef]
10 | Newtype (Qual Tcon) [Tbind] Axiom (Maybe Ty)
13 = Constr (Qual Dcon) [Tbind] [Ty]
16 type Axiom = (Qual Tcon, Kind)
22 newtype Vdef = Vdef (Qual Var,Ty,Exp)
32 | Case Exp Vbind Ty [Alt] {- non-empty list -}
42 = Acon (Qual Dcon) [Tbind] [Vbind] Exp
47 type Tbind = (Tvar,Kind)
62 data Lit = Literal CoreLit Ty
63 deriving Eq -- with nearlyEqualTy
65 data CoreLit = Lint Integer
71 -- Right now we represent module names as triples:
72 -- (package name, hierarchical names, leaf name)
73 -- An alternative to this would be to flatten the
74 -- module namespace, either when printing out
75 -- Core or (probably preferably) in a
77 -- The empty module name (as in an unqualified name)
78 -- is represented as Nothing.
80 type Mname = Maybe AnMname
81 type AnMname = (Pname, [Id], Id)
88 type Qual t = (Mname,t)
90 qual :: AnMname -> t -> Qual t
91 qual mn t = (Just mn, t)
98 eqKind :: Kind -> Kind -> Bool
99 eqKind Klifted Klifted = True
100 eqKind Kunlifted Kunlifted = True
101 eqKind Kopen Kopen = True
102 eqKind (Karrow k1 k2) (Karrow l1 l2) = k1 `eqKind` l1
104 eqKind _ _ = False -- no Keq kind is ever equal to any other...
107 --- tjc: I haven't looked at the rest of this file. ---
109 {- Doesn't expand out fully applied newtype synonyms
110 (for which an environment is needed). -}
111 nearlyEqualTy t1 t2 = eqTy [] [] t1 t2
112 where eqTy e1 e2 (Tvar v1) (Tvar v2) =
113 case (elemIndex v1 e1,elemIndex v2 e2) of
114 (Just i1, Just i2) -> i1 == i2
115 (Nothing, Nothing) -> v1 == v2
117 eqTy e1 e2 (Tcon c1) (Tcon c2) = c1 == c2
118 eqTy e1 e2 (Tapp t1a t1b) (Tapp t2a t2b) =
119 eqTy e1 e2 t1a t2a && eqTy e1 e2 t1b t2b
120 eqTy e1 e2 (Tforall (tv1,tk1) t1) (Tforall (tv2,tk2) t2) =
121 tk1 `eqKind` tk2 && eqTy (tv1:e1) (tv2:e2) t1 t2
123 instance Eq Ty where (==) = nearlyEqualTy
126 subKindOf :: Kind -> Kind -> Bool
127 _ `subKindOf` Kopen = True
128 k1 `subKindOf` k2 = k1 `eqKind` k2 -- doesn't worry about higher kinds
130 baseKind :: Kind -> Bool
131 baseKind (Karrow _ _ ) = False
134 isPrimVar (Just mn,_) = mn == primMname
137 primMname = mkBaseMname "Prim"
138 errMname = mkBaseMname "Err"
139 mkBaseMname :: Id -> AnMname
140 mkBaseMname mn = (basePkg, ghcPrefix, mn)
145 baseMname = mkBaseMname "Base"
146 mainVar = qual mainMname "main"
147 mainMname = (mainPkg, mainPrefix, "Main")
150 tcArrow = (Just primMname, "ZLzmzgZR")
152 tArrow :: Ty -> Ty -> Ty
153 tArrow t1 t2 = Tapp (Tapp (Tcon tcArrow) t1) t2
157 ktArrow = Karrow Kopen (Karrow Kopen Klifted)
161 -- tjc: not sure whether anything that follows is right
166 tcUtuple :: Int -> Qual Tcon
167 tcUtuple n = (Just primMname,"Z"++ (show n) ++ "H")
169 ktUtuple :: Int -> Kind
170 ktUtuple n = foldr Karrow Kunlifted (replicate n Kopen)
172 tUtuple :: [Ty] -> Ty
173 tUtuple ts = foldl Tapp (Tcon (tcUtuple (length ts))) ts
175 isUtupleTy :: Ty -> Bool
176 isUtupleTy (Tapp t _) = isUtupleTy t
177 isUtupleTy (Tcon tc) = tc `elem` [tcUtuple n | n <- [1..maxUtuple]]
180 dcUtuple :: Int -> Qual Dcon
181 dcUtuple n = (Just primMname,"ZdwZ" ++ (show n) ++ "H")
183 isUtupleDc :: Qual Dcon -> Bool
184 isUtupleDc dc = dc `elem` [dcUtuple n | n <- [1..maxUtuple]]
186 dcUtupleTy :: Int -> Ty
188 foldr ( \tv t -> Tforall (tv,Kopen) t)
189 (foldr ( \tv t -> tArrow (Tvar tv) t)
190 (tUtuple (map Tvar tvs)) tvs)
192 where tvs = map ( \i -> ("a" ++ (show i))) [1..n]
194 utuple :: [Ty] -> [Exp] -> Exp
195 utuple ts es = foldl App (foldl Appt (Dcon (dcUtuple (length es))) ts) es