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 HsBinds          ( HsBinds, MonoBinds, Sig, nullMonoBinds )
  18 import HsPragmas        ( DataPragmas, ClassPragmas,
  19                           InstancePragmas, ClassOpPragmas
  20                         )
  21 import HsTypes
  22 import IdInfo
  23 import SpecEnv          ( SpecEnv )
  24 import HsCore           ( UfExpr )
  25 import HsBasic          ( Fixity )
  26
  27 -- others:
  28 import Name             ( pprSym, pprNonSym, getOccName, OccName )
  29 import Outputable       ( interppSP, interpp'SP,
  30                           Outputable(..){-instance * []-}
  31                         )
  32 import Pretty
  33 import SrcLoc           ( SrcLoc )
  34 import PprStyle         ( PprStyle(..) )
  35 \end{code}
  36
  37
  38 %************************************************************************
  39 %*                                                                      *
  40 \subsection[HsDecl]{Declarations}
  41 %*                                                                      *
  42 %************************************************************************
  43
  44 \begin{code}
  45 data HsDecl tyvar uvar name pat
  46   = TyD         (TyDecl name)
  47   | ClD         (ClassDecl tyvar uvar name pat)
  48   | InstD       (InstDecl  tyvar uvar name pat)
  49   | DefD        (DefaultDecl name)
  50   | ValD        (HsBinds tyvar uvar name pat)
  51   | SigD        (IfaceSig name)
  52 \end{code}
  53
  54 \begin{code}
  55 hsDeclName (TyD (TyData _ name _ _ _ _ _))    = name
  56 hsDeclName (TyD (TyNew  _ name _ _ _ _ _))    = name
  57 hsDeclName (TyD (TySynonym name _ _ _))       = name
  58 hsDeclName (ClD (ClassDecl _ name _ _ _ _ _)) = name
  59 hsDeclName (SigD (IfaceSig name _ _ _))       = name
  60 -- Others don't make sense
  61 \end{code}
  62
  63 \begin{code}
  64 instance (NamedThing name, Outputable name, Outputable pat,
  65           Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
  66         => Outputable (HsDecl tyvar uvar name pat) where
  67
  68     ppr sty (TyD td)     = ppr sty td
  69     ppr sty (ClD cd)     = ppr sty cd
  70     ppr sty (SigD sig)   = ppr sty sig
  71     ppr sty (ValD binds) = ppr sty binds
  72     ppr sty (DefD def)   = ppr sty def
  73     ppr sty (InstD inst) = ppr sty inst
  74 \end{code}
  75
  76
  77 %************************************************************************
  78 %*                                                                      *
  79 \subsection[FixityDecl]{A fixity declaration}
  80 %*                                                                      *
  81 %************************************************************************
  82
  83 \begin{code}
  84 data FixityDecl name  = FixityDecl name Fixity SrcLoc
  85
  86 instance Outputable name => Outputable (FixityDecl name) where
  87   ppr sty (FixityDecl name fixity loc) = ppSep [ppr sty fixity, ppr sty name]
  88 \end{code}
  89
  90
  91 %************************************************************************
  92 %*                                                                      *
  93 \subsection[TyDecl]{@data@, @newtype@ or @type@ (synonym) type declaration}
  94 %*                                                                      *
  95 %************************************************************************
  96
  97 \begin{code}
  98 data TyDecl name
  99   = TyData      (Context name)  -- context
 100                 name            -- type constructor
 101                 [HsTyVar name]  -- type variables
 102                 [ConDecl name]  -- data constructors (empty if abstract)
 103                 (Maybe [name])  -- derivings; Nothing => not specified
 104                                 -- (i.e., derive default); Just [] => derive
 105                                 -- *nothing*; Just <list> => as you would
 106                                 -- expect...
 107                 (DataPragmas name)
 108                 SrcLoc
 109
 110   | TyNew       (Context name)  -- context
 111                 name            -- type constructor
 112                 [HsTyVar name]  -- type variables
 113                 (ConDecl name)  -- data constructor
 114                 (Maybe [name])  -- derivings; as above
 115                 (DataPragmas name)
 116                 SrcLoc
 117
 118   | TySynonym   name            -- type constructor
 119                 [HsTyVar name]  -- type variables
 120                 (HsType name)   -- synonym expansion
 121                 SrcLoc
 122
 123 \end{code}
 124
 125 \begin{code}
 126 instance (NamedThing name, Outputable name)
 127               => Outputable (TyDecl name) where
 128
 129     ppr sty (TySynonym tycon tyvars mono_ty src_loc)
 130       = ppHang (pp_decl_head sty SLIT("type") ppNil tycon tyvars)
 131              4 (ppr sty mono_ty)
 132
 133     ppr sty (TyData context tycon tyvars condecls derivings pragmas src_loc)
 134       = pp_tydecl sty
 135                   (pp_decl_head sty SLIT("data") (pp_context_and_arrow sty context) tycon tyvars)
 136                   (pp_condecls sty condecls)
 137                   derivings
 138
 139     ppr sty (TyNew context tycon tyvars condecl derivings pragmas src_loc)
 140       = pp_tydecl sty
 141                   (pp_decl_head sty SLIT("newtype") (pp_context_and_arrow sty context) tycon tyvars)
 142                   (ppr sty condecl)
 143                   derivings
 144
 145 pp_decl_head sty str pp_context tycon tyvars
 146   = ppCat [ppPStr str, pp_context, ppr sty (getOccName tycon),
 147            interppSP sty tyvars, ppPStr SLIT("=")]
 148
 149 pp_condecls sty [] = ppNil              -- Curious!
 150 pp_condecls sty (c:cs)
 151   = ppSep (ppr sty c : map (\ c -> ppBeside (ppStr "| ") (ppr sty c)) cs)
 152
 153 pp_tydecl sty pp_head pp_decl_rhs derivings
 154   = ppHang pp_head 4 (ppSep [
 155         pp_decl_rhs,
 156         case (derivings, sty) of
 157           (Nothing,_)      -> ppNil
 158           (_,PprInterface) -> ppNil     -- No derivings in interfaces
 159           (Just ds,_)      -> ppCat [ppPStr SLIT("deriving"), ppParens (interpp'SP sty ds)]
 160     ])
 161
 162 pp_context_and_arrow :: Outputable name => PprStyle -> Context name -> Pretty
 163 pp_context_and_arrow sty [] = ppNil
 164 pp_context_and_arrow sty theta = ppCat [pprContext sty theta, ppPStr SLIT("=>")]
 165 \end{code}
 166
 167 A type for recording what types a datatype should be specialised to.
 168 It's called a ``Sig'' because it's sort of like a ``type signature''
 169 for an datatype declaration.
 170
 171 \begin{code}
 172 data SpecDataSig name
 173   = SpecDataSig name            -- tycon to specialise
 174                 (HsType name)
 175                 SrcLoc
 176
 177 instance (NamedThing name, Outputable name)
 178               => Outputable (SpecDataSig name) where
 179
 180     ppr sty (SpecDataSig tycon ty _)
 181       = ppCat [ppStr "{-# SPECIALIZE data", ppr sty ty, ppStr "#-}"]
 182 \end{code}
 183
 184 %************************************************************************
 185 %*                                                                      *
 186 \subsection[ConDecl]{A data-constructor declaration}
 187 %*                                                                      *
 188 %************************************************************************
 189
 190 \begin{code}
 191 data ConDecl name
 192   = ConDecl     name            -- prefix-style con decl
 193                 [BangType name]
 194                 SrcLoc
 195
 196   | ConOpDecl   (BangType name) -- infix-style con decl
 197                 name
 198                 (BangType name)
 199                 SrcLoc
 200
 201   | RecConDecl  name
 202                 [([name], BangType name)]       -- list of "fields"
 203                 SrcLoc
 204
 205   | NewConDecl  name            -- newtype con decl
 206                 (HsType name)
 207                 SrcLoc
 208
 209 data BangType name
 210   = Banged   (HsType name)      -- HsType: to allow Haskell extensions
 211   | Unbanged (HsType name)      -- (MonoType only needed for straight Haskell)
 212 \end{code}
 213
 214 \begin{code}
 215 instance (NamedThing name, Outputable name) => Outputable (ConDecl name) where
 216
 217     ppr sty (ConDecl con tys _)
 218       = ppCat [ppr sty (getOccName con), ppInterleave ppNil (map (ppr_bang sty) tys)]
 219
 220         -- We print ConOpDecls in prefix form in interface files
 221     ppr PprInterface (ConOpDecl ty1 op ty2 _)
 222       = ppCat [ppr PprInterface (getOccName op), ppr_bang PprInterface ty1, ppr_bang PprInterface ty2]
 223     ppr sty (ConOpDecl ty1 op ty2 _)
 224       = ppCat [ppr_bang sty ty1, ppr sty (getOccName op), ppr_bang sty ty2]
 225
 226     ppr sty (NewConDecl con ty _)
 227       = ppCat [ppr sty (getOccName con), pprParendHsType sty ty]
 228     ppr sty (RecConDecl con fields _)
 229       = ppCat [ppr sty (getOccName con),
 230                ppCurlies (ppInterleave pp'SP (map pp_field fields))
 231               ]
 232       where
 233         pp_field (ns, ty) = ppCat [ppCat (map (ppr sty . getOccName) ns),
 234                                    ppPStr SLIT("::"), ppr_bang sty ty]
 235
 236 ppr_bang sty (Banged   ty) = ppBeside (ppStr "! ") (pprParendHsType sty ty)
 237                                 -- The extra space helps the lexical analyser that lexes
 238                                 -- interface files; it doesn't make the rigid operator/identifier
 239                                 -- distinction, so "!a" is a valid identifier so far as it is concerned
 240 ppr_bang sty (Unbanged ty) = pprParendHsType sty ty
 241 \end{code}
 242
 243 %************************************************************************
 244 %*                                                                      *
 245 \subsection[ClassDecl]{A class declaration}
 246 %*                                                                      *
 247 %************************************************************************
 248
 249 \begin{code}
 250 data ClassDecl tyvar uvar name pat
 251   = ClassDecl   (Context name)                  -- context...
 252                 name                            -- name of the class
 253                 (HsTyVar name)                  -- the class type variable
 254                 [Sig name]                      -- methods' signatures
 255                 (MonoBinds tyvar uvar name pat) -- default methods
 256                 (ClassPragmas name)
 257                 SrcLoc
 258 \end{code}
 259
 260 \begin{code}
 261 instance (NamedThing name, Outputable name, Outputable pat,
 262           Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
 263                 => Outputable (ClassDecl tyvar uvar name pat) where
 264
 265     ppr sty (ClassDecl context clas tyvar sigs methods pragmas src_loc)
 266       | null sigs       -- No "where" part
 267       = top_matter
 268
 269       | iface_style     -- All on one line (for now at least)
 270       = ppCat [top_matter, ppStr "where",
 271                ppCurlies (ppInterleave (ppPStr SLIT("; ")) pp_sigs)]
 272
 273       | otherwise       -- Laid out
 274       = ppSep [ppCat [top_matter, ppStr "where {"],
 275                ppNest 4 ((ppIntersperse ppSemi pp_sigs `ppAbove` pp_methods)
 276                          `ppBeside` ppStr "}")]
 277       where
 278         top_matter = ppCat [ppStr "class", pp_context_and_arrow sty context,
 279                             ppr sty (getOccName clas), ppr sty tyvar]
 280         pp_sigs     = map (ppr sty) sigs
 281         pp_methods  = ppr sty methods
 282         iface_style = case sty of {PprInterface -> True; other -> False}
 283 \end{code}
 284
 285 %************************************************************************
 286 %*                                                                      *
 287 \subsection[InstDecl]{An instance declaration (also, @SpecInstSig@)}
 288 %*                                                                      *
 289 %************************************************************************
 290
 291 \begin{code}
 292 data InstDecl tyvar uvar name pat
 293   = InstDecl    (HsType name)   -- Context => Class Instance-type
 294                                 -- Using a polytype means that the renamer conveniently
 295                                 -- figures out the quantified type variables for us.
 296
 297                 (MonoBinds tyvar uvar name pat)
 298
 299                 [Sig name]              -- User-supplied pragmatic info
 300
 301                 (Maybe name)            -- Name for the dictionary function
 302
 303                 SrcLoc
 304 \end{code}
 305
 306 \begin{code}
 307 instance (NamedThing name, Outputable name, Outputable pat,
 308           Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
 309               => Outputable (InstDecl tyvar uvar name pat) where
 310
 311     ppr sty (InstDecl inst_ty binds uprags dfun_name src_loc)
 312       | case sty of { PprInterface -> True; other -> False} ||
 313         nullMonoBinds binds && null uprags
 314       = ppCat [ppStr "instance", ppr sty inst_ty]
 315
 316       | otherwise
 317       = ppAboves [ppCat [ppStr "instance", ppr sty inst_ty, ppStr "where"],
 318                   ppNest 4 (ppr sty uprags),
 319                   ppNest 4 (ppr sty binds) ]
 320 \end{code}
 321
 322 A type for recording what instances the user wants to specialise;
 323 called a ``Sig'' because it's sort of like a ``type signature'' for an
 324 instance.
 325 \begin{code}
 326 data SpecInstSig name
 327   = SpecInstSig  name               -- class
 328                  (HsType name)    -- type to specialise to
 329                  SrcLoc
 330
 331 instance (NamedThing name, Outputable name)
 332               => Outputable (SpecInstSig name) where
 333
 334     ppr sty (SpecInstSig clas ty _)
 335       = ppCat [ppStr "{-# SPECIALIZE instance", ppr sty clas, ppr sty ty, ppStr "#-}"]
 336 \end{code}
 337
 338 %************************************************************************
 339 %*                                                                      *
 340 \subsection[DefaultDecl]{A @default@ declaration}
 341 %*                                                                      *
 342 %************************************************************************
 343
 344 There can only be one default declaration per module, but it is hard
 345 for the parser to check that; we pass them all through in the abstract
 346 syntax, and that restriction must be checked in the front end.
 347
 348 \begin{code}
 349 data DefaultDecl name
 350   = DefaultDecl [HsType name]
 351                 SrcLoc
 352
 353 instance (NamedThing name, Outputable name)
 354               => Outputable (DefaultDecl name) where
 355
 356     ppr sty (DefaultDecl tys src_loc)
 357       = ppBeside (ppPStr SLIT("default ")) (ppParens (interpp'SP sty tys))
 358 \end{code}
 359
 360 %************************************************************************
 361 %*                                                                      *
 362 \subsection{Signatures in interface files}
 363 %*                                                                      *
 364 %************************************************************************
 365
 366 \begin{code}
 367 data IfaceSig name
 368   = IfaceSig    name
 369                 (HsType name)
 370                 [HsIdInfo name]
 371                 SrcLoc
 372
 373 instance (NamedThing name, Outputable name) => Outputable (IfaceSig name) where
 374     ppr sty (IfaceSig var ty _ _)
 375       = ppHang (ppCat [ppr sty (getOccName var), ppPStr SLIT("::")])
 376              4 (ppr sty ty)
 377
 378 data HsIdInfo name
 379   = HsArity             ArityInfo
 380   | HsStrictness        (StrictnessInfo name)
 381   | HsUnfold            (UfExpr name)
 382   | HsUpdate            UpdateInfo
 383   | HsDeforest          DeforestInfo
 384   | HsArgUsage          ArgUsageInfo
 385   | HsFBType            FBTypeInfo
 386         -- ToDo: specialisations
 387 \end{code}