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