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