2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[HsTypes]{Abstract syntax: user-defined types}
6 If compiled without \tr{#define COMPILING_GHC}, you get
7 (part of) a Haskell-abstract-syntax library. With it,
12 HsType(..), HsTyVar(..),
13 Context, ClassAssertion
16 , getTyVarName, replaceTyVarName
18 , pprForAll, pprContext, pprClassAssertion
19 , cmpHsType, cmpHsTypes, cmpContext
22 #include "HsVersions.h"
25 import PprType ( {- instance Outputable Kind -} )
27 import Util ( thenCmp, cmpList )
30 This is the syntax for types as seen in type signatures.
33 type Context name = [ClassAssertion name]
35 type ClassAssertion name = (name, [HsType name])
36 -- The type is usually a type variable, but it
37 -- doesn't have to be when reading interface files
40 = HsForAllTy [HsTyVar name]
44 | MonoTyVar name -- Type variable
46 | MonoTyApp (HsType name)
49 | MonoFunTy (HsType name) -- function type
52 | MonoListTy (HsType name) -- Element type
54 | MonoTupleTy [HsType name] -- Element types (length gives arity)
57 -- these next two are only used in unfoldings in interfaces
58 | MonoDictTy name -- Class
61 mkHsForAllTy [] [] ty = ty
62 mkHsForAllTy tvs ctxt ty = HsForAllTy tvs ctxt ty
66 | IfaceTyVar name Kind
67 -- *** NOTA BENE *** A "monotype" in a pragma can have
68 -- for-alls in it, (mostly to do with dictionaries). These
69 -- must be explicitly Kinded.
71 getTyVarName (UserTyVar n) = n
72 getTyVarName (IfaceTyVar n _) = n
74 replaceTyVarName :: HsTyVar name1 -> name2 -> HsTyVar name2
75 replaceTyVarName (UserTyVar n) n' = UserTyVar n'
76 replaceTyVarName (IfaceTyVar n k) n' = IfaceTyVar n' k
80 %************************************************************************
82 \subsection{Pretty printing}
84 %************************************************************************
88 instance (Outputable name) => Outputable (HsType name) where
91 instance (Outputable name) => Outputable (HsTyVar name) where
92 ppr (UserTyVar name) = ppr name
93 ppr (IfaceTyVar name kind) = hsep [ppr name, dcolon, ppr kind]
96 pprForAll tvs = ptext SLIT("forall") <+> interppSP tvs <> ptext SLIT(".")
98 pprContext :: (Outputable name) => Context name -> SDoc
100 pprContext context = parens (hsep (punctuate comma (map pprClassAssertion context))) <+> ptext SLIT("=>")
102 pprClassAssertion :: (Outputable name) => ClassAssertion name -> SDoc
103 pprClassAssertion (clas, tys)
104 = ppr clas <+> hsep (map pprParendHsType tys)
108 pREC_TOP = (0 :: Int)
109 pREC_FUN = (1 :: Int)
110 pREC_CON = (2 :: Int)
112 maybeParen :: Bool -> SDoc -> SDoc
113 maybeParen True p = parens p
114 maybeParen False p = p
116 -- printing works more-or-less as for Types
118 pprHsType, pprParendHsType :: (Outputable name) => HsType name -> SDoc
120 pprHsType ty = ppr_mono_ty pREC_TOP ty
121 pprParendHsType ty = ppr_mono_ty pREC_CON ty
123 ppr_mono_ty ctxt_prec (HsForAllTy tvs ctxt ty)
124 = maybeParen (ctxt_prec >= pREC_FUN) $
125 sep [pprForAll tvs, pprContext ctxt, pprHsType ty]
127 ppr_mono_ty ctxt_prec (MonoTyVar name)
130 ppr_mono_ty ctxt_prec (MonoFunTy ty1 ty2)
131 = let p1 = ppr_mono_ty pREC_FUN ty1
132 p2 = ppr_mono_ty pREC_TOP ty2
134 maybeParen (ctxt_prec >= pREC_FUN)
135 (sep [p1, (<>) (ptext SLIT("-> ")) p2])
137 ppr_mono_ty ctxt_prec (MonoTupleTy tys True)
138 = parens (sep (punctuate comma (map ppr tys)))
139 ppr_mono_ty ctxt_prec (MonoTupleTy tys False)
140 = ptext SLIT("(#") <> sep (punctuate comma (map ppr tys)) <> ptext SLIT("#)")
142 ppr_mono_ty ctxt_prec (MonoListTy ty)
143 = brackets (ppr_mono_ty pREC_TOP ty)
145 ppr_mono_ty ctxt_prec (MonoTyApp fun_ty arg_ty)
146 = maybeParen (ctxt_prec >= pREC_CON)
147 (hsep [ppr_mono_ty pREC_FUN fun_ty, ppr_mono_ty pREC_CON arg_ty])
149 ppr_mono_ty ctxt_prec (MonoDictTy clas tys)
150 = ppr clas <+> hsep (map (ppr_mono_ty pREC_CON) tys)
154 %************************************************************************
156 \subsection{Comparison}
158 %************************************************************************
160 We do define a specialised equality for these \tr{*Type} types; used
161 in checking interfaces. Most any other use is likely to be {\em
162 wrong}, so be careful!
165 cmpHsTyVar :: (a -> a -> Ordering) -> HsTyVar a -> HsTyVar a -> Ordering
166 cmpHsType :: (a -> a -> Ordering) -> HsType a -> HsType a -> Ordering
167 cmpHsTypes :: (a -> a -> Ordering) -> [HsType a] -> [HsType a] -> Ordering
168 cmpContext :: (a -> a -> Ordering) -> Context a -> Context a -> Ordering
170 cmpHsTyVar cmp (UserTyVar v1) (UserTyVar v2) = v1 `cmp` v2
171 cmpHsTyVar cmp (IfaceTyVar v1 _) (IfaceTyVar v2 _) = v1 `cmp` v2
172 cmpHsTyVar cmp (UserTyVar _) other = LT
173 cmpHsTyVar cmp other1 other2 = GT
176 cmpHsTypes cmp [] [] = EQ
177 cmpHsTypes cmp [] tys2 = LT
178 cmpHsTypes cmp tys1 [] = GT
179 cmpHsTypes cmp (ty1:tys1) (ty2:tys2) = cmpHsType cmp ty1 ty2 `thenCmp` cmpHsTypes cmp tys1 tys2
181 cmpHsType cmp (HsForAllTy tvs1 c1 t1) (HsForAllTy tvs2 c2 t2)
182 = cmpList (cmpHsTyVar cmp) tvs1 tvs2 `thenCmp`
183 cmpContext cmp c1 c2 `thenCmp`
186 cmpHsType cmp (MonoTyVar n1) (MonoTyVar n2)
189 cmpHsType cmp (MonoTupleTy tys1 b1) (MonoTupleTy tys2 b2)
190 = (b1 `compare` b2) `thenCmp` cmpHsTypes cmp tys1 tys2
192 cmpHsType cmp (MonoListTy ty1) (MonoListTy ty2)
193 = cmpHsType cmp ty1 ty2
195 cmpHsType cmp (MonoTyApp fun_ty1 arg_ty1) (MonoTyApp fun_ty2 arg_ty2)
196 = cmpHsType cmp fun_ty1 fun_ty2 `thenCmp` cmpHsType cmp arg_ty1 arg_ty2
198 cmpHsType cmp (MonoFunTy a1 b1) (MonoFunTy a2 b2)
199 = cmpHsType cmp a1 a2 `thenCmp` cmpHsType cmp b1 b2
201 cmpHsType cmp (MonoDictTy c1 tys1) (MonoDictTy c2 tys2)
202 = cmp c1 c2 `thenCmp` cmpHsTypes cmp tys1 tys2
204 cmpHsType cmp ty1 ty2 -- tags must be different
208 if tag1 _LT_ tag2 then LT else GT
210 tag (MonoTyVar n1) = (ILIT(1) :: FAST_INT)
211 tag (MonoTupleTy tys1 _) = ILIT(2)
212 tag (MonoListTy ty1) = ILIT(3)
213 tag (MonoTyApp tc1 tys1) = ILIT(4)
214 tag (MonoFunTy a1 b1) = ILIT(5)
215 tag (MonoDictTy c1 tys1) = ILIT(7)
216 tag (HsForAllTy _ _ _) = ILIT(8)
220 = cmpList cmp_ctxt a b
222 cmp_ctxt (c1, tys1) (c2, tys2)
223 = cmp c1 c2 `thenCmp` cmpHsTypes cmp tys1 tys2