compiler/hsSyn/HsDecls.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   4 %
   5
   6 \begin{code}
   7 {-# LANGUAGE DeriveDataTypeable #-}
   8
   9 -- | Abstract syntax of global declarations.
  10 --
  11 -- Definitions for: @TyDecl@ and @ConDecl@, @ClassDecl@,
  12 -- @InstDecl@, @DefaultDecl@ and @ForeignDecl@.
  13 module HsDecls (
  14   -- * Toplevel declarations
  15   HsDecl(..), LHsDecl,
  16   -- ** Class or type declarations
  17   TyClDecl(..), LTyClDecl,
  18   isClassDecl, isSynDecl, isDataDecl, isTypeDecl, isFamilyDecl,
  19   isFamInstDecl, tcdName, tyClDeclTyVars,
  20   countTyClDecls,
  21   -- ** Instance declarations
  22   InstDecl(..), LInstDecl, NewOrData(..), FamilyFlavour(..),
  23   instDeclATs,
  24   -- ** Standalone deriving declarations
  25   DerivDecl(..), LDerivDecl,
  26   -- ** @RULE@ declarations
  27   RuleDecl(..), LRuleDecl, RuleBndr(..),
  28   collectRuleBndrSigTys,
  29   -- ** @VECTORISE@ declarations
  30   VectDecl(..), LVectDecl,
  31   lvectDeclName,
  32   -- ** @default@ declarations
  33   DefaultDecl(..), LDefaultDecl,
  34   -- ** Top-level template haskell splice
  35   SpliceDecl(..),
  36   -- ** Foreign function interface declarations
  37   ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..),
  38   CImportSpec(..),
  39   -- ** Data-constructor declarations
  40   ConDecl(..), LConDecl, ResType(..),
  41   HsConDeclDetails, hsConDeclArgTys,
  42   -- ** Document comments
  43   DocDecl(..), LDocDecl, docDeclDoc,
  44   -- ** Deprecations
  45   WarnDecl(..),  LWarnDecl,
  46   -- ** Annotations
  47   AnnDecl(..), LAnnDecl,
  48   AnnProvenance(..), annProvenanceName_maybe, modifyAnnProvenanceNameM,
  49
  50   -- * Grouping
  51   HsGroup(..),  emptyRdrGroup, emptyRnGroup, appendGroups
  52     ) where
  53
  54 -- friends:
  55 import {-# SOURCE #-}   HsExpr( LHsExpr, HsExpr, pprExpr )
  56         -- Because Expr imports Decls via HsBracket
  57
  58 import HsBinds
  59 import HsPat
  60 import HsTypes
  61 import HsDoc
  62 import TyCon
  63 import NameSet
  64 import {- Kind parts of -} Type
  65 import BasicTypes
  66 import ForeignCall
  67
  68 -- others:
  69 import Class
  70 import Outputable
  71 import Util
  72 import SrcLoc
  73 import FastString
  74
  75 import Control.Monad    ( liftM )
  76 import Data.Data        hiding (TyCon)
  77 import Data.Maybe       ( isJust )
  78 \end{code}
  79
  80 %************************************************************************
  81 %*                                                                      *
  82 \subsection[HsDecl]{Declarations}
  83 %*                                                                      *
  84 %************************************************************************
  85
  86 \begin{code}
  87 type LHsDecl id = Located (HsDecl id)
  88
  89 -- | A Haskell Declaration
  90 data HsDecl id
  91   = TyClD       (TyClDecl id)     -- ^ A type or class declaration.
  92   | InstD       (InstDecl  id)    -- ^ An instance declaration.
  93   | DerivD      (DerivDecl id)
  94   | ValD        (HsBind id)
  95   | SigD        (Sig id)
  96   | DefD        (DefaultDecl id)
  97   | ForD        (ForeignDecl id)
  98   | WarningD    (WarnDecl id)
  99   | AnnD        (AnnDecl id)
 100   | RuleD       (RuleDecl id)
 101   | VectD       (VectDecl id)
 102   | SpliceD     (SpliceDecl id)
 103   | DocD        (DocDecl)
 104   | QuasiQuoteD (HsQuasiQuote id)
 105   deriving (Data, Typeable)
 106
 107
 108 -- NB: all top-level fixity decls are contained EITHER
 109 -- EITHER SigDs
 110 -- OR     in the ClassDecls in TyClDs
 111 --
 112 -- The former covers
 113 --      a) data constructors
 114 --      b) class methods (but they can be also done in the
 115 --              signatures of class decls)
 116 --      c) imported functions (that have an IfacSig)
 117 --      d) top level decls
 118 --
 119 -- The latter is for class methods only
 120
 121 -- | A 'HsDecl' is categorised into a 'HsGroup' before being
 122 -- fed to the renamer.
 123 data HsGroup id
 124   = HsGroup {
 125         hs_valds  :: HsValBinds id,
 126
 127         hs_tyclds :: [[LTyClDecl id]],
 128                 -- A list of mutually-recursive groups
 129                 -- Parser generates a singleton list;
 130                 -- renamer does dependency analysis
 131
 132         hs_instds :: [LInstDecl id],
 133         hs_derivds :: [LDerivDecl id],
 134
 135         hs_fixds  :: [LFixitySig id],
 136                 -- Snaffled out of both top-level fixity signatures,
 137                 -- and those in class declarations
 138
 139         hs_defds  :: [LDefaultDecl id],
 140         hs_fords  :: [LForeignDecl id],
 141         hs_warnds :: [LWarnDecl id],
 142         hs_annds  :: [LAnnDecl id],
 143         hs_ruleds :: [LRuleDecl id],
 144         hs_vects  :: [LVectDecl id],
 145
 146         hs_docs   :: [LDocDecl]
 147   } deriving (Data, Typeable)
 148
 149 emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup a
 150 emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn }
 151 emptyRnGroup  = emptyGroup { hs_valds = emptyValBindsOut }
 152
 153 emptyGroup = HsGroup { hs_tyclds = [], hs_instds = [], hs_derivds = [],
 154                        hs_fixds = [], hs_defds = [], hs_annds = [],
 155                        hs_fords = [], hs_warnds = [], hs_ruleds = [], hs_vects = [],
 156                        hs_valds = error "emptyGroup hs_valds: Can't happen",
 157                        hs_docs = [] }
 158
 159 appendGroups :: HsGroup a -> HsGroup a -> HsGroup a
 160 appendGroups
 161     HsGroup {
 162         hs_valds  = val_groups1,
 163         hs_tyclds = tyclds1,
 164         hs_instds = instds1,
 165         hs_derivds = derivds1,
 166         hs_fixds  = fixds1,
 167         hs_defds  = defds1,
 168         hs_annds  = annds1,
 169         hs_fords  = fords1,
 170         hs_warnds = warnds1,
 171         hs_ruleds = rulds1,
 172         hs_vects = vects1,
 173   hs_docs   = docs1 }
 174     HsGroup {
 175         hs_valds  = val_groups2,
 176         hs_tyclds = tyclds2,
 177         hs_instds = instds2,
 178         hs_derivds = derivds2,
 179         hs_fixds  = fixds2,
 180         hs_defds  = defds2,
 181         hs_annds  = annds2,
 182         hs_fords  = fords2,
 183         hs_warnds = warnds2,
 184         hs_ruleds = rulds2,
 185         hs_vects  = vects2,
 186         hs_docs   = docs2 }
 187   =
 188     HsGroup {
 189         hs_valds  = val_groups1 `plusHsValBinds` val_groups2,
 190         hs_tyclds = tyclds1 ++ tyclds2,
 191         hs_instds = instds1 ++ instds2,
 192         hs_derivds = derivds1 ++ derivds2,
 193         hs_fixds  = fixds1 ++ fixds2,
 194         hs_annds  = annds1 ++ annds2,
 195         hs_defds  = defds1 ++ defds2,
 196         hs_fords  = fords1 ++ fords2,
 197         hs_warnds = warnds1 ++ warnds2,
 198         hs_ruleds = rulds1 ++ rulds2,
 199         hs_vects  = vects1 ++ vects2,
 200         hs_docs   = docs1  ++ docs2 }
 201 \end{code}
 202
 203 \begin{code}
 204 instance OutputableBndr name => Outputable (HsDecl name) where
 205     ppr (TyClD dcl)             = ppr dcl
 206     ppr (ValD binds)            = ppr binds
 207     ppr (DefD def)              = ppr def
 208     ppr (InstD inst)            = ppr inst
 209     ppr (DerivD deriv)          = ppr deriv
 210     ppr (ForD fd)               = ppr fd
 211     ppr (SigD sd)               = ppr sd
 212     ppr (RuleD rd)              = ppr rd
 213     ppr (VectD vect)            = ppr vect
 214     ppr (WarningD wd)           = ppr wd
 215     ppr (AnnD ad)               = ppr ad
 216     ppr (SpliceD dd)            = ppr dd
 217     ppr (DocD doc)              = ppr doc
 218     ppr (QuasiQuoteD qq)        = ppr qq
 219
 220 instance OutputableBndr name => Outputable (HsGroup name) where
 221     ppr (HsGroup { hs_valds  = val_decls,
 222                    hs_tyclds = tycl_decls,
 223                    hs_instds = inst_decls,
 224                    hs_derivds = deriv_decls,
 225                    hs_fixds  = fix_decls,
 226                    hs_warnds = deprec_decls,
 227                    hs_annds  = ann_decls,
 228                    hs_fords  = foreign_decls,
 229                    hs_defds  = default_decls,
 230                    hs_ruleds = rule_decls,
 231                    hs_vects  = vect_decls })
 232         = vcat_mb empty
 233             [ppr_ds fix_decls, ppr_ds default_decls,
 234              ppr_ds deprec_decls, ppr_ds ann_decls,
 235              ppr_ds rule_decls,
 236              ppr_ds vect_decls,
 237              if isEmptyValBinds val_decls
 238                 then Nothing
 239                 else Just (ppr val_decls),
 240              ppr_ds (concat tycl_decls),
 241              ppr_ds inst_decls,
 242              ppr_ds deriv_decls,
 243              ppr_ds foreign_decls]
 244         where
 245           ppr_ds :: Outputable a => [a] -> Maybe SDoc
 246           ppr_ds [] = Nothing
 247           ppr_ds ds = Just (vcat (map ppr ds))
 248
 249           vcat_mb :: SDoc -> [Maybe SDoc] -> SDoc
 250           -- Concatenate vertically with white-space between non-blanks
 251           vcat_mb _    []             = empty
 252           vcat_mb gap (Nothing : ds) = vcat_mb gap ds
 253           vcat_mb gap (Just d  : ds) = gap $$ d $$ vcat_mb blankLine ds
 254
 255 data SpliceDecl id
 256   = SpliceDecl                  -- Top level splice
 257         (Located (HsExpr id))
 258         HsExplicitFlag          -- Explicit <=> $(f x y)
 259                                 -- Implicit <=> f x y,  i.e. a naked top level expression
 260     deriving (Data, Typeable)
 261
 262 instance OutputableBndr name => Outputable (SpliceDecl name) where
 263    ppr (SpliceDecl e _) = ptext (sLit "$") <> parens (pprExpr (unLoc e))
 264 \end{code}
 265
 266
 267 %************************************************************************
 268 %*                                                                      *
 269 \subsection[TyDecl]{@data@, @newtype@ or @type@ (synonym) type declaration}
 270 %*                                                                      *
 271 %************************************************************************
 272
 273                 --------------------------------
 274                         THE NAMING STORY
 275                 --------------------------------
 276
 277 Here is the story about the implicit names that go with type, class,
 278 and instance decls.  It's a bit tricky, so pay attention!
 279
 280 "Implicit" (or "system") binders
 281 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 282   Each data type decl defines
 283         a worker name for each constructor
 284         to-T and from-T convertors
 285   Each class decl defines
 286         a tycon for the class
 287         a data constructor for that tycon
 288         the worker for that constructor
 289         a selector for each superclass
 290
 291 All have occurrence names that are derived uniquely from their parent
 292 declaration.
 293
 294 None of these get separate definitions in an interface file; they are
 295 fully defined by the data or class decl.  But they may *occur* in
 296 interface files, of course.  Any such occurrence must haul in the
 297 relevant type or class decl.
 298
 299 Plan of attack:
 300  - Ensure they "point to" the parent data/class decl
 301    when loading that decl from an interface file
 302    (See RnHiFiles.getSysBinders)
 303
 304  - When typechecking the decl, we build the implicit TyCons and Ids.
 305    When doing so we look them up in the name cache (RnEnv.lookupSysName),
 306    to ensure correct module and provenance is set
 307
 308 These are the two places that we have to conjure up the magic derived
 309 names.  (The actual magic is in OccName.mkWorkerOcc, etc.)
 310
 311 Default methods
 312 ~~~~~~~~~~~~~~~
 313  - Occurrence name is derived uniquely from the method name
 314    E.g. $dmmax
 315
 316  - If there is a default method name at all, it's recorded in
 317    the ClassOpSig (in HsBinds), in the DefMeth field.
 318    (DefMeth is defined in Class.lhs)
 319
 320 Source-code class decls and interface-code class decls are treated subtly
 321 differently, which has given me a great deal of confusion over the years.
 322 Here's the deal.  (We distinguish the two cases because source-code decls
 323 have (Just binds) in the tcdMeths field, whereas interface decls have Nothing.
 324
 325 In *source-code* class declarations:
 326
 327  - When parsing, every ClassOpSig gets a DefMeth with a suitable RdrName
 328    This is done by RdrHsSyn.mkClassOpSigDM
 329
 330  - The renamer renames it to a Name
 331
 332  - During typechecking, we generate a binding for each $dm for
 333    which there's a programmer-supplied default method:
 334         class Foo a where
 335           op1 :: <type>
 336           op2 :: <type>
 337           op1 = ...
 338    We generate a binding for $dmop1 but not for $dmop2.
 339    The Class for Foo has a NoDefMeth for op2 and a DefMeth for op1.
 340    The Name for $dmop2 is simply discarded.
 341
 342 In *interface-file* class declarations:
 343   - When parsing, we see if there's an explicit programmer-supplied default method
 344     because there's an '=' sign to indicate it:
 345         class Foo a where
 346           op1 = :: <type>       -- NB the '='
 347           op2   :: <type>
 348     We use this info to generate a DefMeth with a suitable RdrName for op1,
 349     and a NoDefMeth for op2
 350   - The interface file has a separate definition for $dmop1, with unfolding etc.
 351   - The renamer renames it to a Name.
 352   - The renamer treats $dmop1 as a free variable of the declaration, so that
 353     the binding for $dmop1 will be sucked in.  (See RnHsSyn.tyClDeclFVs)
 354     This doesn't happen for source code class decls, because they *bind* the default method.
 355
 356 Dictionary functions
 357 ~~~~~~~~~~~~~~~~~~~~
 358 Each instance declaration gives rise to one dictionary function binding.
 359
 360 The type checker makes up new source-code instance declarations
 361 (e.g. from 'deriving' or generic default methods --- see
 362 TcInstDcls.tcInstDecls1).  So we can't generate the names for
 363 dictionary functions in advance (we don't know how many we need).
 364
 365 On the other hand for interface-file instance declarations, the decl
 366 specifies the name of the dictionary function, and it has a binding elsewhere
 367 in the interface file:
 368         instance {Eq Int} = dEqInt
 369         dEqInt :: {Eq Int} <pragma info>
 370
 371 So again we treat source code and interface file code slightly differently.
 372
 373 Source code:
 374   - Source code instance decls have a Nothing in the (Maybe name) field
 375     (see data InstDecl below)
 376
 377   - The typechecker makes up a Local name for the dict fun for any source-code
 378     instance decl, whether it comes from a source-code instance decl, or whether
 379     the instance decl is derived from some other construct (e.g. 'deriving').
 380
 381   - The occurrence name it chooses is derived from the instance decl (just for
 382     documentation really) --- e.g. dNumInt.  Two dict funs may share a common
 383     occurrence name, but will have different uniques.  E.g.
 384         instance Foo [Int]  where ...
 385         instance Foo [Bool] where ...
 386     These might both be dFooList
 387
 388   - The CoreTidy phase externalises the name, and ensures the occurrence name is
 389     unique (this isn't special to dict funs).  So we'd get dFooList and dFooList1.
 390
 391   - We can take this relaxed approach (changing the occurrence name later)
 392     because dict fun Ids are not captured in a TyCon or Class (unlike default
 393     methods, say).  Instead, they are kept separately in the InstEnv.  This
 394     makes it easy to adjust them after compiling a module.  (Once we've finished
 395     compiling that module, they don't change any more.)
 396
 397
 398 Interface file code:
 399   - The instance decl gives the dict fun name, so the InstDecl has a (Just name)
 400     in the (Maybe name) field.
 401
 402   - RnHsSyn.instDeclFVs treats the dict fun name as free in the decl, so that we
 403     suck in the dfun binding
 404
 405
 406 \begin{code}
 407 -- Representation of indexed types
 408 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 409 -- Family kind signatures are represented by the variant `TyFamily'.  It
 410 -- covers "type family", "newtype family", and "data family" declarations,
 411 -- distinguished by the value of the field `tcdFlavour'.
 412 --
 413 -- Indexed types are represented by 'TyData' and 'TySynonym' using the field
 414 -- 'tcdTyPats::Maybe [LHsType name]', with the following meaning:
 415 --
 416 --   * If it is 'Nothing', we have a *vanilla* data type declaration or type
 417 --     synonym declaration and 'tcdVars' contains the type parameters of the
 418 --     type constructor.
 419 --
 420 --   * If it is 'Just pats', we have the definition of an indexed type.  Then,
 421 --     'pats' are type patterns for the type-indexes of the type constructor
 422 --     and 'tcdTyVars' are the variables in those patterns.  Hence, the arity of
 423 --     the indexed type (ie, the number of indexes) is 'length tcdTyPats' and
 424 --     *not* 'length tcdVars'.
 425 --
 426 -- In both cases, 'tcdVars' collects all variables we need to quantify over.
 427
 428 type LTyClDecl name = Located (TyClDecl name)
 429
 430 -- | A type or class declaration.
 431 data TyClDecl name
 432   = ForeignType {
 433                 tcdLName    :: Located name,
 434                 tcdExtName  :: Maybe FastString
 435     }
 436
 437
 438   | -- | @type/data family T :: *->*@
 439     TyFamily {  tcdFlavour:: FamilyFlavour,             -- type or data
 440                 tcdLName  :: Located name,              -- type constructor
 441                 tcdTyVars :: [LHsTyVarBndr name],       -- type variables
 442                 tcdKind   :: Maybe Kind                 -- result kind
 443     }
 444
 445
 446   | -- | Declares a data type or newtype, giving its construcors
 447     -- @
 448     --  data/newtype T a = <constrs>
 449     --  data/newtype instance T [a] = <constrs>
 450     -- @
 451     TyData {    tcdND     :: NewOrData,
 452                 tcdCtxt   :: LHsContext name,           -- ^ Context
 453                 tcdLName  :: Located name,              -- ^ Type constructor
 454
 455                 tcdTyVars :: [LHsTyVarBndr name],       -- ^ Type variables
 456
 457                 tcdTyPats :: Maybe [LHsType name],
 458                         -- ^ Type patterns.
 459                         --
 460                         -- @Just [t1..tn]@ for @data instance T t1..tn = ...@
 461                         --      in this case @tcdTyVars = fv( tcdTyPats )@.
 462                         -- @Nothing@ for everything else.
 463
 464                 tcdKindSig:: Maybe Kind,
 465                         -- ^ Optional kind signature.
 466                         --
 467                         -- @(Just k)@ for a GADT-style @data@, or @data
 468                         -- instance@ decl with explicit kind sig
 469
 470                 tcdCons   :: [LConDecl name],
 471                         -- ^ Data constructors
 472                         --
 473                         -- For @data T a = T1 | T2 a@
 474                         --   the 'LConDecl's all have 'ResTyH98'.
 475                         -- For @data T a where { T1 :: T a }@
 476                         --   the 'LConDecls' all have 'ResTyGADT'.
 477
 478                 tcdDerivs :: Maybe [LHsType name]
 479                         -- ^ Derivings; @Nothing@ => not specified,
 480                         --              @Just []@ => derive exactly what is asked
 481                         --
 482                         -- These "types" must be of form
 483                         -- @
 484                         --      forall ab. C ty1 ty2
 485                         -- @
 486                         -- Typically the foralls and ty args are empty, but they
 487                         -- are non-empty for the newtype-deriving case
 488     }
 489
 490   | TySynonym { tcdLName  :: Located name,              -- ^ type constructor
 491                 tcdTyVars :: [LHsTyVarBndr name],       -- ^ type variables
 492                 tcdTyPats :: Maybe [LHsType name],      -- ^ Type patterns
 493                         -- See comments for tcdTyPats in TyData
 494                         -- 'Nothing' => vanilla type synonym
 495
 496                 tcdSynRhs :: LHsType name               -- ^ synonym expansion
 497     }
 498
 499   | ClassDecl { tcdCtxt    :: LHsContext name,          -- ^ Context...
 500                 tcdLName   :: Located name,             -- ^ Name of the class
 501                 tcdTyVars  :: [LHsTyVarBndr name],      -- ^ Class type variables
 502                 tcdFDs     :: [Located (FunDep name)],  -- ^ Functional deps
 503                 tcdSigs    :: [LSig name],              -- ^ Methods' signatures
 504                 tcdMeths   :: LHsBinds name,            -- ^ Default methods
 505                 tcdATs     :: [LTyClDecl name],         -- ^ Associated types; ie
 506                                                         --   only 'TyFamily' and
 507                                                         --   'TySynonym'; the
 508                                                         --   latter for defaults
 509                 tcdDocs    :: [LDocDecl]                -- ^ Haddock docs
 510     }
 511   deriving (Data, Typeable)
 512
 513 data NewOrData
 514   = NewType                     -- ^ @newtype Blah ...@
 515   | DataType                    -- ^ @data Blah ...@
 516   deriving( Eq, Data, Typeable )                -- Needed because Demand derives Eq
 517
 518 data FamilyFlavour
 519   = TypeFamily                  -- ^ @type family ...@
 520   | DataFamily                  -- ^ @data family ...@
 521   deriving (Data, Typeable)
 522 \end{code}
 523
 524 Simple classifiers
 525
 526 \begin{code}
 527 -- | @True@ <=> argument is a @data@\/@newtype@ or @data@\/@newtype instance@
 528 -- declaration.
 529 isDataDecl :: TyClDecl name -> Bool
 530 isDataDecl (TyData {}) = True
 531 isDataDecl _other      = False
 532
 533 -- | type or type instance declaration
 534 isTypeDecl :: TyClDecl name -> Bool
 535 isTypeDecl (TySynonym {}) = True
 536 isTypeDecl _other         = False
 537
 538 -- | vanilla Haskell type synonym (ie, not a type instance)
 539 isSynDecl :: TyClDecl name -> Bool
 540 isSynDecl (TySynonym {tcdTyPats = Nothing}) = True
 541 isSynDecl _other                            = False
 542
 543 -- | type class
 544 isClassDecl :: TyClDecl name -> Bool
 545 isClassDecl (ClassDecl {}) = True
 546 isClassDecl _              = False
 547
 548 -- | type family declaration
 549 isFamilyDecl :: TyClDecl name -> Bool
 550 isFamilyDecl (TyFamily {}) = True
 551 isFamilyDecl _other        = False
 552
 553 -- | family instance (types, newtypes, and data types)
 554 isFamInstDecl :: TyClDecl name -> Bool
 555 isFamInstDecl tydecl
 556    | isTypeDecl tydecl
 557      || isDataDecl tydecl = isJust (tcdTyPats tydecl)
 558    | otherwise            = False
 559 \end{code}
 560
 561 Dealing with names
 562
 563 \begin{code}
 564 tcdName :: TyClDecl name -> name
 565 tcdName decl = unLoc (tcdLName decl)
 566
 567 tyClDeclTyVars :: TyClDecl name -> [LHsTyVarBndr name]
 568 tyClDeclTyVars (TyFamily    {tcdTyVars = tvs}) = tvs
 569 tyClDeclTyVars (TySynonym   {tcdTyVars = tvs}) = tvs
 570 tyClDeclTyVars (TyData      {tcdTyVars = tvs}) = tvs
 571 tyClDeclTyVars (ClassDecl   {tcdTyVars = tvs}) = tvs
 572 tyClDeclTyVars (ForeignType {})                = []
 573 \end{code}
 574
 575 \begin{code}
 576 countTyClDecls :: [TyClDecl name] -> (Int, Int, Int, Int, Int, Int)
 577         -- class, synonym decls, data, newtype, family decls, family instances
 578 countTyClDecls decls
 579  = (count isClassDecl    decls,
 580     count isSynDecl      decls,  -- excluding...
 581     count isDataTy       decls,  -- ...family...
 582     count isNewTy        decls,  -- ...instances
 583     count isFamilyDecl   decls,
 584     count isFamInstDecl  decls)
 585  where
 586    isDataTy TyData{tcdND = DataType, tcdTyPats = Nothing} = True
 587    isDataTy _                                             = False
 588
 589    isNewTy TyData{tcdND = NewType, tcdTyPats = Nothing} = True
 590    isNewTy _                                            = False
 591 \end{code}
 592
 593 \begin{code}
 594 instance OutputableBndr name
 595               => Outputable (TyClDecl name) where
 596
 597     ppr (ForeignType {tcdLName = ltycon})
 598         = hsep [ptext (sLit "foreign import type dotnet"), ppr ltycon]
 599
 600     ppr (TyFamily {tcdFlavour = flavour, tcdLName = ltycon,
 601                    tcdTyVars = tyvars, tcdKind = mb_kind})
 602       = pp_flavour <+> pp_decl_head [] ltycon tyvars Nothing <+> pp_kind
 603         where
 604           pp_flavour = case flavour of
 605                          TypeFamily -> ptext (sLit "type family")
 606                          DataFamily -> ptext (sLit "data family")
 607
 608           pp_kind = case mb_kind of
 609                       Nothing   -> empty
 610                       Just kind -> dcolon <+> pprKind kind
 611
 612     ppr (TySynonym {tcdLName = ltycon, tcdTyVars = tyvars, tcdTyPats = typats,
 613                     tcdSynRhs = mono_ty})
 614       = hang (ptext (sLit "type") <+>
 615               (if isJust typats then ptext (sLit "instance") else empty) <+>
 616               pp_decl_head [] ltycon tyvars typats <+>
 617               equals)
 618              4 (ppr mono_ty)
 619
 620     ppr (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = ltycon,
 621                  tcdTyVars = tyvars, tcdTyPats = typats, tcdKindSig = mb_sig,
 622                  tcdCons = condecls, tcdDerivs = derivings})
 623       = pp_tydecl (null condecls && isJust mb_sig)
 624                   (ppr new_or_data <+>
 625                    (if isJust typats then ptext (sLit "instance") else empty) <+>
 626                    pp_decl_head (unLoc context) ltycon tyvars typats <+>
 627                    ppr_sigx mb_sig)
 628                   (pp_condecls condecls)
 629                   derivings
 630       where
 631         ppr_sigx Nothing     = empty
 632         ppr_sigx (Just kind) = dcolon <+> pprKind kind
 633
 634     ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars,
 635                     tcdFDs  = fds,
 636                     tcdSigs = sigs, tcdMeths = methods, tcdATs = ats})
 637       | null sigs && null ats  -- No "where" part
 638       = top_matter
 639
 640       | otherwise       -- Laid out
 641       = sep [hsep [top_matter, ptext (sLit "where {")],
 642              nest 4 (sep [ sep (map ppr_semi ats)
 643                          , sep (map ppr_semi sigs)
 644                          , pprLHsBinds methods
 645                          , char '}'])]
 646       where
 647         top_matter    =     ptext (sLit "class")
 648                         <+> pp_decl_head (unLoc context) lclas tyvars Nothing
 649                         <+> pprFundeps (map unLoc fds)
 650         ppr_semi :: Outputable a => a -> SDoc
 651         ppr_semi decl = ppr decl <> semi
 652
 653 pp_decl_head :: OutputableBndr name
 654    => HsContext name
 655    -> Located name
 656    -> [LHsTyVarBndr name]
 657    -> Maybe [LHsType name]
 658    -> SDoc
 659 pp_decl_head context thing tyvars Nothing       -- no explicit type patterns
 660   = hsep [pprHsContext context, ppr thing, interppSP tyvars]
 661 pp_decl_head context thing _      (Just typats) -- explicit type patterns
 662   = hsep [ pprHsContext context, ppr thing
 663          , hsep (map (pprParendHsType.unLoc) typats)]
 664
 665 pp_condecls :: OutputableBndr name => [LConDecl name] -> SDoc
 666 pp_condecls cs@(L _ ConDecl{ con_res = ResTyGADT _ } : _) -- In GADT syntax
 667   = hang (ptext (sLit "where")) 2 (vcat (map ppr cs))
 668 pp_condecls cs                    -- In H98 syntax
 669   = equals <+> sep (punctuate (ptext (sLit " |")) (map ppr cs))
 670
 671 pp_tydecl :: OutputableBndr name => Bool -> SDoc -> SDoc -> Maybe [LHsType name] -> SDoc
 672 pp_tydecl True  pp_head _ _
 673   = pp_head
 674 pp_tydecl False pp_head pp_decl_rhs derivings
 675   = hang pp_head 4 (sep [
 676       pp_decl_rhs,
 677       case derivings of
 678         Nothing -> empty
 679         Just ds -> hsep [ptext (sLit "deriving"), parens (interpp'SP ds)]
 680     ])
 681
 682 instance Outputable NewOrData where
 683   ppr NewType  = ptext (sLit "newtype")
 684   ppr DataType = ptext (sLit "data")
 685 \end{code}
 686
 687
 688 %************************************************************************
 689 %*                                                                      *
 690 \subsection[ConDecl]{A data-constructor declaration}
 691 %*                                                                      *
 692 %************************************************************************
 693
 694 \begin{code}
 695 type LConDecl name = Located (ConDecl name)
 696
 697 -- data T b = forall a. Eq a => MkT a b
 698 --   MkT :: forall b a. Eq a => MkT a b
 699
 700 -- data T b where
 701 --      MkT1 :: Int -> T Int
 702
 703 -- data T = Int `MkT` Int
 704 --        | MkT2
 705
 706 -- data T a where
 707 --      Int `MkT` Int :: T Int
 708
 709 data ConDecl name
 710   = ConDecl
 711     { con_name      :: Located name
 712         -- ^ Constructor name.  This is used for the DataCon itself, and for
 713         -- the user-callable wrapper Id.
 714
 715     , con_explicit  :: HsExplicitFlag
 716         -- ^ Is there an user-written forall? (cf. 'HsTypes.HsForAllTy')
 717
 718     , con_qvars     :: [LHsTyVarBndr name]
 719         -- ^ Type variables.  Depending on 'con_res' this describes the
 720         -- following entities
 721         --
 722         --  - ResTyH98:  the constructor's *existential* type variables
 723         --  - ResTyGADT: *all* the constructor's quantified type variables
 724         --
 725         -- If con_explicit is Implicit, then con_qvars is irrelevant
 726         -- until after renaming.
 727
 728     , con_cxt       :: LHsContext name
 729         -- ^ The context.  This /does not/ include the \"stupid theta\" which
 730         -- lives only in the 'TyData' decl.
 731
 732     , con_details   :: HsConDeclDetails name
 733         -- ^ The main payload
 734
 735     , con_res       :: ResType name
 736         -- ^ Result type of the constructor
 737
 738     , con_doc       :: Maybe LHsDocString
 739         -- ^ A possible Haddock comment.
 740
 741     , con_old_rec :: Bool
 742         -- ^ TEMPORARY field; True <=> user has employed now-deprecated syntax for
 743         --                             GADT-style record decl   C { blah } :: T a b
 744         -- Remove this when we no longer parse this stuff, and hence do not
 745         -- need to report decprecated use
 746     } deriving (Data, Typeable)
 747
 748 type HsConDeclDetails name = HsConDetails (LBangType name) [ConDeclField name]
 749
 750 hsConDeclArgTys :: HsConDeclDetails name -> [LBangType name]
 751 hsConDeclArgTys (PrefixCon tys)    = tys
 752 hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2]
 753 hsConDeclArgTys (RecCon flds)      = map cd_fld_type flds
 754
 755 data ResType name
 756    = ResTyH98           -- Constructor was declared using Haskell 98 syntax
 757    | ResTyGADT (LHsType name)   -- Constructor was declared using GADT-style syntax,
 758                                 --      and here is its result type
 759    deriving (Data, Typeable)
 760
 761 instance OutputableBndr name => Outputable (ResType name) where
 762          -- Debugging only
 763    ppr ResTyH98 = ptext (sLit "ResTyH98")
 764    ppr (ResTyGADT ty) = ptext (sLit "ResTyGADT") <+> pprParendHsType (unLoc ty)
 765 \end{code}
 766
 767
 768 \begin{code}
 769 instance (OutputableBndr name) => Outputable (ConDecl name) where
 770     ppr = pprConDecl
 771
 772 pprConDecl :: OutputableBndr name => ConDecl name -> SDoc
 773 pprConDecl (ConDecl { con_name = con, con_explicit = expl, con_qvars = tvs
 774                     , con_cxt = cxt, con_details = details
 775                     , con_res = ResTyH98, con_doc = doc })
 776   = sep [ppr_mbDoc doc, pprHsForAll expl tvs cxt, ppr_details details]
 777   where
 778     ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprHsInfix con, ppr t2]
 779     ppr_details (PrefixCon tys)  = hsep (pprHsVar con : map ppr tys)
 780     ppr_details (RecCon fields)  = ppr con <+> pprConDeclFields fields
 781
 782 pprConDecl (ConDecl { con_name = con, con_explicit = expl, con_qvars = tvs
 783                     , con_cxt = cxt, con_details = PrefixCon arg_tys
 784                     , con_res = ResTyGADT res_ty })
 785   = ppr con <+> dcolon <+>
 786     sep [pprHsForAll expl tvs cxt, ppr (foldr mk_fun_ty res_ty arg_tys)]
 787   where
 788     mk_fun_ty a b = noLoc (HsFunTy a b)
 789
 790 pprConDecl (ConDecl { con_name = con, con_explicit = expl, con_qvars = tvs
 791                     , con_cxt = cxt, con_details = RecCon fields, con_res = ResTyGADT res_ty })
 792   = sep [ppr con <+> dcolon <+> pprHsForAll expl tvs cxt,
 793          pprConDeclFields fields <+> arrow <+> ppr res_ty]
 794
 795 pprConDecl (ConDecl {con_name = con, con_details = InfixCon {}, con_res = ResTyGADT {} })
 796   = pprPanic "pprConDecl" (ppr con)
 797         -- In GADT syntax we don't allow infix constructors
 798 \end{code}
 799
 800 %************************************************************************
 801 %*                                                                      *
 802 \subsection[InstDecl]{An instance declaration}
 803 %*                                                                      *
 804 %************************************************************************
 805
 806 \begin{code}
 807 type LInstDecl name = Located (InstDecl name)
 808
 809 data InstDecl name
 810   = InstDecl    (LHsType name)  -- Context => Class Instance-type
 811                                 -- Using a polytype means that the renamer conveniently
 812                                 -- figures out the quantified type variables for us.
 813                 (LHsBinds name)
 814                 [LSig name]     -- User-supplied pragmatic info
 815                 [LTyClDecl name]-- Associated types (ie, 'TyData' and
 816                                 -- 'TySynonym' only)
 817   deriving (Data, Typeable)
 818
 819 instance (OutputableBndr name) => Outputable (InstDecl name) where
 820
 821     ppr (InstDecl inst_ty binds uprags ats)
 822       = vcat [hsep [ptext (sLit "instance"), ppr inst_ty, ptext (sLit "where")]
 823              , nest 4 $ vcat (map ppr ats)
 824              , nest 4 $ vcat (map ppr uprags)
 825              , nest 4 $ pprLHsBinds binds ]
 826
 827 -- Extract the declarations of associated types from an instance
 828 --
 829 instDeclATs :: [LInstDecl name] -> [LTyClDecl name]
 830 instDeclATs inst_decls = [at | L _ (InstDecl _ _ _ ats) <- inst_decls, at <- ats]
 831 \end{code}
 832
 833 %************************************************************************
 834 %*                                                                      *
 835 \subsection[DerivDecl]{A stand-alone instance deriving declaration}
 836 %*                                                                      *
 837 %************************************************************************
 838
 839 \begin{code}
 840 type LDerivDecl name = Located (DerivDecl name)
 841
 842 data DerivDecl name = DerivDecl { deriv_type :: LHsType name }
 843   deriving (Data, Typeable)
 844
 845 instance (OutputableBndr name) => Outputable (DerivDecl name) where
 846     ppr (DerivDecl ty)
 847         = hsep [ptext (sLit "deriving instance"), ppr ty]
 848 \end{code}
 849
 850 %************************************************************************
 851 %*                                                                      *
 852 \subsection[DefaultDecl]{A @default@ declaration}
 853 %*                                                                      *
 854 %************************************************************************
 855
 856 There can only be one default declaration per module, but it is hard
 857 for the parser to check that; we pass them all through in the abstract
 858 syntax, and that restriction must be checked in the front end.
 859
 860 \begin{code}
 861 type LDefaultDecl name = Located (DefaultDecl name)
 862
 863 data DefaultDecl name
 864   = DefaultDecl [LHsType name]
 865   deriving (Data, Typeable)
 866
 867 instance (OutputableBndr name)
 868               => Outputable (DefaultDecl name) where
 869
 870     ppr (DefaultDecl tys)
 871       = ptext (sLit "default") <+> parens (interpp'SP tys)
 872 \end{code}
 873
 874 %************************************************************************
 875 %*                                                                      *
 876 \subsection{Foreign function interface declaration}
 877 %*                                                                      *
 878 %************************************************************************
 879
 880 \begin{code}
 881
 882 -- foreign declarations are distinguished as to whether they define or use a
 883 -- Haskell name
 884 --
 885 --  * the Boolean value indicates whether the pre-standard deprecated syntax
 886 --   has been used
 887 --
 888 type LForeignDecl name = Located (ForeignDecl name)
 889
 890 data ForeignDecl name
 891   = ForeignImport (Located name) (LHsType name) ForeignImport  -- defines name
 892   | ForeignExport (Located name) (LHsType name) ForeignExport  -- uses name
 893   deriving (Data, Typeable)
 894
 895 -- Specification Of an imported external entity in dependence on the calling
 896 -- convention
 897 --
 898 data ForeignImport = -- import of a C entity
 899                      --
 900                      --  * the two strings specifying a header file or library
 901                      --   may be empty, which indicates the absence of a
 902                      --   header or object specification (both are not used
 903                      --   in the case of `CWrapper' and when `CFunction'
 904                      --   has a dynamic target)
 905                      --
 906                      --  * the calling convention is irrelevant for code
 907                      --   generation in the case of `CLabel', but is needed
 908                      --   for pretty printing
 909                      --
 910                      --  * `Safety' is irrelevant for `CLabel' and `CWrapper'
 911                      --
 912                      CImport  CCallConv       -- ccall or stdcall
 913                               Safety          -- interruptible, safe or unsafe
 914                               FastString      -- name of C header
 915                               CImportSpec     -- details of the C entity
 916   deriving (Data, Typeable)
 917
 918 -- details of an external C entity
 919 --
 920 data CImportSpec = CLabel    CLabelString     -- import address of a C label
 921                  | CFunction CCallTarget      -- static or dynamic function
 922                  | CWrapper                   -- wrapper to expose closures
 923                                               -- (former f.e.d.)
 924   deriving (Data, Typeable)
 925
 926 -- specification of an externally exported entity in dependence on the calling
 927 -- convention
 928 --
 929 data ForeignExport = CExport  CExportSpec    -- contains the calling convention
 930   deriving (Data, Typeable)
 931
 932 -- pretty printing of foreign declarations
 933 --
 934
 935 instance OutputableBndr name => Outputable (ForeignDecl name) where
 936   ppr (ForeignImport n ty fimport) =
 937     hang (ptext (sLit "foreign import") <+> ppr fimport <+> ppr n)
 938        2 (dcolon <+> ppr ty)
 939   ppr (ForeignExport n ty fexport) =
 940     hang (ptext (sLit "foreign export") <+> ppr fexport <+> ppr n)
 941        2 (dcolon <+> ppr ty)
 942
 943 instance Outputable ForeignImport where
 944   ppr (CImport  cconv safety header spec) =
 945     ppr cconv <+> ppr safety <+>
 946     char '"' <> pprCEntity spec <> char '"'
 947     where
 948       pp_hdr = if nullFS header then empty else ftext header
 949
 950       pprCEntity (CLabel lbl) =
 951         ptext (sLit "static") <+> pp_hdr <+> char '&' <> ppr lbl
 952       pprCEntity (CFunction (StaticTarget lbl _)) =
 953         ptext (sLit "static") <+> pp_hdr <+> ppr lbl
 954       pprCEntity (CFunction (DynamicTarget)) =
 955         ptext (sLit "dynamic")
 956       pprCEntity (CWrapper) = ptext (sLit "wrapper")
 957
 958 instance Outputable ForeignExport where
 959   ppr (CExport  (CExportStatic lbl cconv)) =
 960     ppr cconv <+> char '"' <> ppr lbl <> char '"'
 961 \end{code}
 962
 963
 964 %************************************************************************
 965 %*                                                                      *
 966 \subsection{Transformation rules}
 967 %*                                                                      *
 968 %************************************************************************
 969
 970 \begin{code}
 971 type LRuleDecl name = Located (RuleDecl name)
 972
 973 data RuleDecl name
 974   = HsRule                      -- Source rule
 975         RuleName                -- Rule name
 976         Activation
 977         [RuleBndr name]         -- Forall'd vars; after typechecking this includes tyvars
 978         (Located (HsExpr name)) -- LHS
 979         NameSet                 -- Free-vars from the LHS
 980         (Located (HsExpr name)) -- RHS
 981         NameSet                 -- Free-vars from the RHS
 982   deriving (Data, Typeable)
 983
 984 data RuleBndr name
 985   = RuleBndr (Located name)
 986   | RuleBndrSig (Located name) (LHsType name)
 987   deriving (Data, Typeable)
 988
 989 collectRuleBndrSigTys :: [RuleBndr name] -> [LHsType name]
 990 collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs]
 991
 992 instance OutputableBndr name => Outputable (RuleDecl name) where
 993   ppr (HsRule name act ns lhs _fv_lhs rhs _fv_rhs)
 994         = sep [text "{-# RULES" <+> doubleQuotes (ftext name) <+> ppr act,
 995                nest 4 (pp_forall <+> pprExpr (unLoc lhs)),
 996                nest 4 (equals <+> pprExpr (unLoc rhs) <+> text "#-}") ]
 997         where
 998           pp_forall | null ns   = empty
 999                     | otherwise = text "forall" <+> fsep (map ppr ns) <> dot
1000
1001 instance OutputableBndr name => Outputable (RuleBndr name) where
1002    ppr (RuleBndr name) = ppr name
1003    ppr (RuleBndrSig name ty) = ppr name <> dcolon <> ppr ty
1004 \end{code}
1005
1006
1007 %************************************************************************
1008 %*                                                                      *
1009 \subsection{Vectorisation declarations}
1010 %*                                                                      *
1011 %************************************************************************
1012
1013 A vectorisation pragma, one of
1014
1015   {-# VECTORISE f = closure1 g (scalar_map g) #-}
1016   {-# VECTORISE SCALAR f #-}
1017   {-# NOVECTORISE f #-}
1018
1019   {-# VECTORISE type T = ty #-}
1020   {-# VECTORISE SCALAR type T #-}
1021
1022 Note [Typechecked vectorisation pragmas]
1023 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1024 In case of the first variant of vectorisation pragmas (with an explicit expression),
1025 we need to infer the type of that expression during type checking and then keep that type
1026 around until vectorisation, so that it can be checked against the *vectorised* type of 'f'.
1027 (We cannot determine vectorised types during type checking due to internal information of
1028 the vectoriser being needed.)
1029
1030 To this end, we annotate the 'Id' of 'f' (the variable mentioned in the PRAGMA) with the
1031 inferred type of the expression.  This is slightly dodgy, as this is really the type of
1032 '$v_f' (the name of the vectorised function).
1033
1034 \begin{code}
1035 type LVectDecl name = Located (VectDecl name)
1036
1037 data VectDecl name
1038   = HsVect
1039       (Located name)
1040       (Maybe (LHsExpr name))    -- 'Nothing' => SCALAR declaration
1041   | HsNoVect
1042       (Located name)
1043   | HsVectTypeIn                -- pre type-checking
1044       (Located name)
1045       (Maybe (LHsType name))    -- 'Nothing' => SCALAR declaration
1046   | HsVectTypeOut               -- post type-checking
1047       TyCon
1048       (Maybe Type)              -- 'Nothing' => SCALAR declaration
1049   deriving (Data, Typeable)
1050
1051 lvectDeclName :: Outputable name => LVectDecl name -> name
1052 lvectDeclName (L _ (HsVect        (L _ name) _)) = name
1053 lvectDeclName (L _ (HsNoVect      (L _ name)))   = name
1054 lvectDeclName (L _ (HsVectTypeIn  (L _ name) _)) = name
1055 lvectDeclName (L _ (HsVectTypeOut name _))       = pprPanic "HsDecls.HsVectTypeOut" (ppr name)
1056
1057 instance OutputableBndr name => Outputable (VectDecl name) where
1058   ppr (HsVect v Nothing)
1059     = sep [text "{-# VECTORISE SCALAR" <+> ppr v <+> text "#-}" ]
1060   ppr (HsVect v (Just rhs))
1061     = sep [text "{-# VECTORISE" <+> ppr v,
1062            nest 4 $
1063              pprExpr (unLoc rhs) <+> text "#-}" ]
1064   ppr (HsNoVect v)
1065     = sep [text "{-# NOVECTORISE" <+> ppr v <+> text "#-}" ]
1066   ppr (HsVectTypeIn t Nothing)
1067     = sep [text "{-# VECTORISE SCALAR type" <+> ppr t <+> text "#-}" ]
1068   ppr (HsVectTypeIn t (Just ty))
1069     = sep [text "{-# VECTORISE type" <+> ppr t,
1070            nest 4 $
1071              ppr (unLoc ty) <+> text "#-}" ]
1072   ppr (HsVectTypeOut t Nothing)
1073     = sep [text "{-# VECTORISE SCALAR type" <+> ppr t <+> text "#-}" ]
1074   ppr (HsVectTypeOut t (Just ty))
1075     = sep [text "{-# VECTORISE type" <+> ppr t,
1076            nest 4 $
1077              ppr ty <+> text "#-}" ]
1078 \end{code}
1079
1080 %************************************************************************
1081 %*                                                                      *
1082 \subsection[DocDecl]{Document comments}
1083 %*                                                                      *
1084 %************************************************************************
1085
1086 \begin{code}
1087
1088 type LDocDecl = Located (DocDecl)
1089
1090 data DocDecl
1091   = DocCommentNext HsDocString
1092   | DocCommentPrev HsDocString
1093   | DocCommentNamed String HsDocString
1094   | DocGroup Int HsDocString
1095   deriving (Data, Typeable)
1096
1097 -- Okay, I need to reconstruct the document comments, but for now:
1098 instance Outputable DocDecl where
1099   ppr _ = text "<document comment>"
1100
1101 docDeclDoc :: DocDecl -> HsDocString
1102 docDeclDoc (DocCommentNext d) = d
1103 docDeclDoc (DocCommentPrev d) = d
1104 docDeclDoc (DocCommentNamed _ d) = d
1105 docDeclDoc (DocGroup _ d) = d
1106
1107 \end{code}
1108
1109 %************************************************************************
1110 %*                                                                      *
1111 \subsection[DeprecDecl]{Deprecations}
1112 %*                                                                      *
1113 %************************************************************************
1114
1115 We use exported entities for things to deprecate.
1116
1117 \begin{code}
1118 type LWarnDecl name = Located (WarnDecl name)
1119
1120 data WarnDecl name = Warning name WarningTxt
1121   deriving (Data, Typeable)
1122
1123 instance OutputableBndr name => Outputable (WarnDecl name) where
1124     ppr (Warning thing txt)
1125       = hsep [text "{-# DEPRECATED", ppr thing, doubleQuotes (ppr txt), text "#-}"]
1126 \end{code}
1127
1128 %************************************************************************
1129 %*                                                                      *
1130 \subsection[AnnDecl]{Annotations}
1131 %*                                                                      *
1132 %************************************************************************
1133
1134 \begin{code}
1135 type LAnnDecl name = Located (AnnDecl name)
1136
1137 data AnnDecl name = HsAnnotation (AnnProvenance name) (Located (HsExpr name))
1138   deriving (Data, Typeable)
1139
1140 instance (OutputableBndr name) => Outputable (AnnDecl name) where
1141     ppr (HsAnnotation provenance expr)
1142       = hsep [text "{-#", pprAnnProvenance provenance, pprExpr (unLoc expr), text "#-}"]
1143
1144
1145 data AnnProvenance name = ValueAnnProvenance name
1146                         | TypeAnnProvenance name
1147                         | ModuleAnnProvenance
1148   deriving (Data, Typeable)
1149
1150 annProvenanceName_maybe :: AnnProvenance name -> Maybe name
1151 annProvenanceName_maybe (ValueAnnProvenance name) = Just name
1152 annProvenanceName_maybe (TypeAnnProvenance name)  = Just name
1153 annProvenanceName_maybe ModuleAnnProvenance       = Nothing
1154
1155 -- TODO: Replace with Traversable instance when GHC bootstrap version rises high enough
1156 modifyAnnProvenanceNameM :: Monad m => (before -> m after) -> AnnProvenance before -> m (AnnProvenance after)
1157 modifyAnnProvenanceNameM fm prov =
1158     case prov of
1159             ValueAnnProvenance name -> liftM ValueAnnProvenance (fm name)
1160             TypeAnnProvenance name -> liftM TypeAnnProvenance (fm name)
1161             ModuleAnnProvenance -> return ModuleAnnProvenance
1162
1163 pprAnnProvenance :: OutputableBndr name => AnnProvenance name -> SDoc
1164 pprAnnProvenance ModuleAnnProvenance       = ptext (sLit "ANN module")
1165 pprAnnProvenance (ValueAnnProvenance name) = ptext (sLit "ANN") <+> ppr name
1166 pprAnnProvenance (TypeAnnProvenance name)  = ptext (sLit "ANN type") <+> ppr name
1167 \end{code}