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