3 import List (elemIndex)
6 = Module AnMname [Tdef] [Vdefg]
9 = Data (Qual Tcon) [Tbind] [Cdef]
10 | Newtype (Qual Tcon) [Tbind] (Maybe Ty)
13 = Constr (Qual Dcon) [Tbind] [Ty]
19 newtype Vdef = Vdef (Qual Var,Ty,Exp)
25 -- Why were type apps and value apps distinguished,
26 -- but not type lambdas and value lambdas?
32 | Case Exp Vbind Ty [Alt] {- non-empty list -}
33 -- Renamed to Cast; switched order
43 = Acon (Qual Dcon) [Tbind] [Vbind] Exp
48 type Tbind = (Tvar,Kind)
65 | Lrational Rational Ty
68 deriving (Eq) -- with nearlyEqualTy
71 -- this requires at least one module name,
72 -- and possibly other hierarchical names
73 -- an alternative would be to flatten the
74 -- module namespace, either when printing out
75 -- Core or (probably preferably) in a
77 -- Maybe because the empty module name is a module name (represented as
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 --- tjc: I haven't looked at the rest of this file. ---
100 {- Doesn't expand out fully applied newtype synonyms
101 (for which an environment is needed). -}
102 nearlyEqualTy t1 t2 = eqTy [] [] t1 t2
103 where eqTy e1 e2 (Tvar v1) (Tvar v2) =
104 case (elemIndex v1 e1,elemIndex v2 e2) of
105 (Just i1, Just i2) -> i1 == i2
106 (Nothing, Nothing) -> v1 == v2
108 eqTy e1 e2 (Tcon c1) (Tcon c2) = c1 == c2
109 eqTy e1 e2 (Tapp t1a t1b) (Tapp t2a t2b) =
110 eqTy e1 e2 t1a t2a && eqTy e1 e2 t1b t2b
111 eqTy e1 e2 (Tforall (tv1,tk1) t1) (Tforall (tv2,tk2) t2) =
112 tk1 == tk2 && eqTy (tv1:e1) (tv2:e2) t1 t2
114 instance Eq Ty where (==) = nearlyEqualTy
117 subKindOf :: Kind -> Kind -> Bool
118 _ `subKindOf` Kopen = True
119 k1 `subKindOf` k2 = k1 == k2 -- doesn't worry about higher kinds
121 instance Ord Kind where (<=) = subKindOf
123 baseKind :: Kind -> Bool
124 baseKind (Karrow _ _ ) = False
127 isPrimVar (Just mn,_) = mn == primMname
130 primMname = mkBaseMname "Prim"
131 errMname = mkBaseMname "Err"
132 mkBaseMname :: Id -> AnMname
133 mkBaseMname mn = (basePkg, ghcPrefix, mn)
138 baseMname = mkBaseMname "Base"
139 mainVar = qual mainMname "main"
140 mainMname = (mainPkg, mainPrefix, "Main")
143 tcArrow = (Just primMname, "ZLzmzgZR")
145 tArrow :: Ty -> Ty -> Ty
146 tArrow t1 t2 = Tapp (Tapp (Tcon tcArrow) t1) t2
150 ktArrow = Karrow Kopen (Karrow Kopen Klifted)
154 -- tjc: not sure whether anything that follows is right
159 tcUtuple :: Int -> Qual Tcon
160 tcUtuple n = (Just primMname,"Z"++ (show n) ++ "H")
162 ktUtuple :: Int -> Kind
163 ktUtuple n = foldr Karrow Kunlifted (replicate n Kopen)
165 tUtuple :: [Ty] -> Ty
166 tUtuple ts = foldl Tapp (Tcon (tcUtuple (length ts))) ts
168 isUtupleTy :: Ty -> Bool
169 isUtupleTy (Tapp t _) = isUtupleTy t
170 isUtupleTy (Tcon tc) = tc `elem` [tcUtuple n | n <- [1..maxUtuple]]
173 dcUtuple :: Int -> Qual Dcon
174 dcUtuple n = (Just primMname,"ZdwZ" ++ (show n) ++ "H")
176 isUtupleDc :: Qual Dcon -> Bool
177 isUtupleDc dc = dc `elem` [dcUtuple n | n <- [1..maxUtuple]]
179 dcUtupleTy :: Int -> Ty
181 foldr ( \tv t -> Tforall (tv,Kopen) t)
182 (foldr ( \tv t -> tArrow (Tvar tv) t)
183 (tUtuple (map Tvar tvs)) tvs)
185 where tvs = map ( \i -> ("a" ++ (show i))) [1..n]
187 utuple :: [Ty] -> [Exp] -> Exp
188 utuple ts es = foldl App (foldl Appt (Dcon (dcUtuple (length es))) ts) es