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         PolyType(..), MonoType(..),
  15         Context(..), ClassAssertion(..)
  16
  17 #ifdef COMPILING_GHC
  18         , pprParendMonoType, pprContext
  19         , extractMonoTyNames, extractCtxtTyNames
  20         , cmpPolyType, cmpMonoType, cmpContext
  21 #endif
  22     ) where
  23
  24 #ifdef COMPILING_GHC
  25 import Ubiq
  26
  27 import Outputable       ( interppSP, ifnotPprForUser )
  28 import Pretty
  29 import Type             ( Kind )
  30 import Util             ( thenCmp, cmpList, isIn, panic# )
  31
  32 #endif {- COMPILING_GHC -}
  33 \end{code}
  34
  35 This is the syntax for types as seen in type signatures.
  36
  37 \begin{code}
  38 data PolyType name
  39   = HsPreForAllTy       (Context name)
  40                         (MonoType name)
  41
  42         -- The renamer turns HsPreForAllTys into HsForAllTys when they
  43         -- occur in signatures, to make the binding of variables
  44         -- explicit.  This distinction is made visible for
  45         -- non-COMPILING_GHC code, because you probably want to do the
  46         -- same thing.
  47
  48   | HsForAllTy          [name]
  49                         (Context name)
  50                         (MonoType name)
  51
  52 type Context name = [ClassAssertion name]
  53
  54 type ClassAssertion name = (name, name)
  55
  56 data MonoType name
  57   = MonoTyVar           name            -- Type variable
  58
  59   | MonoTyApp           name            -- Type constructor or variable
  60                         [MonoType name]
  61
  62     -- We *could* have a "MonoTyCon name" equiv to "MonoTyApp name []"
  63     -- (for efficiency, what?)  WDP 96/02/18
  64
  65   | MonoFunTy           (MonoType name) -- function type
  66                         (MonoType name)
  67
  68   | MonoListTy          (MonoType name) -- list type
  69   | MonoTupleTy         [MonoType name] -- tuple type (length gives arity)
  70
  71 #ifdef COMPILING_GHC
  72   -- these next two are only used in unfoldings in interfaces
  73   | MonoDictTy          name    -- Class
  74                         (MonoType name)
  75
  76   | MonoForAllTy        [(name, Kind)]
  77                         (MonoType name)
  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 #endif {- COMPILING_GHC -}
  83 \end{code}
  84
  85 This is used in various places:
  86 \begin{code}
  87 #ifdef COMPILING_GHC
  88 pprContext :: (Outputable name) => PprStyle -> (Context name) -> Pretty
  89
  90 pprContext sty []           = ppNil
  91 pprContext sty [(clas, ty)] = ppCat [ppr sty clas, ppr sty ty, ppStr "=>"]
  92 pprContext sty context
  93   = ppBesides [ppLparen,
  94            ppInterleave ppComma (map pp_assert context),
  95            ppRparen, ppStr " =>"]
  96   where
  97     pp_assert (clas, ty)
  98       = ppCat [ppr sty clas, ppr sty ty]
  99 \end{code}
 100
 101 \begin{code}
 102 instance (Outputable name) => Outputable (PolyType name) where
 103     ppr sty (HsPreForAllTy ctxt ty)
 104       = print_it sty ppNil ctxt ty
 105     ppr sty (HsForAllTy tvs ctxt ty)
 106       = print_it sty
 107             (ppBesides [ppStr "_forall_ ", interppSP sty tvs, ppStr " => "])
 108             ctxt ty
 109
 110 print_it sty pp_forall ctxt ty
 111   = ppCat [ifnotPprForUser sty pp_forall, -- print foralls unless PprForUser
 112            pprContext sty ctxt, ppr sty ty]
 113
 114 instance (Outputable name) => Outputable (MonoType name) where
 115     ppr = pprMonoType
 116
 117 pREC_TOP = (0 :: Int)
 118 pREC_FUN = (1 :: Int)
 119 pREC_CON = (2 :: Int)
 120
 121 -- printing works more-or-less as for Types
 122
 123 pprMonoType, pprParendMonoType :: (Outputable name) => PprStyle -> MonoType name -> Pretty
 124
 125 pprMonoType sty ty       = ppr_mono_ty sty pREC_TOP ty
 126 pprParendMonoType sty ty = ppr_mono_ty sty pREC_CON ty
 127
 128 ppr_mono_ty sty ctxt_prec (MonoTyVar name) = ppr sty name
 129
 130 ppr_mono_ty sty ctxt_prec (MonoFunTy ty1 ty2)
 131   = let p1 = ppr_mono_ty sty pREC_FUN ty1
 132         p2 = ppr_mono_ty sty pREC_TOP ty2
 133     in
 134     if ctxt_prec < pREC_FUN then -- no parens needed
 135         ppSep [p1, ppBeside (ppStr "-> ") p2]
 136     else
 137         ppSep [ppBeside ppLparen p1, ppBesides [ppStr "-> ", p2, ppRparen]]
 138
 139 ppr_mono_ty sty ctxt_prec (MonoTupleTy tys)
 140  = ppBesides [ppLparen, ppInterleave ppComma (map (ppr sty) tys), ppRparen]
 141
 142 ppr_mono_ty sty ctxt_prec (MonoListTy ty)
 143  = ppBesides [ppLbrack, ppr_mono_ty sty pREC_TOP ty, ppRbrack]
 144
 145 ppr_mono_ty sty ctxt_prec (MonoTyApp tycon tys)
 146   = let pp_tycon = ppr sty tycon in
 147     if null tys then
 148         pp_tycon
 149     else if ctxt_prec < pREC_CON then -- no parens needed
 150         ppCat [pp_tycon, ppInterleave ppNil (map (ppr_mono_ty sty pREC_CON) tys)]
 151     else
 152         ppBesides [ ppLparen, pp_tycon, ppSP,
 153                ppInterleave ppNil (map (ppr_mono_ty sty pREC_CON) tys), ppRparen ]
 154
 155 -- unfoldings only
 156 ppr_mono_ty sty ctxt_prec (MonoDictTy clas ty)
 157   = ppBesides [ppStr "{{", ppr sty clas, ppSP, ppr_mono_ty sty ctxt_prec ty, ppStr "}}"]
 158
 159 #endif {- COMPILING_GHC -}
 160 \end{code}
 161
 162 \begin{code}
 163 #ifdef COMPILING_GHC
 164
 165 extractCtxtTyNames :: Eq name => Context  name -> [name]
 166 extractMonoTyNames :: Eq name => (name -> Bool) -> MonoType name -> [name]
 167
 168 extractCtxtTyNames ctxt
 169   = foldr get [] ctxt
 170   where
 171     get (clas, tv) acc
 172       | tv `is_elem` acc = acc
 173       | otherwise        = tv : acc
 174
 175     is_elem = isIn "extractCtxtTyNames"
 176
 177 extractMonoTyNames is_tyvar_name ty
 178   = get ty []
 179   where
 180     get (MonoTyApp con tys) acc = let
 181                                      rest = foldr get acc tys
 182                                   in
 183                                   if is_tyvar_name con && not (con `is_elem` rest)
 184                                   then con : rest
 185                                   else rest
 186     get (MonoListTy ty)     acc = get ty acc
 187     get (MonoFunTy ty1 ty2) acc = get ty1 (get ty2 acc)
 188     get (MonoDictTy _ ty)   acc = get ty acc
 189     get (MonoTupleTy tys)   acc = foldr get acc tys
 190     get (MonoTyVar tv)      acc
 191       | tv `is_elem` acc        = acc
 192       | otherwise               = tv : acc
 193
 194     is_elem = isIn "extractMonoTyNames"
 195
 196 #endif {- COMPILING_GHC -}
 197 \end{code}
 198
 199 We do define a specialised equality for these \tr{*Type} types; used
 200 in checking interfaces.  Most any other use is likely to be {\em
 201 wrong}, so be careful!
 202 \begin{code}
 203 #ifdef COMPILING_GHC
 204
 205 cmpPolyType :: (a -> a -> TAG_) -> PolyType a -> PolyType a -> TAG_
 206 cmpMonoType :: (a -> a -> TAG_) -> MonoType a -> MonoType a -> TAG_
 207 cmpContext  :: (a -> a -> TAG_) -> Context  a -> Context  a -> TAG_
 208
 209 -- We assume that HsPreForAllTys have been smashed by now.
 210 # ifdef DEBUG
 211 cmpPolyType _ (HsPreForAllTy _ _) _ = panic# "cmpPolyType:HsPreForAllTy:1st arg"
 212 cmpPolyType _ _ (HsPreForAllTy _ _) = panic# "cmpPolyType:HsPreForAllTy:2nd arg"
 213 # endif
 214
 215 cmpPolyType cmp (HsForAllTy tvs1 c1 t1) (HsForAllTy tvs2 c2 t2)
 216   = thenCmp (cmp_tvs tvs1 tvs2)
 217             (thenCmp (cmpContext cmp c1 c2) (cmpMonoType cmp t1 t2))
 218   where
 219     cmp_tvs [] [] = EQ_
 220     cmp_tvs [] _  = LT_
 221     cmp_tvs _  [] = GT_
 222     cmp_tvs (a:as) (b:bs)
 223       = thenCmp (cmp a b) (cmp_tvs as bs)
 224     cmp_tvs _ _ = panic# "cmp_tvs"
 225
 226 -----------
 227 cmpMonoType cmp (MonoTyVar n1) (MonoTyVar n2)
 228   = cmp n1 n2
 229
 230 cmpMonoType cmp (MonoTupleTy tys1) (MonoTupleTy tys2)
 231   = cmpList (cmpMonoType cmp) tys1 tys2
 232 cmpMonoType cmp (MonoListTy ty1) (MonoListTy ty2)
 233   = cmpMonoType cmp ty1 ty2
 234
 235 cmpMonoType cmp (MonoTyApp tc1 tys1) (MonoTyApp tc2 tys2)
 236   = thenCmp (cmp tc1 tc2) (cmpList (cmpMonoType cmp) tys1 tys2)
 237
 238 cmpMonoType cmp (MonoFunTy a1 b1) (MonoFunTy a2 b2)
 239   = thenCmp (cmpMonoType cmp a1 a2) (cmpMonoType cmp b1 b2)
 240
 241 cmpMonoType cmp (MonoDictTy c1 ty1)   (MonoDictTy c2 ty2)
 242   = thenCmp (cmp c1 c2) (cmpMonoType cmp ty1 ty2)
 243
 244 cmpMonoType cmp ty1 ty2 -- tags must be different
 245   = let tag1 = tag ty1
 246         tag2 = tag ty2
 247     in
 248     if tag1 _LT_ tag2 then LT_ else GT_
 249   where
 250     tag (MonoTyVar n1)          = (ILIT(1) :: FAST_INT)
 251     tag (MonoTupleTy tys1)      = ILIT(2)
 252     tag (MonoListTy ty1)        = ILIT(3)
 253     tag (MonoTyApp tc1 tys1)    = ILIT(4)
 254     tag (MonoFunTy a1 b1)       = ILIT(5)
 255     tag (MonoDictTy c1 ty1)     = ILIT(7)
 256
 257 -------------------
 258 cmpContext cmp a b
 259   = cmpList cmp_ctxt a b
 260   where
 261     cmp_ctxt (c1, tv1) (c2, tv2)
 262       = thenCmp (cmp c1 c2) (cmp tv1 tv2)
 263
 264 #endif {- COMPILING_GHC -}
 265 \end{code}