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 )
  25 import PprType          ( {- instance Outputable Kind -} )
  26 import Outputable
  27 import Util             ( thenCmp, cmpList, panic )
  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          [HsTyVar name]
  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 unfoldings in interfaces
  58   | MonoDictTy          name    -- Class
  59                         [HsType name]
  60
  61 mkHsForAllTy []  []   ty = ty
  62 mkHsForAllTy tvs ctxt ty = HsForAllTy tvs ctxt ty
  63
  64 data HsTyVar name
  65   = UserTyVar name
  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.
  70
  71 getTyVarName (UserTyVar n)    = n
  72 getTyVarName (IfaceTyVar n _) = n
  73
  74 replaceTyVarName :: HsTyVar name1 -> name2 -> HsTyVar name2
  75 replaceTyVarName (UserTyVar n)    n' = UserTyVar n'
  76 replaceTyVarName (IfaceTyVar n k) n' = IfaceTyVar n' k
  77 \end{code}
  78
  79
  80 %************************************************************************
  81 %*                                                                      *
  82 \subsection{Pretty printing}
  83 %*                                                                      *
  84 %************************************************************************
  85
  86 \begin{code}
  87
  88 instance (Outputable name) => Outputable (HsType name) where
  89     ppr ty = pprHsType ty
  90
  91 instance (Outputable name) => Outputable (HsTyVar name) where
  92     ppr (UserTyVar name)       = ppr name
  93     ppr (IfaceTyVar name kind) = hsep [ppr name, ptext SLIT("::"), ppr kind]
  94
  95 pprForAll []  = empty
  96 pprForAll tvs = ptext SLIT("forall") <+> interppSP tvs <> ptext SLIT(".")
  97
  98 pprContext :: (Outputable name) => Context name -> SDoc
  99 pprContext []      = empty
 100 pprContext context = parens (hsep (punctuate comma (map pprClassAssertion context))) <+> ptext SLIT("=>")
 101
 102 pprClassAssertion :: (Outputable name) => ClassAssertion name -> SDoc
 103 pprClassAssertion (clas, tys)
 104   = ppr clas <+> hsep (map ppr tys)
 105 \end{code}
 106
 107 \begin{code}
 108 pREC_TOP = (0 :: Int)
 109 pREC_FUN = (1 :: Int)
 110 pREC_CON = (2 :: Int)
 111
 112 maybeParen :: Bool -> SDoc -> SDoc
 113 maybeParen True  p = parens p
 114 maybeParen False p = p
 115
 116 -- printing works more-or-less as for Types
 117
 118 pprHsType, pprParendHsType :: (Outputable name) => HsType name -> SDoc
 119
 120 pprHsType ty       = ppr_mono_ty pREC_TOP ty
 121 pprParendHsType ty = ppr_mono_ty pREC_CON ty
 122
 123 ppr_mono_ty ctxt_prec (HsForAllTy tvs ctxt ty)
 124   = maybeParen (ctxt_prec >= pREC_FUN) $
 125     sep [pprForAll tvs, pprContext ctxt, pprHsType ty]
 126
 127 ppr_mono_ty ctxt_prec (MonoTyVar name)
 128   = ppr name
 129
 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
 133     in
 134     maybeParen (ctxt_prec >= pREC_FUN)
 135                (sep [p1, (<>) (ptext SLIT("-> ")) p2])
 136
 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("#)")
 141
 142 ppr_mono_ty ctxt_prec (MonoListTy ty)
 143  = brackets (ppr_mono_ty pREC_TOP ty)
 144
 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])
 148
 149 ppr_mono_ty ctxt_prec (MonoDictTy clas tys)
 150   = ppr clas <+> hsep (map (ppr_mono_ty pREC_CON) tys)
 151 \end{code}
 152
 153
 154 %************************************************************************
 155 %*                                                                      *
 156 \subsection{Comparison}
 157 %*                                                                      *
 158 %************************************************************************
 159
 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!
 163
 164 \begin{code}
 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
 169
 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
 174
 175
 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
 180
 181 cmpHsType cmp (HsForAllTy tvs1 c1 t1) (HsForAllTy tvs2 c2 t2)
 182   = cmpList (cmpHsTyVar cmp) tvs1 tvs2  `thenCmp`
 183     cmpContext cmp c1 c2                `thenCmp`
 184     cmpHsType cmp t1 t2
 185
 186 cmpHsType cmp (MonoTyVar n1) (MonoTyVar n2)
 187   = cmp n1 n2
 188
 189 cmpHsType cmp (MonoTupleTy tys1 b1) (MonoTupleTy tys2 b2)
 190   = (b1 `compare` b2) `thenCmp` cmpHsTypes cmp tys1 tys2
 191
 192 cmpHsType cmp (MonoListTy ty1) (MonoListTy ty2)
 193   = cmpHsType cmp ty1 ty2
 194
 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
 197
 198 cmpHsType cmp (MonoFunTy a1 b1) (MonoFunTy a2 b2)
 199   = cmpHsType cmp a1 a2 `thenCmp` cmpHsType cmp b1 b2
 200
 201 cmpHsType cmp (MonoDictTy c1 tys1)   (MonoDictTy c2 tys2)
 202   = cmp c1 c2 `thenCmp` cmpHsTypes cmp tys1 tys2
 203
 204 cmpHsType cmp ty1 ty2 -- tags must be different
 205   = let tag1 = tag ty1
 206         tag2 = tag ty2
 207     in
 208     if tag1 _LT_ tag2 then LT else GT
 209   where
 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)
 217
 218 -------------------
 219 cmpContext cmp a b
 220   = cmpList cmp_ctxt a b
 221   where
 222     cmp_ctxt (c1, tys1) (c2, tys2)
 223       = cmp c1 c2 `thenCmp` cmpHsTypes cmp tys1 tys2
 224 \end{code}