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