ghc/compiler/abstractSyn/HsTypes.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   3 %
   4 \section[HsTypes]{Abstract syntax: user-defined types}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module HsTypes (
  10         PolyType(..), MonoType(..),
  11         ClassAssertion(..), Context(..),
  12
  13         ProtoNameContext(..),
  14         ProtoNameMonoType(..),
  15         ProtoNamePolyType(..),
  16         RenamedContext(..),
  17         RenamedMonoType(..),
  18         RenamedPolyType(..),
  19
  20         cmpPolyType, cmpMonoType, cmpList,
  21         eqMonoType,
  22
  23         pprContext, pprParendMonoType
  24
  25     ) where
  26
  27 import ProtoName
  28 import Name             ( Name )
  29 import Unique           ( Unique )
  30 import Outputable
  31 import Pretty
  32 import Util
  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   = UnoverloadedTy      (MonoType name) -- equiv to having a [] context
  40
  41   | OverloadedTy        (Context name)  -- not supposed to be []
  42                         (MonoType name)
  43
  44   -- this next one is only used in unfoldings in interfaces
  45   | ForAllTy            [name]
  46                         (MonoType name)
  47
  48 type Context name = [ClassAssertion name]
  49
  50 type ClassAssertion name = (name, name)
  51
  52 type ProtoNamePolyType = PolyType ProtoName
  53 type RenamedPolyType   = PolyType Name
  54
  55 type ProtoNameContext  = Context  ProtoName
  56 type RenamedContext    = Context  Name
  57
  58 data MonoType name
  59   = MonoTyVar           name            -- Type variable
  60   | MonoTyCon           name            -- Type constructor
  61                         [MonoType name]
  62   | FunMonoTy           (MonoType name) -- function type
  63                         (MonoType name)
  64   | ListMonoTy          (MonoType name) -- list type
  65   | TupleMonoTy         [PolyType name] -- tuple type (length gives arity)
  66         -- *** NOTA BENE *** The tuple type takes *Poly*Type
  67         -- arguments, because these *do* arise in pragmatic info
  68         -- in interfaces (mostly to do with dictionaries).  It just
  69         -- so happens that this won't happen for lists, etc.,
  70         -- (as far as I know).
  71         -- We might want to be less hacky about this in future. (ToDo)
  72         -- [WDP]
  73
  74   -- these next two are only used in unfoldings in interfaces
  75   | MonoTyVarTemplate   name
  76   | MonoDict            name    -- Class
  77                         (MonoType name)
  78
  79 #ifdef DPH
  80   | MonoTyProc          [MonoType name]
  81                         (MonoType name) -- Processor
  82   | MonoTyPod           (MonoType name) -- Pod
  83 #endif {- Data Parallel Haskell -}
  84
  85 type ProtoNameMonoType = MonoType ProtoName
  86 type RenamedMonoType   = MonoType Name
  87 \end{code}
  88
  89 We do define a specialised equality for these \tr{*Type} types; used
  90 in checking interfaces.  Most any other use is likely to be {\em
  91 wrong}, so be careful!
  92 \begin{code}
  93 cmpPolyType :: (a -> a -> TAG_) -> PolyType a -> PolyType a -> TAG_
  94 cmpMonoType :: (a -> a -> TAG_) -> MonoType a -> MonoType a -> TAG_
  95 cmpContext  :: (a -> a -> TAG_) -> Context  a -> Context  a -> TAG_
  96 cmpList     :: (a -> a -> TAG_) -> [a]        -> [a]        -> TAG_
  97
  98 cmpPolyType cmp (UnoverloadedTy  t1) (UnoverloadedTy  t2)
  99   = cmpMonoType cmp t1 t2
 100 cmpPolyType cmp (OverloadedTy c1 t1) (OverloadedTy c2 t2)
 101   = case cmpContext cmp c1 c2 of { EQ_ -> cmpMonoType cmp t1 t2; xxx -> xxx }
 102
 103 cmpPolyType cmp (ForAllTy tvs1 t1) (ForAllTy tvs2 t2)
 104   = case cmp_tvs tvs1 tvs2 of { EQ_ -> cmpMonoType cmp t1 t2; xxx -> xxx }
 105   where
 106     cmp_tvs [] [] = EQ_
 107     cmp_tvs [] _  = LT_
 108     cmp_tvs _  [] = GT_
 109     cmp_tvs (a:as) (b:bs)
 110       = case cmp a b of { EQ_ -> cmp_tvs as bs; xxx -> xxx }
 111     cmp_tvs _ _ = case (panic "cmp_tvs") of { v -> cmp_tvs v v } -- BUG avoidance
 112
 113 cmpPolyType cmp ty1 ty2 -- tags must be different
 114   = let tag1 = tag ty1
 115         tag2 = tag ty2
 116     in
 117     if tag1 _LT_ tag2 then LT_ else GT_
 118   where
 119     tag (UnoverloadedTy _) = (ILIT(1) :: FAST_INT)
 120     tag (OverloadedTy _ _) = ILIT(2)
 121     tag (ForAllTy _ _)     = ILIT(3)
 122
 123 -----------
 124 cmpMonoType cmp (MonoTyVar n1) (MonoTyVar n2)
 125   = cmp n1 n2
 126
 127 cmpMonoType cmp (TupleMonoTy tys1) (TupleMonoTy tys2)
 128   = cmpList (cmpPolyType cmp) tys1 tys2
 129 cmpMonoType cmp (ListMonoTy ty1) (ListMonoTy ty2)
 130   = cmpMonoType cmp ty1 ty2
 131
 132 cmpMonoType cmp (MonoTyCon tc1 tys1) (MonoTyCon tc2 tys2)
 133   = case cmp tc1 tc2 of { EQ_ -> cmpList (cmpMonoType cmp) tys1 tys2; xxx -> xxx }
 134
 135 cmpMonoType cmp (FunMonoTy a1 b1) (FunMonoTy a2 b2)
 136   = case cmpMonoType cmp a1 a2 of { EQ_ -> cmpMonoType cmp b1 b2; xxx -> xxx }
 137
 138 cmpMonoType cmp (MonoTyVarTemplate n1) (MonoTyVarTemplate n2)
 139   = cmp n1 n2
 140 cmpMonoType cmp (MonoDict c1 ty1)   (MonoDict c2 ty2)
 141   = case cmp c1 c2 of { EQ_ -> cmpMonoType cmp ty1 ty2; xxx -> xxx }
 142
 143 #ifdef DPH
 144 cmpMonoType cmp (MonoTyProc tys1 ty1) (MonoTyProc tys2 ty2)
 145   = case cmpList (cmpMonoType cmp) tys1 tys2 of { EQ_ -> cmpMonoType cmp ty1 ty2; xxx -> xxx }
 146 cmpMonoType cmp (MonoTyPod ty1)  (MonoTyPod ty2) = cmpMonoType cmp ty1 ty2
 147 #endif {- Data Parallel Haskell -}
 148
 149 cmpMonoType cmp ty1 ty2 -- tags must be different
 150   = let tag1 = tag ty1
 151         tag2 = tag ty2
 152     in
 153     if tag1 _LT_ tag2 then LT_ else GT_
 154   where
 155     tag (MonoTyVar n1)          = (ILIT(1) :: FAST_INT)
 156     tag (TupleMonoTy tys1)      = ILIT(2)
 157     tag (ListMonoTy ty1)        = ILIT(3)
 158     tag (MonoTyCon tc1 tys1)    = ILIT(4)
 159     tag (FunMonoTy a1 b1)       = ILIT(5)
 160     tag (MonoTyVarTemplate n1)  = ILIT(6)
 161     tag (MonoDict c1 ty1)       = ILIT(7)
 162 #ifdef DPH
 163     tag (MonoTyProc tys1 ty1)   = ILIT(8)
 164     tag (MonoTyPod ty1)         = ILIT(9)
 165 #endif {- Data Parallel Haskell -}
 166
 167 -------------------
 168 cmpContext cmp a b
 169   = cmpList cmp_ctxt a b
 170   where
 171     cmp_ctxt (c1, tv1) (c2, tv2)
 172       = case cmp c1 c2 of { EQ_ -> cmp tv1 tv2; xxx -> xxx }
 173
 174 -------------------
 175 cmpList cmp []     [] = EQ_
 176 cmpList cmp []     _  = LT_
 177 cmpList cmp _      [] = GT_
 178 cmpList cmp (a:as) (b:bs)
 179   = case cmp a b of { EQ_ -> cmpList cmp as bs; xxx -> xxx }
 180
 181 cmpList cmp _ _
 182   = case (panic "cmpList (HsTypes)") of { l -> cmpList cmp l l } -- BUG avoidance
 183 \end{code}
 184
 185 \begin{code}
 186 eqMonoType :: ProtoNameMonoType -> ProtoNameMonoType -> Bool
 187
 188 eqMonoType a b = case (cmpMonoType cmpProtoName a b) of { EQ_ -> True; _ -> False }
 189 \end{code}
 190
 191 This is used in various places:
 192 \begin{code}
 193 pprContext :: (Outputable name) => PprStyle -> (Context name) -> Pretty
 194
 195 pprContext sty []           = ppNil
 196 pprContext sty [(clas, ty)] = ppCat [ppr sty clas, ppr sty ty, ppStr "=>"]
 197 pprContext sty context
 198   = ppBesides [ppLparen,
 199            ppInterleave ppComma (map pp_assert context),
 200            ppRparen, ppStr " =>"]
 201   where
 202     pp_assert (clas, ty)
 203       = ppCat [ppr sty clas, ppr sty ty]
 204 \end{code}
 205
 206 \begin{code}
 207 instance (Outputable name) => Outputable (PolyType name) where
 208     ppr sty (UnoverloadedTy ty) = ppr sty ty
 209     ppr sty (OverloadedTy ctxt ty)
 210      = ppCat [pprContext sty ctxt, ppr sty ty]
 211     ppr sty (ForAllTy tvs ty)
 212      = ppBesides [ppStr "_forall_ ", interppSP sty tvs, ppStr " => ", ppr sty ty]
 213
 214 instance (Outputable name) => Outputable (MonoType name) where
 215     ppr = pprMonoType
 216
 217 pREC_TOP = (0 :: Int)
 218 pREC_FUN = (1 :: Int)
 219 pREC_CON = (2 :: Int)
 220
 221 -- printing works more-or-less as for UniTypes (in UniTyFuns)
 222
 223 pprMonoType, pprParendMonoType :: (Outputable name) => PprStyle -> MonoType name -> Pretty
 224
 225 pprMonoType sty ty       = ppr_mono_ty sty pREC_TOP ty
 226 pprParendMonoType sty ty = ppr_mono_ty sty pREC_CON ty
 227
 228 ppr_mono_ty sty ctxt_prec (MonoTyVar name) = ppr sty name
 229
 230 ppr_mono_ty sty ctxt_prec (FunMonoTy ty1 ty2)
 231   = let p1 = ppr_mono_ty sty pREC_FUN ty1
 232         p2 = ppr_mono_ty sty pREC_TOP ty2
 233     in
 234     if ctxt_prec < pREC_FUN then -- no parens needed
 235         ppSep [p1, ppBeside (ppStr "-> ") p2]
 236     else
 237         ppSep [ppBeside ppLparen p1, ppBesides [ppStr "-> ", p2, ppRparen]]
 238
 239 ppr_mono_ty sty ctxt_prec (TupleMonoTy tys)
 240  = ppBesides [ppLparen, ppInterleave ppComma (map (ppr sty) tys), ppRparen]
 241
 242 ppr_mono_ty sty ctxt_prec (ListMonoTy ty)
 243  = ppBesides [ppLbrack, ppr_mono_ty sty pREC_TOP ty, ppRbrack]
 244
 245 ppr_mono_ty sty ctxt_prec (MonoTyCon tycon tys)
 246   = let pp_tycon = ppr sty tycon in
 247     if null tys then
 248         pp_tycon
 249     else if ctxt_prec < pREC_CON then -- no parens needed
 250         ppCat [pp_tycon, ppInterleave ppNil (map (ppr_mono_ty sty pREC_CON) tys)]
 251     else
 252         ppBesides [ ppLparen, pp_tycon, ppSP,
 253                ppInterleave ppNil (map (ppr_mono_ty sty pREC_CON) tys), ppRparen ]
 254
 255 -- unfoldings only
 256 ppr_mono_ty sty ctxt_prec (MonoTyVarTemplate tv) = ppr sty tv
 257
 258 ppr_mono_ty sty ctxt_prec (MonoDict clas ty)
 259   = ppBesides [ppStr "{{", ppr sty clas, ppSP, ppr_mono_ty sty ctxt_prec ty, ppStr "}}"]
 260
 261 #ifdef DPH
 262 ppr_mono_ty sty ctxt_prec (MonoTyProc tys ty)
 263      = ppBesides [ppStr "(|",
 264                   ppInterleave ppComma (map (ppr_mono_ty sty pREC_TOP) tys),
 265                   ppSemi,
 266                   ppr_mono_ty sty pREC_TOP ty,
 267                   ppStr "|)"]
 268
 269 ppr_mono_ty sty ctxt_prec (MonoTyPod ty)
 270      = ppBesides [ppStr "<<", ppr_mono_ty sty pREC_TOP ty ,ppStr ">>"]
 271
 272 #endif {- Data Parallel Haskell -}
 273 \end{code}