ghc/compiler/hsSyn/HsTypes.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[HsTypes]{Abstract syntax: user-defined types}
   5
   6 \begin{code}
   7 module HsTypes (
   8         HsType(..), MonoUsageAnn(..), HsTyVar(..),
   9         Context, ClassAssertion
  10
  11         , mkHsForAllTy, mkHsUsForAllTy
  12         , getTyVarName, replaceTyVarName
  13         , pprParendHsType
  14         , pprForAll, pprContext, pprClassAssertion
  15         , cmpHsType, cmpHsTypes, cmpContext
  16     ) where
  17
  18 #include "HsVersions.h"
  19
  20 import Type             ( Kind, UsageAnn(..) )
  21 import PprType          ( {- instance Outputable Kind -} )
  22 import Outputable
  23 import Util             ( thenCmp, cmpList )
  24 \end{code}
  25
  26 This is the syntax for types as seen in type signatures.
  27
  28 \begin{code}
  29 type Context name = [ClassAssertion name]
  30
  31 type ClassAssertion name = (name, [HsType name])
  32         -- The type is usually a type variable, but it
  33         -- doesn't have to be when reading interface files
  34
  35 data HsType name
  36   = HsForAllTy          (Maybe [HsTyVar name])  -- Nothing for implicitly quantified signatures
  37                         (Context name)
  38                         (HsType name)
  39
  40   | MonoTyVar           name            -- Type variable
  41
  42   | MonoTyApp           (HsType name)
  43                         (HsType name)
  44
  45   | MonoFunTy           (HsType name) -- function type
  46                         (HsType name)
  47
  48   | MonoListTy          (HsType name)   -- Element type
  49
  50   | MonoTupleTy         [HsType name]   -- Element types (length gives arity)
  51                         Bool            -- boxed?
  52
  53   -- these next two are only used in interfaces
  54   | MonoDictTy          name    -- Class
  55                         [HsType name]
  56
  57   | MonoUsgTy           (MonoUsageAnn name)
  58                         (HsType name)
  59
  60   | MonoUsgForAllTy     name
  61                         (HsType name)
  62
  63 data MonoUsageAnn name
  64   = MonoUsOnce
  65   | MonoUsMany
  66   | MonoUsVar name
  67
  68
  69 mkHsForAllTy []  []   ty = ty
  70 mkHsForAllTy tvs ctxt ty = HsForAllTy (Just tvs) ctxt ty
  71
  72 mkHsUsForAllTy uvs ty = foldr (\ uv ty -> MonoUsgForAllTy uv ty)
  73                               ty uvs
  74
  75 data HsTyVar name
  76   = UserTyVar name
  77   | IfaceTyVar name Kind
  78         -- *** NOTA BENE *** A "monotype" in a pragma can have
  79         -- for-alls in it, (mostly to do with dictionaries).  These
  80         -- must be explicitly Kinded.
  81
  82 getTyVarName (UserTyVar n)    = n
  83 getTyVarName (IfaceTyVar n _) = n
  84
  85 replaceTyVarName :: HsTyVar name1 -> name2 -> HsTyVar name2
  86 replaceTyVarName (UserTyVar n)    n' = UserTyVar n'
  87 replaceTyVarName (IfaceTyVar n k) n' = IfaceTyVar n' k
  88 \end{code}
  89
  90
  91 %************************************************************************
  92 %*                                                                      *
  93 \subsection{Pretty printing}
  94 %*                                                                      *
  95 %************************************************************************
  96
  97 \begin{code}
  98
  99 instance (Outputable name) => Outputable (HsType name) where
 100     ppr ty = pprHsType ty
 101
 102 instance (Outputable name) => Outputable (HsTyVar name) where
 103     ppr (UserTyVar name)       = ppr name
 104     ppr (IfaceTyVar name kind) = hsep [ppr name, dcolon, ppr kind]
 105
 106 pprForAll []  = empty
 107 pprForAll tvs = ptext SLIT("forall") <+> interppSP tvs <> ptext SLIT(".")
 108
 109 pprContext :: (Outputable name) => Context name -> SDoc
 110 pprContext []      = empty
 111 pprContext context = parens (hsep (punctuate comma (map pprClassAssertion context))) <+> ptext SLIT("=>")
 112
 113 pprClassAssertion :: (Outputable name) => ClassAssertion name -> SDoc
 114 pprClassAssertion (clas, tys)
 115   = ppr clas <+> hsep (map pprParendHsType tys)
 116 \end{code}
 117
 118 \begin{code}
 119 pREC_TOP = (0 :: Int)
 120 pREC_FUN = (1 :: Int)
 121 pREC_CON = (2 :: Int)
 122
 123 maybeParen :: Bool -> SDoc -> SDoc
 124 maybeParen True  p = parens p
 125 maybeParen False p = p
 126
 127 -- printing works more-or-less as for Types
 128
 129 pprHsType, pprParendHsType :: (Outputable name) => HsType name -> SDoc
 130
 131 pprHsType ty       = ppr_mono_ty pREC_TOP ty
 132 pprParendHsType ty = ppr_mono_ty pREC_CON ty
 133
 134 ppr_mono_ty ctxt_prec (HsForAllTy maybe_tvs ctxt ty)
 135   = maybeParen (ctxt_prec >= pREC_FUN) $
 136     sep [pprForAll tvs, pprContext ctxt, pprHsType ty]
 137   where
 138     tvs = case maybe_tvs of
 139                 Just tvs -> tvs
 140                 Nothing  -> []
 141
 142 ppr_mono_ty ctxt_prec (MonoTyVar name)
 143   = ppr name
 144
 145 ppr_mono_ty ctxt_prec (MonoFunTy ty1 ty2)
 146   = let p1 = ppr_mono_ty pREC_FUN ty1
 147         p2 = ppr_mono_ty pREC_TOP ty2
 148     in
 149     maybeParen (ctxt_prec >= pREC_FUN)
 150                (sep [p1, (<>) (ptext SLIT("-> ")) p2])
 151
 152 ppr_mono_ty ctxt_prec (MonoTupleTy tys True)
 153  = parens (sep (punctuate comma (map ppr tys)))
 154 ppr_mono_ty ctxt_prec (MonoTupleTy tys False)
 155  = ptext SLIT("(#") <> sep (punctuate comma (map ppr tys)) <> ptext SLIT("#)")
 156
 157 ppr_mono_ty ctxt_prec (MonoListTy ty)
 158  = brackets (ppr_mono_ty pREC_TOP ty)
 159
 160 ppr_mono_ty ctxt_prec (MonoTyApp fun_ty arg_ty)
 161   = maybeParen (ctxt_prec >= pREC_CON)
 162                (hsep [ppr_mono_ty pREC_FUN fun_ty, ppr_mono_ty pREC_CON arg_ty])
 163
 164 ppr_mono_ty ctxt_prec (MonoDictTy clas tys)
 165   = ppr clas <+> hsep (map (ppr_mono_ty pREC_CON) tys)
 166
 167 ppr_mono_ty ctxt_prec ty@(MonoUsgForAllTy _ _)
 168   = maybeParen (ctxt_prec >= pREC_FUN) $
 169     sep [ ptext SLIT("__fuall") <+> brackets pp_uvars <+> ptext SLIT("=>"),
 170           ppr_mono_ty pREC_TOP sigma
 171         ]
 172   where
 173     (uvars,sigma) = split [] ty
 174     pp_uvars      = interppSP uvars
 175
 176     split uvs (MonoUsgForAllTy uv ty') = split (uv:uvs) ty'
 177     split uvs ty'                      = (reverse uvs,ty')
 178
 179 ppr_mono_ty ctxt_prec (MonoUsgTy u ty)
 180   = maybeParen (ctxt_prec >= pREC_CON) $
 181     ptext SLIT("__u") <+> pp_ua <+> ppr_mono_ty pREC_CON ty
 182   where
 183     pp_ua = case u of
 184               MonoUsOnce   -> ptext SLIT("-")
 185               MonoUsMany   -> ptext SLIT("!")
 186               MonoUsVar uv -> ppr uv
 187 \end{code}
 188
 189
 190 %************************************************************************
 191 %*                                                                      *
 192 \subsection{Comparison}
 193 %*                                                                      *
 194 %************************************************************************
 195
 196 We do define a specialised equality for these \tr{*Type} types; used
 197 in checking interfaces.  Most any other use is likely to be {\em
 198 wrong}, so be careful!
 199
 200 \begin{code}
 201 cmpHsTyVar  :: (a -> a -> Ordering) -> HsTyVar a  -> HsTyVar a  -> Ordering
 202 cmpHsType   :: (a -> a -> Ordering) -> HsType a   -> HsType a   -> Ordering
 203 cmpHsTypes  :: (a -> a -> Ordering) -> [HsType a] -> [HsType a] -> Ordering
 204 cmpContext  :: (a -> a -> Ordering) -> Context  a -> Context  a -> Ordering
 205
 206 cmpHsTyVar cmp (UserTyVar v1)    (UserTyVar v2)    = v1 `cmp` v2
 207 cmpHsTyVar cmp (IfaceTyVar v1 _) (IfaceTyVar v2 _) = v1 `cmp` v2
 208 cmpHsTyVar cmp (UserTyVar _)     other             = LT
 209 cmpHsTyVar cmp other1            other2            = GT
 210
 211
 212 cmpHsTypes cmp [] []   = EQ
 213 cmpHsTypes cmp [] tys2 = LT
 214 cmpHsTypes cmp tys1 [] = GT
 215 cmpHsTypes cmp (ty1:tys1) (ty2:tys2) = cmpHsType cmp ty1 ty2 `thenCmp` cmpHsTypes cmp tys1 tys2
 216
 217 cmpHsType cmp (HsForAllTy tvs1 c1 t1) (HsForAllTy tvs2 c2 t2)
 218   = cmpMaybe (cmpList (cmpHsTyVar cmp)) tvs1 tvs2       `thenCmp`
 219     cmpContext cmp c1 c2                                `thenCmp`
 220     cmpHsType cmp t1 t2
 221
 222 cmpHsType cmp (MonoTyVar n1) (MonoTyVar n2)
 223   = cmp n1 n2
 224
 225 cmpHsType cmp (MonoTupleTy tys1 b1) (MonoTupleTy tys2 b2)
 226   = (b1 `compare` b2) `thenCmp` cmpHsTypes cmp tys1 tys2
 227
 228 cmpHsType cmp (MonoListTy ty1) (MonoListTy ty2)
 229   = cmpHsType cmp ty1 ty2
 230
 231 cmpHsType cmp (MonoTyApp fun_ty1 arg_ty1) (MonoTyApp fun_ty2 arg_ty2)
 232   = cmpHsType cmp fun_ty1 fun_ty2 `thenCmp` cmpHsType cmp arg_ty1 arg_ty2
 233
 234 cmpHsType cmp (MonoFunTy a1 b1) (MonoFunTy a2 b2)
 235   = cmpHsType cmp a1 a2 `thenCmp` cmpHsType cmp b1 b2
 236
 237 cmpHsType cmp (MonoDictTy c1 tys1)   (MonoDictTy c2 tys2)
 238   = cmp c1 c2 `thenCmp` cmpHsTypes cmp tys1 tys2
 239
 240 cmpHsType cmp (MonoUsgTy u1 ty1) (MonoUsgTy u2 ty2)
 241   = cmpUsg cmp u1 u2 `thenCmp` cmpHsType cmp ty1 ty2
 242
 243 cmpHsType cmp ty1 ty2 -- tags must be different
 244   = let tag1 = tag ty1
 245         tag2 = tag ty2
 246     in
 247     if tag1 _LT_ tag2 then LT else GT
 248   where
 249     tag (MonoTyVar n1)                  = (ILIT(1) :: FAST_INT)
 250     tag (MonoTupleTy tys1 _)            = ILIT(2)
 251     tag (MonoListTy ty1)                = ILIT(3)
 252     tag (MonoTyApp tc1 tys1)            = ILIT(4)
 253     tag (MonoFunTy a1 b1)               = ILIT(5)
 254     tag (MonoDictTy c1 tys1)            = ILIT(6)
 255     tag (MonoUsgTy c1 ty1)              = ILIT(7)
 256     tag (MonoUsgForAllTy uv1 ty1)       = ILIT(8)
 257     tag (HsForAllTy _ _ _)              = ILIT(9)
 258
 259 -------------------
 260 cmpContext cmp a b
 261   = cmpList cmp_ctxt a b
 262   where
 263     cmp_ctxt (c1, tys1) (c2, tys2)
 264       = cmp c1 c2 `thenCmp` cmpHsTypes cmp tys1 tys2
 265
 266 cmpUsg cmp  MonoUsOnce     MonoUsOnce    = EQ
 267 cmpUsg cmp  MonoUsMany     MonoUsMany    = EQ
 268 cmpUsg cmp (MonoUsVar u1) (MonoUsVar u2) = cmp u1 u2
 269
 270 cmpUsg cmp ua1 ua2  -- tags must be different
 271   = let tag1 = tag ua1
 272         tag2 = tag ua2
 273     in
 274         if tag1 _LT_ tag2 then LT else GT
 275   where
 276     tag MonoUsOnce       = (ILIT(1) :: FAST_INT)
 277     tag MonoUsMany       = ILIT(2)
 278     tag (MonoUsVar    _) = ILIT(3)
 279
 280 -- Should be in Maybes, I guess
 281 cmpMaybe cmp Nothing  Nothing  = EQ
 282 cmpMaybe cmp Nothing  (Just x) = LT
 283 cmpMaybe cmp (Just x)  Nothing = GT
 284 cmpMaybe cmp (Just x) (Just y) = x `cmp` y
 285 \end{code}