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