ghc/compiler/hsSyn/HsTypes.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   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 [OLD COMMENT -- SOF 7/97]
  10
  11 \begin{code}
  12 #include "HsVersions.h"
  13
  14 module HsTypes (
  15         HsType(..), HsTyVar(..),
  16         SYN_IE(Context), SYN_IE(ClassAssertion)
  17
  18         , mkHsForAllTy
  19         , getTyVarName, replaceTyVarName
  20         , pprParendHsType
  21         , pprContext
  22         , cmpHsType, cmpContext
  23     ) where
  24
  25 IMP_Ubiq()
  26
  27 import CmdLineOpts      ( opt_PprUserLength )
  28 import Outputable       ( Outputable(..), PprStyle(..), pprQuote, interppSP )
  29 import Kind             ( Kind {- instance Outputable -} )
  30 import Name             ( nameOccName )
  31 import Pretty
  32 import Util             ( thenCmp, cmpList, isIn, panic# )
  33 \end{code}
  34
  35 This is the syntax for types as seen in type signatures.
  36
  37 \begin{code}
  38 type Context name = [ClassAssertion name]
  39
  40 type ClassAssertion name = (name, HsType name)
  41         -- The type is usually a type variable, but it
  42         -- doesn't have to be when reading interface files
  43
  44 data HsType name
  45   = HsPreForAllTy       (Context name)
  46                         (HsType name)
  47
  48         -- The renamer turns HsPreForAllTys into HsForAllTys when they
  49         -- occur in signatures, to make the binding of variables
  50         -- explicit.  This distinction is made visible for
  51         -- non-COMPILING_GHC code, because you probably want to do the
  52         -- same thing.
  53
  54   | HsForAllTy          [HsTyVar name]
  55                         (Context name)
  56                         (HsType name)
  57
  58   | MonoTyVar           name            -- Type variable
  59
  60   | MonoTyApp           (HsType name)
  61                         (HsType name)
  62
  63   | MonoFunTy           (HsType name) -- function type
  64                         (HsType name)
  65
  66   | MonoListTy          name            -- The list TyCon name
  67                         (HsType name)   -- Element type
  68
  69   | MonoTupleTy         name            -- The tuple TyCon name
  70                         [HsType name]   -- Element types (length gives arity)
  71
  72   -- these next two are only used in unfoldings in interfaces
  73   | MonoDictTy          name    -- Class
  74                         (HsType name)
  75
  76 mkHsForAllTy []  []   ty = ty
  77 mkHsForAllTy tvs ctxt ty = HsForAllTy tvs ctxt ty
  78
  79 data HsTyVar name
  80   = UserTyVar name
  81   | IfaceTyVar name Kind
  82         -- *** NOTA BENE *** A "monotype" in a pragma can have
  83         -- for-alls in it, (mostly to do with dictionaries).  These
  84         -- must be explicitly Kinded.
  85
  86 getTyVarName (UserTyVar n)    = n
  87 getTyVarName (IfaceTyVar n _) = n
  88
  89 replaceTyVarName :: HsTyVar name1 -> name2 -> HsTyVar name2
  90 replaceTyVarName (UserTyVar n)    n' = UserTyVar n'
  91 replaceTyVarName (IfaceTyVar n k) n' = IfaceTyVar n' k
  92 \end{code}
  93
  94
  95 %************************************************************************
  96 %*                                                                      *
  97 \subsection{Pretty printing}
  98 %*                                                                      *
  99 %************************************************************************
 100
 101 \begin{code}
 102
 103 instance (Outputable name) => Outputable (HsType name) where
 104     ppr sty ty = pprQuote sty $ \ sty -> pprHsType sty ty
 105
 106 instance (Outputable name) => Outputable (HsTyVar name) where
 107     ppr sty (UserTyVar name)       = ppr sty name
 108     ppr sty (IfaceTyVar name kind) = pprQuote sty $ \ sty ->
 109                                      hsep [ppr sty name, ptext SLIT("::"), ppr sty kind]
 110
 111 ppr_forall sty ctxt_prec [] [] ty
 112    = ppr_mono_ty sty ctxt_prec ty
 113 ppr_forall sty ctxt_prec tvs ctxt ty
 114    = maybeParen (ctxt_prec >= pREC_FUN) $
 115      sep [ptext SLIT("_forall_"), brackets (interppSP sty tvs),
 116             pprContext sty ctxt,  ptext SLIT("=>"),
 117             pprHsType sty ty]
 118
 119 pprContext :: (Outputable name) => PprStyle -> (Context name) -> Doc
 120 pprContext sty []               = empty
 121 pprContext sty context
 122   = pprQuote sty $ \ sty -> parens (hsep (punctuate comma (map ppr_assert context)))
 123   where
 124     ppr_assert (clas, ty) = hsep [ppr sty clas, ppr sty ty]
 125 \end{code}
 126
 127 \begin{code}
 128 pREC_TOP = (0 :: Int)
 129 pREC_FUN = (1 :: Int)
 130 pREC_CON = (2 :: Int)
 131
 132 maybeParen :: Bool -> Doc -> Doc
 133 maybeParen True  p = parens p
 134 maybeParen False p = p
 135
 136 -- printing works more-or-less as for Types
 137
 138 pprHsType, pprParendHsType :: (Outputable name) => PprStyle -> HsType name -> Doc
 139
 140 pprHsType sty ty       = ppr_mono_ty sty pREC_TOP ty
 141 pprParendHsType sty ty = ppr_mono_ty sty pREC_CON ty
 142
 143 ppr_mono_ty sty ctxt_prec (HsPreForAllTy ctxt ty)     = ppr_forall sty ctxt_prec [] ctxt ty
 144 ppr_mono_ty sty ctxt_prec (HsForAllTy tvs ctxt ty)    = ppr_forall sty ctxt_prec tvs ctxt ty
 145
 146 ppr_mono_ty sty ctxt_prec (MonoTyVar name) = ppr sty name
 147
 148 ppr_mono_ty sty ctxt_prec (MonoFunTy ty1 ty2)
 149   = let p1 = ppr_mono_ty sty pREC_FUN ty1
 150         p2 = ppr_mono_ty sty pREC_TOP ty2
 151     in
 152     maybeParen (ctxt_prec >= pREC_FUN)
 153                (sep [p1, (<>) (ptext SLIT("-> ")) p2])
 154
 155 ppr_mono_ty sty ctxt_prec (MonoTupleTy _ tys)
 156  = parens (sep (punctuate comma (map (ppr sty) tys)))
 157
 158 ppr_mono_ty sty ctxt_prec (MonoListTy _ ty)
 159  = brackets (ppr_mono_ty sty pREC_TOP ty)
 160
 161 ppr_mono_ty sty ctxt_prec (MonoTyApp fun_ty arg_ty)
 162   = maybeParen (ctxt_prec >= pREC_CON)
 163                (hsep [ppr_mono_ty sty pREC_FUN fun_ty, ppr_mono_ty sty pREC_CON arg_ty])
 164
 165 ppr_mono_ty sty ctxt_prec (MonoDictTy clas ty)
 166   = hsep [ppr sty clas, ppr_mono_ty sty pREC_CON ty]
 167 \end{code}
 168
 169
 170 %************************************************************************
 171 %*                                                                      *
 172 \subsection{Comparison}
 173 %*                                                                      *
 174 %************************************************************************
 175
 176 We do define a specialised equality for these \tr{*Type} types; used
 177 in checking interfaces.  Most any other use is likely to be {\em
 178 wrong}, so be careful!
 179
 180 \begin{code}
 181 cmpHsTyVar :: (a -> a -> TAG_) -> HsTyVar a -> HsTyVar a -> TAG_
 182 --cmpHsType :: (a -> a -> TAG_) -> HsType a -> HsType a -> TAG_
 183 --cmpContext  :: (a -> a -> TAG_) -> Context  a -> Context  a -> TAG_
 184
 185 cmpHsTyVar cmp (UserTyVar v1)    (UserTyVar v2)    = v1 `cmp` v2
 186 cmpHsTyVar cmp (IfaceTyVar v1 _) (IfaceTyVar v2 _) = v1 `cmp` v2
 187 cmpHsTyVar cmp (UserTyVar _)     other             = LT_
 188 cmpHsTyVar cmp other1            other2            = GT_
 189
 190
 191 -- We assume that HsPreForAllTys have been smashed by now.
 192 # ifdef DEBUG
 193 cmpHsType _ (HsPreForAllTy _ _) _ = panic# "cmpHsType:HsPreForAllTy:1st arg"
 194 cmpHsType _ _ (HsPreForAllTy _ _) = panic# "cmpHsType:HsPreForAllTy:2nd arg"
 195 # endif
 196
 197 cmpHsType cmp (HsForAllTy tvs1 c1 t1) (HsForAllTy tvs2 c2 t2)
 198   = cmpList (cmpHsTyVar cmp) tvs1 tvs2  `thenCmp`
 199     cmpContext cmp c1 c2                `thenCmp`
 200     cmpHsType cmp t1 t2
 201
 202 cmpHsType cmp (MonoTyVar n1) (MonoTyVar n2)
 203   = cmp n1 n2
 204
 205 cmpHsType cmp (MonoTupleTy _ tys1) (MonoTupleTy _ tys2)
 206   = cmpList (cmpHsType cmp) tys1 tys2
 207 cmpHsType cmp (MonoListTy _ ty1) (MonoListTy _ ty2)
 208   = cmpHsType cmp ty1 ty2
 209
 210 cmpHsType cmp (MonoTyApp fun_ty1 arg_ty1) (MonoTyApp fun_ty2 arg_ty2)
 211   = cmpHsType cmp fun_ty1 fun_ty2 `thenCmp` cmpHsType cmp arg_ty1 arg_ty2
 212
 213 cmpHsType cmp (MonoFunTy a1 b1) (MonoFunTy a2 b2)
 214   = cmpHsType cmp a1 a2 `thenCmp` cmpHsType cmp b1 b2
 215
 216 cmpHsType cmp (MonoDictTy c1 ty1)   (MonoDictTy c2 ty2)
 217   = cmp c1 c2 `thenCmp` cmpHsType cmp ty1 ty2
 218
 219 cmpHsType cmp ty1 ty2 -- tags must be different
 220   = let tag1 = tag ty1
 221         tag2 = tag ty2
 222     in
 223     if tag1 _LT_ tag2 then LT_ else GT_
 224   where
 225     tag (MonoTyVar n1)          = (ILIT(1) :: FAST_INT)
 226     tag (MonoTupleTy _ tys1)    = ILIT(2)
 227     tag (MonoListTy _ ty1)      = ILIT(3)
 228     tag (MonoTyApp tc1 tys1)    = ILIT(4)
 229     tag (MonoFunTy a1 b1)       = ILIT(5)
 230     tag (MonoDictTy c1 ty1)     = ILIT(7)
 231     tag (HsForAllTy _ _ _)      = ILIT(8)
 232     tag (HsPreForAllTy _ _)     = ILIT(9)
 233
 234 -------------------
 235 cmpContext cmp a b
 236   = cmpList cmp_ctxt a b
 237   where
 238     cmp_ctxt (c1, ty1) (c2, ty2)
 239       = cmp c1 c2 `thenCmp` cmpHsType cmp ty1 ty2
 240 \end{code}