3 import List (elemIndex)
6 = Module Mname [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)
29 | Case Exp Vbind [Alt] {- non-empty list -}
39 = Acon (Qual Dcon) [Tbind] [Vbind] Exp
44 type Tbind = (Tvar,Kind)
61 | Lrational Rational Ty
64 deriving (Eq) -- with nearlyEqualTy
72 type Qual t = (Mname,t)
76 {- Doesn't expand out fully applied newtype synonyms
77 (for which an environment is needed). -}
78 nearlyEqualTy t1 t2 = eqTy [] [] t1 t2
79 where eqTy e1 e2 (Tvar v1) (Tvar v2) =
80 case (elemIndex v1 e1,elemIndex v2 e2) of
81 (Just i1, Just i2) -> i1 == i2
82 (Nothing, Nothing) -> v1 == v2
84 eqTy e1 e2 (Tcon c1) (Tcon c2) = c1 == c2
85 eqTy e1 e2 (Tapp t1a t1b) (Tapp t2a t2b) =
86 eqTy e1 e2 t1a t2a && eqTy e1 e2 t1b t2b
87 eqTy e1 e2 (Tforall (tv1,tk1) t1) (Tforall (tv2,tk2) t2) =
88 tk1 == tk2 && eqTy (tv1:e1) (tv2:e2) t1 t2
90 instance Eq Ty where (==) = nearlyEqualTy
93 subKindOf :: Kind -> Kind -> Bool
94 _ `subKindOf` Kopen = True
95 k1 `subKindOf` k2 = k1 == k2 -- doesn't worry about higher kinds
97 instance Ord Kind where (<=) = subKindOf
99 baseKind :: Kind -> Bool
100 baseKind (Karrow _ _ ) = False
103 primMname = "PrelGHC"
106 tcArrow = (primMname, "ZLzmzgZR")
108 tArrow :: Ty -> Ty -> Ty
109 tArrow t1 t2 = Tapp (Tapp (Tcon tcArrow) t1) t2
112 ktArrow = Karrow Kopen (Karrow Kopen Klifted)
119 tcUtuple :: Int -> Qual Tcon
120 tcUtuple n = (primMname,"Z"++ (show n) ++ "H")
122 ktUtuple :: Int -> Kind
123 ktUtuple n = foldr Karrow Kunlifted (replicate n Kopen)
125 tUtuple :: [Ty] -> Ty
126 tUtuple ts = foldl Tapp (Tcon (tcUtuple (length ts))) ts
128 isUtupleTy :: Ty -> Bool
129 isUtupleTy (Tapp t _) = isUtupleTy t
130 isUtupleTy (Tcon tc) = tc `elem` [tcUtuple n | n <- [1..maxUtuple]]
133 dcUtuple :: Int -> Qual Dcon
134 dcUtuple n = (primMname,"ZdwZ" ++ (show n) ++ "H")
136 isUtupleDc :: Qual Dcon -> Bool
137 isUtupleDc dc = dc `elem` [dcUtuple n | n <- [1..maxUtuple]]
139 dcUtupleTy :: Int -> Ty
141 foldr ( \tv t -> Tforall (tv,Kopen) t)
142 (foldr ( \tv t -> tArrow (Tvar tv) t)
143 (tUtuple (map Tvar tvs)) tvs)
145 where tvs = map ( \i -> ("a" ++ (show i))) [1..n]
147 utuple :: [Ty] -> [Exp] -> Exp
148 utuple ts es = foldl App (foldl Appt (Dcon (dcUtuple (length es))) ts) es