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