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