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