ghc/compiler/hsSyn/HsDecls.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[HsDecls]{Abstract syntax: global declarations}
   5
   6 Definitions for: @FixityDecl@, @TyDecl@ and @ConDecl@, @ClassDecl@,
   7 @InstDecl@, @DefaultDecl@.
   8
   9 \begin{code}
  10 #include "HsVersions.h"
  11
  12 module HsDecls where
  13
  14 import Ubiq
  15
  16 -- friends:
  17 import HsLoop           ( nullMonoBinds, MonoBinds, Sig )
  18 import HsPragmas        ( DataPragmas, ClassPragmas,
  19                           InstancePragmas, ClassOpPragmas )
  20 import HsTypes
  21
  22 -- others:
  23 import Outputable
  24 import Pretty
  25 import SrcLoc           ( SrcLoc )
  26 import Util             ( cmpList, panic#{-ToDo:rm eventually-} )
  27 \end{code}
  28
  29 %************************************************************************
  30 %*                                                                      *
  31 \subsection[FixityDecl]{A fixity declaration}
  32 %*                                                                      *
  33 %************************************************************************
  34
  35 \begin{code}
  36 data FixityDecl name
  37   = InfixL      name Int
  38   | InfixR      name Int
  39   | InfixN      name Int
  40 \end{code}
  41
  42 \begin{code}
  43 instance (NamedThing name, Outputable name)
  44      => Outputable (FixityDecl name) where
  45     ppr sty (InfixL var prec)   = print_it sty "l" prec var
  46     ppr sty (InfixR var prec)   = print_it sty "r" prec var
  47     ppr sty (InfixN var prec)   = print_it sty ""  prec var
  48
  49 print_it sty suff prec var
  50   = ppBesides [ppStr "infix", ppStr suff, ppSP, ppInt prec, ppSP, pprOp sty var]
  51 \end{code}
  52
  53 %************************************************************************
  54 %*                                                                      *
  55 \subsection[TyDecl]{@data@, @newtype@ or @type@ (synonym) type declaration}
  56 %*                                                                      *
  57 %************************************************************************
  58
  59 \begin{code}
  60 data TyDecl name
  61   = TyData      (Context name)  -- context
  62                 name            -- type constructor
  63                 [name]          -- type variables
  64                 [ConDecl name]  -- data constructors (empty if abstract)
  65                 (Maybe [name])  -- derivings; Nothing => not specified
  66                                 -- (i.e., derive default); Just [] => derive
  67                                 -- *nothing*; Just <list> => as you would
  68                                 -- expect...
  69                 (DataPragmas name)
  70                 SrcLoc
  71
  72   | TyNew       (Context name)  -- context
  73                 name            -- type constructor
  74                 [name]          -- type variables
  75                 [ConDecl name]  -- data constructor (empty if abstract)
  76                 (Maybe [name])  -- derivings; as above
  77                 (DataPragmas name)
  78                 SrcLoc
  79
  80   | TySynonym   name            -- type constructor
  81                 [name]          -- type variables
  82                 (MonoType name) -- synonym expansion
  83                 SrcLoc
  84
  85 \end{code}
  86
  87 \begin{code}
  88 instance (NamedThing name, Outputable name)
  89               => Outputable (TyDecl name) where
  90
  91     ppr sty (TySynonym tycon tyvars mono_ty src_loc)
  92       = ppHang (pp_decl_head sty SLIT("type") ppNil tycon tyvars)
  93              4 (ppCat [ppEquals, ppr sty mono_ty])
  94
  95     ppr sty (TyData context tycon tyvars condecls derivings pragmas src_loc)
  96       = pp_tydecl sty
  97                   (pp_decl_head sty SLIT("data") (pprContext sty context) tycon tyvars)
  98                   (pp_condecls sty condecls)
  99                   derivings
 100
 101     ppr sty (TyNew context tycon tyvars condecl derivings pragmas src_loc)
 102       = pp_tydecl sty
 103                   (pp_decl_head sty SLIT("newtype") (pprContext sty context) tycon tyvars)
 104                   (pp_condecls sty condecl)
 105                   derivings
 106
 107 pp_decl_head sty str pp_context tycon tyvars
 108   = ppCat [ppPStr str, pp_context, ppr sty tycon, interppSP sty tyvars]
 109
 110 pp_condecls sty [] = ppNil -- abstract datatype
 111 pp_condecls sty (c:cs)
 112   = ppSep (ppBeside (ppStr "= ") (ppr sty c)
 113            : map (\ x -> ppBeside (ppStr "| ") (ppr sty x)) cs)
 114
 115 pp_tydecl sty pp_head pp_decl_rhs derivings
 116   = ppHang pp_head 4 (ppSep [
 117         pp_decl_rhs,
 118         case derivings of
 119           Nothing -> ppNil
 120           Just ds -> ppBeside (ppPStr SLIT("deriving "))
 121                         (ppParens (ppInterleave ppComma (map (ppr sty) ds)))])
 122 \end{code}
 123
 124 A type for recording what types a datatype should be specialised to.
 125 It's called a ``Sig'' because it's sort of like a ``type signature''
 126 for an datatype declaration.
 127
 128 \begin{code}
 129 data SpecDataSig name
 130   = SpecDataSig name            -- tycon to specialise
 131                 (MonoType name)
 132                 SrcLoc
 133
 134 instance (NamedThing name, Outputable name)
 135               => Outputable (SpecDataSig name) where
 136
 137     ppr sty (SpecDataSig tycon ty _)
 138       = ppCat [ppStr "{-# SPECIALIZE data", ppr sty ty, ppStr "#-}"]
 139 \end{code}
 140
 141 %************************************************************************
 142 %*                                                                      *
 143 \subsection[ConDecl]{A data-constructor declaration}
 144 %*                                                                      *
 145 %************************************************************************
 146
 147 \begin{code}
 148 data ConDecl name
 149   = ConDecl     name            -- prefix-style con decl
 150                 [BangType name]
 151                 SrcLoc
 152
 153   | ConOpDecl   (BangType name) -- infix-style con decl
 154                 name
 155                 (BangType name)
 156                 SrcLoc
 157
 158   | RecConDecl  name
 159                 [([name], BangType name)]       -- list of "fields"
 160                 SrcLoc
 161
 162   | NewConDecl  name            -- newtype con decl
 163                 (MonoType name)
 164                 SrcLoc
 165
 166 data BangType name
 167   = Banged   (MonoType name)
 168   | Unbanged (MonoType name)
 169 \end{code}
 170
 171 \begin{code}
 172 instance (NamedThing name, Outputable name) => Outputable (ConDecl name) where
 173
 174     ppr sty (ConDecl con tys _)
 175       = ppCat [pprNonOp sty con, ppInterleave ppNil (map (ppr_bang sty) tys)]
 176     ppr sty (ConOpDecl ty1 op ty2 _)
 177       = ppCat [ppr_bang sty ty1, pprOp sty op, ppr_bang sty ty2]
 178     ppr sty (NewConDecl con ty _)
 179       = ppCat [pprNonOp sty con, pprParendMonoType sty ty]
 180     ppr sty (RecConDecl con fields _)
 181       = ppCat [pprNonOp sty con, ppChar '{',
 182                ppInterleave pp'SP (map pp_field fields), ppChar '}']
 183       where
 184         pp_field (n, ty) = ppCat [ppr sty n, ppPStr SLIT("::"), ppr_bang sty ty]
 185
 186 ppr_bang sty (Banged   ty) = ppBeside (ppChar '!') (pprParendMonoType sty ty)
 187 ppr_bang sty (Unbanged ty) = pprParendMonoType sty ty
 188 \end{code}
 189
 190 %************************************************************************
 191 %*                                                                      *
 192 \subsection[ClassDecl]{A class declaration}
 193 %*                                                                      *
 194 %************************************************************************
 195
 196 \begin{code}
 197 data ClassDecl tyvar uvar name pat
 198   = ClassDecl   (Context name)                  -- context...
 199                 name                            -- name of the class
 200                 name                            -- the class type variable
 201                 [Sig name]                      -- methods' signatures
 202                 (MonoBinds tyvar uvar name pat) -- default methods
 203                 (ClassPragmas name)
 204                 SrcLoc
 205 \end{code}
 206
 207 \begin{code}
 208 instance (NamedThing name, Outputable name, Outputable pat,
 209           Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
 210                 => Outputable (ClassDecl tyvar uvar name pat) where
 211
 212     ppr sty (ClassDecl context clas tyvar sigs methods pragmas src_loc)
 213      = let
 214            top_matter = ppCat [ppStr "class", pprContext sty context,
 215                                ppr sty clas, ppr sty tyvar]
 216        in
 217        if null sigs && nullMonoBinds methods then
 218            ppAbove top_matter (ppNest 4 (ppr sty pragmas))
 219        else
 220            ppAboves [ppCat [top_matter, ppStr "where"],
 221                      ppNest 4 (ppAboves (map (ppr sty) sigs)),
 222                      ppNest 4 (ppr sty methods),
 223                      ppNest 4 (ppr sty pragmas) ]
 224 \end{code}
 225
 226 %************************************************************************
 227 %*                                                                      *
 228 \subsection[InstDecl]{An instance declaration (also, @SpecInstSig@)}
 229 %*                                                                      *
 230 %************************************************************************
 231
 232 \begin{code}
 233 data InstDecl tyvar uvar name pat
 234   = InstDecl    name            -- Class
 235
 236                 (PolyType name) -- Context => Instance-type
 237                                 -- Using a polytype means that the renamer conveniently
 238                                 -- figures out the quantified type variables for us.
 239
 240                 (MonoBinds tyvar uvar name pat)
 241
 242                 Bool            -- True <=> This instance decl is from the
 243                                 -- module being compiled; False <=> It is from
 244                                 -- an imported interface.
 245
 246                 (Maybe Module)  -- The name of the module where the instance decl
 247                                 -- originally came from; Nothing => Prelude
 248
 249                 [Sig name]              -- actually user-supplied pragmatic info
 250                 (InstancePragmas name)  -- interface-supplied pragmatic info
 251                 SrcLoc
 252 \end{code}
 253
 254 \begin{code}
 255 instance (NamedThing name, Outputable name, Outputable pat,
 256           Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
 257               => Outputable (InstDecl tyvar uvar name pat) where
 258
 259     ppr sty (InstDecl clas ty binds local modname uprags pragmas src_loc)
 260       = let
 261             (context, inst_ty)
 262               = case ty of
 263                   HsPreForAllTy c t -> (c, t)
 264                   HsForAllTy  _ c t -> (c, t)
 265
 266             top_matter = ppCat [ppStr "instance", pprContext sty context,
 267                                 ppr sty clas, pprParendMonoType sty inst_ty]
 268         in
 269         if nullMonoBinds binds && null uprags then
 270             ppAbove top_matter (ppNest 4 (ppr sty pragmas))
 271         else
 272             ppAboves [ppCat [top_matter, ppStr "where"],
 273                       if null uprags then ppNil else ppNest 4 (ppr sty uprags),
 274                       ppNest 4 (ppr sty binds),
 275                       ppNest 4 (ppr sty pragmas) ]
 276 \end{code}
 277
 278 A type for recording what instances the user wants to specialise;
 279 called a ``Sig'' because it's sort of like a ``type signature'' for an
 280 instance.
 281 \begin{code}
 282 data SpecInstSig name
 283   = SpecInstSig  name               -- class
 284                  (MonoType name)    -- type to specialise to
 285                  SrcLoc
 286
 287 instance (NamedThing name, Outputable name)
 288               => Outputable (SpecInstSig name) where
 289
 290     ppr sty (SpecInstSig clas ty _)
 291       = ppCat [ppStr "{-# SPECIALIZE instance", ppr sty clas, ppr sty ty, ppStr "#-}"]
 292 \end{code}
 293
 294 %************************************************************************
 295 %*                                                                      *
 296 \subsection[DefaultDecl]{A @default@ declaration}
 297 %*                                                                      *
 298 %************************************************************************
 299
 300 There can only be one default declaration per module, but it is hard
 301 for the parser to check that; we pass them all through in the abstract
 302 syntax, and that restriction must be checked in the front end.
 303
 304 \begin{code}
 305 data DefaultDecl name
 306   = DefaultDecl [MonoType name]
 307                 SrcLoc
 308
 309 instance (NamedThing name, Outputable name)
 310               => Outputable (DefaultDecl name) where
 311
 312     ppr sty (DefaultDecl tys src_loc)
 313       = ppBeside (ppPStr SLIT("default ")) (ppParens (interpp'SP sty tys))
 314 \end{code}