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