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