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