f4e5a46bc5548a8e454d7b91eb9d7a98b89bd48e
[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 CPP #-}
8 {-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable,
9              DeriveTraversable #-}
10 {-# LANGUAGE StandaloneDeriving #-}
11 {-# LANGUAGE FlexibleContexts #-}
12 {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
13                                       -- in module PlaceHolder
14 {-# LANGUAGE ConstraintKinds #-}
15 {-# LANGUAGE FlexibleInstances #-}
16 {-# OPTIONS_GHC -fno-warn-orphans #-}
17
18 -- | Abstract syntax of global declarations.
19 --
20 -- Definitions for: @SynDecl@ and @ConDecl@, @ClassDecl@,
21 -- @InstDecl@, @DefaultDecl@ and @ForeignDecl@.
22 module HsDecls (
23   -- * Toplevel declarations
24   HsDecl(..), LHsDecl, HsDataDefn(..),
25   -- ** Class or type declarations
26   TyClDecl(..), LTyClDecl,
27   TyClGroup(..), tyClGroupConcat, mkTyClGroup,
28   isClassDecl, isDataDecl, isSynDecl, tcdName,
29   isFamilyDecl, isTypeFamilyDecl, isDataFamilyDecl,
30   isOpenTypeFamilyInfo, isClosedTypeFamilyInfo,
31   tyFamInstDeclName, tyFamInstDeclLName,
32   countTyClDecls, pprTyClDeclFlavour,
33   tyClDeclLName, tyClDeclTyVars,
34   hsDeclHasCusk, famDeclHasCusk,
35   FamilyDecl(..), LFamilyDecl,
36
37   -- ** Instance declarations
38   InstDecl(..), LInstDecl, NewOrData(..), FamilyInfo(..),
39   TyFamInstDecl(..), LTyFamInstDecl, instDeclDataFamInsts,
40   DataFamInstDecl(..), LDataFamInstDecl, pprDataFamInstFlavour,
41   TyFamEqn(..), TyFamInstEqn, LTyFamInstEqn, TyFamDefltEqn, LTyFamDefltEqn,
42   LClsInstDecl, ClsInstDecl(..),
43
44   -- ** Standalone deriving declarations
45   DerivDecl(..), LDerivDecl,
46   -- ** @RULE@ declarations
47   RuleDecl(..), LRuleDecl, RuleBndr(..),LRuleBndr,
48   collectRuleBndrSigTys,
49   -- ** @VECTORISE@ declarations
50   VectDecl(..), LVectDecl,
51   lvectDeclName, lvectInstDecl,
52   -- ** @default@ declarations
53   DefaultDecl(..), LDefaultDecl,
54   -- ** Template haskell declaration splice
55   SpliceExplicitFlag(..),
56   SpliceDecl(..), LSpliceDecl,
57   -- ** Foreign function interface declarations
58   ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..),
59   noForeignImportCoercionYet, noForeignExportCoercionYet,
60   CImportSpec(..),
61   -- ** Data-constructor declarations
62   ConDecl(..), LConDecl, ResType(..),
63   HsConDeclDetails, hsConDeclArgTys,
64   -- ** Document comments
65   DocDecl(..), LDocDecl, docDeclDoc,
66   -- ** Deprecations
67   WarnDecl(..),  LWarnDecl,
68   -- ** Annotations
69   AnnDecl(..), LAnnDecl,
70   AnnProvenance(..), annProvenanceName_maybe,
71   -- ** Role annotations
72   RoleAnnotDecl(..), LRoleAnnotDecl, roleAnnotDeclName,
73
74   -- * Grouping
75   HsGroup(..),  emptyRdrGroup, emptyRnGroup, appendGroups
76
77     ) where
78
79 -- friends:
80 import {-# SOURCE #-}   HsExpr( LHsExpr, HsExpr, HsSplice, pprExpr, pprUntypedSplice )
81         -- Because Expr imports Decls via HsBracket
82
83 import HsBinds
84 import HsPat
85 import HsTypes
86 import HsDoc
87 import TyCon
88 import Name
89 import BasicTypes
90 import Coercion
91 import ForeignCall
92 import PlaceHolder ( PostTc,PostRn,PlaceHolder(..),DataId )
93 import NameSet
94
95 -- others:
96 import InstEnv
97 import Class
98 import Outputable
99 import Util
100 import SrcLoc
101 import FastString
102
103 import Bag
104 import Data.Data        hiding (TyCon,Fixity)
105 #if __GLASGOW_HASKELL__ < 709
106 import Data.Foldable ( Foldable )
107 import Data.Traversable ( Traversable )
108 #endif
109 import Data.Maybe
110 \end{code}
111
112 %************************************************************************
113 %*                                                                      *
114 \subsection[HsDecl]{Declarations}
115 %*                                                                      *
116 %************************************************************************
117
118 \begin{code}
119 type LHsDecl id = Located (HsDecl id)
120         -- ^ When in a list this may have
121         --
122         --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi'
123         --
124
125 -- | A Haskell Declaration
126 data HsDecl id
127   = TyClD       (TyClDecl id)     -- ^ A type or class declaration.
128   | InstD       (InstDecl  id)    -- ^ An instance declaration.
129   | DerivD      (DerivDecl id)
130   | ValD        (HsBind id)
131   | SigD        (Sig id)
132   | DefD        (DefaultDecl id)
133   | ForD        (ForeignDecl id)
134   | WarningD    (WarnDecl id)
135   | AnnD        (AnnDecl id)
136   | RuleD       (RuleDecl id)
137   | VectD       (VectDecl id)
138   | SpliceD     (SpliceDecl id)
139   | DocD        (DocDecl)
140   | QuasiQuoteD (HsQuasiQuote id)
141   | RoleAnnotD  (RoleAnnotDecl id)
142   deriving (Typeable)
143 deriving instance (DataId id) => Data (HsDecl id)
144
145
146 -- NB: all top-level fixity decls are contained EITHER
147 -- EITHER SigDs
148 -- OR     in the ClassDecls in TyClDs
149 --
150 -- The former covers
151 --      a) data constructors
152 --      b) class methods (but they can be also done in the
153 --              signatures of class decls)
154 --      c) imported functions (that have an IfacSig)
155 --      d) top level decls
156 --
157 -- The latter is for class methods only
158
159 -- | A 'HsDecl' is categorised into a 'HsGroup' before being
160 -- fed to the renamer.
161 data HsGroup id
162   = HsGroup {
163         hs_valds  :: HsValBinds id,
164         hs_splcds :: [LSpliceDecl id],
165
166         hs_tyclds :: [TyClGroup id],
167                 -- A list of mutually-recursive groups
168                 -- No family-instances here; they are in hs_instds
169                 -- Parser generates a singleton list;
170                 -- renamer does dependency analysis
171
172         hs_instds  :: [LInstDecl id],
173                 -- Both class and family instance declarations in here
174
175         hs_derivds :: [LDerivDecl id],
176
177         hs_fixds  :: [LFixitySig id],
178                 -- Snaffled out of both top-level fixity signatures,
179                 -- and those in class declarations
180
181         hs_defds  :: [LDefaultDecl id],
182         hs_fords  :: [LForeignDecl id],
183         hs_warnds :: [LWarnDecl id],
184         hs_annds  :: [LAnnDecl id],
185         hs_ruleds :: [LRuleDecl id],
186         hs_vects  :: [LVectDecl id],
187
188         hs_docs   :: [LDocDecl]
189   } deriving (Typeable)
190 deriving instance (DataId id) => Data (HsGroup id)
191
192 emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup a
193 emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn }
194 emptyRnGroup  = emptyGroup { hs_valds = emptyValBindsOut }
195
196 emptyGroup = HsGroup { hs_tyclds = [], hs_instds = [],
197                        hs_derivds = [],
198                        hs_fixds = [], hs_defds = [], hs_annds = [],
199                        hs_fords = [], hs_warnds = [], hs_ruleds = [], hs_vects = [],
200                        hs_valds = error "emptyGroup hs_valds: Can't happen",
201                        hs_splcds = [],
202                        hs_docs = [] }
203
204 appendGroups :: HsGroup a -> HsGroup a -> HsGroup a
205 appendGroups
206     HsGroup {
207         hs_valds  = val_groups1,
208         hs_splcds = spliceds1,
209         hs_tyclds = tyclds1,
210         hs_instds = instds1,
211         hs_derivds = derivds1,
212         hs_fixds  = fixds1,
213         hs_defds  = defds1,
214         hs_annds  = annds1,
215         hs_fords  = fords1,
216         hs_warnds = warnds1,
217         hs_ruleds = rulds1,
218         hs_vects = vects1,
219   hs_docs   = docs1 }
220     HsGroup {
221         hs_valds  = val_groups2,
222         hs_splcds = spliceds2,
223         hs_tyclds = tyclds2,
224         hs_instds = instds2,
225         hs_derivds = derivds2,
226         hs_fixds  = fixds2,
227         hs_defds  = defds2,
228         hs_annds  = annds2,
229         hs_fords  = fords2,
230         hs_warnds = warnds2,
231         hs_ruleds = rulds2,
232         hs_vects  = vects2,
233         hs_docs   = docs2 }
234   =
235     HsGroup {
236         hs_valds  = val_groups1 `plusHsValBinds` val_groups2,
237         hs_splcds = spliceds1 ++ spliceds2,
238         hs_tyclds = tyclds1 ++ tyclds2,
239         hs_instds = instds1 ++ instds2,
240         hs_derivds = derivds1 ++ derivds2,
241         hs_fixds  = fixds1 ++ fixds2,
242         hs_annds  = annds1 ++ annds2,
243         hs_defds  = defds1 ++ defds2,
244         hs_fords  = fords1 ++ fords2,
245         hs_warnds = warnds1 ++ warnds2,
246         hs_ruleds = rulds1 ++ rulds2,
247         hs_vects  = vects1 ++ vects2,
248         hs_docs   = docs1  ++ docs2 }
249 \end{code}
250
251 \begin{code}
252 instance OutputableBndr name => Outputable (HsDecl name) where
253     ppr (TyClD dcl)             = ppr dcl
254     ppr (ValD binds)            = ppr binds
255     ppr (DefD def)              = ppr def
256     ppr (InstD inst)            = ppr inst
257     ppr (DerivD deriv)          = ppr deriv
258     ppr (ForD fd)               = ppr fd
259     ppr (SigD sd)               = ppr sd
260     ppr (RuleD rd)              = ppr rd
261     ppr (VectD vect)            = ppr vect
262     ppr (WarningD wd)           = ppr wd
263     ppr (AnnD ad)               = ppr ad
264     ppr (SpliceD dd)            = ppr dd
265     ppr (DocD doc)              = ppr doc
266     ppr (QuasiQuoteD qq)        = ppr qq
267     ppr (RoleAnnotD ra)         = ppr ra
268
269 instance OutputableBndr name => Outputable (HsGroup name) where
270     ppr (HsGroup { hs_valds  = val_decls,
271                    hs_tyclds = tycl_decls,
272                    hs_instds = inst_decls,
273                    hs_derivds = deriv_decls,
274                    hs_fixds  = fix_decls,
275                    hs_warnds = deprec_decls,
276                    hs_annds  = ann_decls,
277                    hs_fords  = foreign_decls,
278                    hs_defds  = default_decls,
279                    hs_ruleds = rule_decls,
280                    hs_vects  = vect_decls })
281         = vcat_mb empty
282             [ppr_ds fix_decls, ppr_ds default_decls,
283              ppr_ds deprec_decls, ppr_ds ann_decls,
284              ppr_ds rule_decls,
285              ppr_ds vect_decls,
286              if isEmptyValBinds val_decls
287                 then Nothing
288                 else Just (ppr val_decls),
289              ppr_ds (tyClGroupConcat tycl_decls),
290              ppr_ds inst_decls,
291              ppr_ds deriv_decls,
292              ppr_ds foreign_decls]
293         where
294           ppr_ds :: Outputable a => [a] -> Maybe SDoc
295           ppr_ds [] = Nothing
296           ppr_ds ds = Just (vcat (map ppr ds))
297
298           vcat_mb :: SDoc -> [Maybe SDoc] -> SDoc
299           -- Concatenate vertically with white-space between non-blanks
300           vcat_mb _    []             = empty
301           vcat_mb gap (Nothing : ds) = vcat_mb gap ds
302           vcat_mb gap (Just d  : ds) = gap $$ d $$ vcat_mb blankLine ds
303
304 data SpliceExplicitFlag = ExplicitSplice | -- <=> $(f x y)
305                           ImplicitSplice   -- <=> f x y,  i.e. a naked top level expression
306     deriving (Data, Typeable)
307
308 type LSpliceDecl name = Located (SpliceDecl name)
309 data SpliceDecl id
310   = SpliceDecl                  -- Top level splice
311         (Located (HsSplice id))
312         SpliceExplicitFlag
313     deriving (Typeable)
314 deriving instance (DataId id) => Data (SpliceDecl id)
315
316 instance OutputableBndr name => Outputable (SpliceDecl name) where
317    ppr (SpliceDecl (L _ e) _) = pprUntypedSplice e
318 \end{code}
319
320
321 %************************************************************************
322 %*                                                                      *
323 \subsection[SynDecl]{@data@, @newtype@ or @type@ (synonym) type declaration}
324 %*                                                                      *
325 %************************************************************************
326
327                 --------------------------------
328                         THE NAMING STORY
329                 --------------------------------
330
331 Here is the story about the implicit names that go with type, class,
332 and instance decls.  It's a bit tricky, so pay attention!
333
334 "Implicit" (or "system") binders
335 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
336   Each data type decl defines
337         a worker name for each constructor
338         to-T and from-T convertors
339   Each class decl defines
340         a tycon for the class
341         a data constructor for that tycon
342         the worker for that constructor
343         a selector for each superclass
344
345 All have occurrence names that are derived uniquely from their parent
346 declaration.
347
348 None of these get separate definitions in an interface file; they are
349 fully defined by the data or class decl.  But they may *occur* in
350 interface files, of course.  Any such occurrence must haul in the
351 relevant type or class decl.
352
353 Plan of attack:
354  - Ensure they "point to" the parent data/class decl
355    when loading that decl from an interface file
356    (See RnHiFiles.getSysBinders)
357
358  - When typechecking the decl, we build the implicit TyCons and Ids.
359    When doing so we look them up in the name cache (RnEnv.lookupSysName),
360    to ensure correct module and provenance is set
361
362 These are the two places that we have to conjure up the magic derived
363 names.  (The actual magic is in OccName.mkWorkerOcc, etc.)
364
365 Default methods
366 ~~~~~~~~~~~~~~~
367  - Occurrence name is derived uniquely from the method name
368    E.g. $dmmax
369
370  - If there is a default method name at all, it's recorded in
371    the ClassOpSig (in HsBinds), in the DefMeth field.
372    (DefMeth is defined in Class.lhs)
373
374 Source-code class decls and interface-code class decls are treated subtly
375 differently, which has given me a great deal of confusion over the years.
376 Here's the deal.  (We distinguish the two cases because source-code decls
377 have (Just binds) in the tcdMeths field, whereas interface decls have Nothing.
378
379 In *source-code* class declarations:
380
381  - When parsing, every ClassOpSig gets a DefMeth with a suitable RdrName
382    This is done by RdrHsSyn.mkClassOpSigDM
383
384  - The renamer renames it to a Name
385
386  - During typechecking, we generate a binding for each $dm for
387    which there's a programmer-supplied default method:
388         class Foo a where
389           op1 :: <type>
390           op2 :: <type>
391           op1 = ...
392    We generate a binding for $dmop1 but not for $dmop2.
393    The Class for Foo has a NoDefMeth for op2 and a DefMeth for op1.
394    The Name for $dmop2 is simply discarded.
395
396 In *interface-file* class declarations:
397   - When parsing, we see if there's an explicit programmer-supplied default method
398     because there's an '=' sign to indicate it:
399         class Foo a where
400           op1 = :: <type>       -- NB the '='
401           op2   :: <type>
402     We use this info to generate a DefMeth with a suitable RdrName for op1,
403     and a NoDefMeth for op2
404   - The interface file has a separate definition for $dmop1, with unfolding etc.
405   - The renamer renames it to a Name.
406   - The renamer treats $dmop1 as a free variable of the declaration, so that
407     the binding for $dmop1 will be sucked in.  (See RnHsSyn.tyClDeclFVs)
408     This doesn't happen for source code class decls, because they *bind* the default method.
409
410 Dictionary functions
411 ~~~~~~~~~~~~~~~~~~~~
412 Each instance declaration gives rise to one dictionary function binding.
413
414 The type checker makes up new source-code instance declarations
415 (e.g. from 'deriving' or generic default methods --- see
416 TcInstDcls.tcInstDecls1).  So we can't generate the names for
417 dictionary functions in advance (we don't know how many we need).
418
419 On the other hand for interface-file instance declarations, the decl
420 specifies the name of the dictionary function, and it has a binding elsewhere
421 in the interface file:
422         instance {Eq Int} = dEqInt
423         dEqInt :: {Eq Int} <pragma info>
424
425 So again we treat source code and interface file code slightly differently.
426
427 Source code:
428   - Source code instance decls have a Nothing in the (Maybe name) field
429     (see data InstDecl below)
430
431   - The typechecker makes up a Local name for the dict fun for any source-code
432     instance decl, whether it comes from a source-code instance decl, or whether
433     the instance decl is derived from some other construct (e.g. 'deriving').
434
435   - The occurrence name it chooses is derived from the instance decl (just for
436     documentation really) --- e.g. dNumInt.  Two dict funs may share a common
437     occurrence name, but will have different uniques.  E.g.
438         instance Foo [Int]  where ...
439         instance Foo [Bool] where ...
440     These might both be dFooList
441
442   - The CoreTidy phase externalises the name, and ensures the occurrence name is
443     unique (this isn't special to dict funs).  So we'd get dFooList and dFooList1.
444
445   - We can take this relaxed approach (changing the occurrence name later)
446     because dict fun Ids are not captured in a TyCon or Class (unlike default
447     methods, say).  Instead, they are kept separately in the InstEnv.  This
448     makes it easy to adjust them after compiling a module.  (Once we've finished
449     compiling that module, they don't change any more.)
450
451
452 Interface file code:
453   - The instance decl gives the dict fun name, so the InstDecl has a (Just name)
454     in the (Maybe name) field.
455
456   - RnHsSyn.instDeclFVs treats the dict fun name as free in the decl, so that we
457     suck in the dfun binding
458
459
460 \begin{code}
461 type LTyClDecl name = Located (TyClDecl name)
462
463 -- | A type or class declaration.
464 data TyClDecl name
465   = -- | @type/data family T :: *->*@
466     --
467     --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType',
468     --             'ApiAnnotation.AnnData',
469     --             'ApiAnnotation.AnnFamily','ApiAnnotation.AnnWhere',
470     --             'ApiAnnotation.AnnOpen','ApiAnnotation.AnnDcolon',
471     --             'ApiAnnotation.AnnClose'
472
473     FamDecl { tcdFam :: FamilyDecl name }
474
475   | -- | @type@ declaration
476     --
477     --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType',
478     --             'ApiAnnotation.AnnEqual',
479     SynDecl { tcdLName  :: Located name            -- ^ Type constructor
480             , tcdTyVars :: LHsTyVarBndrs name      -- ^ Type variables; for an associated type
481                                                   --   these include outer binders
482             , tcdRhs    :: LHsType name            -- ^ RHS of type declaration
483             , tcdFVs    :: PostRn name NameSet }
484
485   | -- | @data@ declaration
486     --
487     --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnData',
488     --              'ApiAnnotation.AnnFamily',
489     --              'ApiAnnotation.AnnNewType',
490     --              'ApiAnnotation.AnnNewType','ApiAnnotation.AnnWhere'
491     DataDecl { tcdLName    :: Located name        -- ^ Type constructor
492              , tcdTyVars   :: LHsTyVarBndrs name  -- ^ Type variables; for an assoicated type
493                                                   --   these include outer binders
494                                                   -- Eg  class T a where
495                                                   --       type F a :: *
496                                                   --       type F a = a -> a
497                                                   -- Here the type decl for 'f' includes 'a'
498                                                   -- in its tcdTyVars
499              , tcdDataDefn :: HsDataDefn name
500              , tcdFVs      :: PostRn name NameSet }
501
502   | ClassDecl { tcdCtxt    :: LHsContext name,          -- ^ Context...
503                 tcdLName   :: Located name,             -- ^ Name of the class
504                 tcdTyVars  :: LHsTyVarBndrs name,       -- ^ Class type variables
505                 tcdFDs     :: [Located (FunDep name)],  -- ^ Functional deps
506                 tcdSigs    :: [LSig name],              -- ^ Methods' signatures
507                 tcdMeths   :: LHsBinds name,            -- ^ Default methods
508                 tcdATs     :: [LFamilyDecl name],       -- ^ Associated types; ie
509                 tcdATDefs  :: [LTyFamDefltEqn name],    -- ^ Associated type defaults
510                 tcdDocs    :: [LDocDecl],               -- ^ Haddock docs
511                 tcdFVs     :: PostRn name NameSet
512     }
513         -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnClass',
514         --           'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpen',
515         --           'ApiAnnotation.AnnClose'
516         --   - The tcdFDs will have 'ApiAnnotation.AnnVbar',
517         --                          'ApiAnnotation.AnnComma'
518         --                          'ApiAnnotation.AnnRarrow'
519
520   deriving (Typeable)
521 deriving instance (DataId id) => Data (TyClDecl id)
522
523  -- This is used in TcTyClsDecls to represent
524  -- strongly connected components of decls
525  -- No familiy instances in here
526  -- The role annotations must be grouped with their decls for the
527  -- type-checker to infer roles correctly
528 data TyClGroup name
529   = TyClGroup { group_tyclds :: [LTyClDecl name]
530               , group_roles  :: [LRoleAnnotDecl name] }
531     deriving (Typeable)
532 deriving instance (DataId id) => Data (TyClGroup id)
533
534 tyClGroupConcat :: [TyClGroup name] -> [LTyClDecl name]
535 tyClGroupConcat = concatMap group_tyclds
536
537 mkTyClGroup :: [LTyClDecl name] -> TyClGroup name
538 mkTyClGroup decls = TyClGroup { group_tyclds = decls, group_roles = [] }
539
540 type LFamilyDecl name = Located (FamilyDecl name)
541 data FamilyDecl name = FamilyDecl
542   { fdInfo    :: FamilyInfo name            -- type or data, closed or open
543   , fdLName   :: Located name               -- type constructor
544   , fdTyVars  :: LHsTyVarBndrs name         -- type variables
545   , fdKindSig :: Maybe (LHsKind name) }     -- result kind
546   deriving( Typeable )
547 deriving instance (DataId id) => Data (FamilyDecl id)
548
549 data FamilyInfo name
550   = DataFamily
551   | OpenTypeFamily
552      -- this list might be empty, if we're in an hs-boot file and the user
553      -- said "type family Foo x where .."
554   | ClosedTypeFamily [LTyFamInstEqn name]
555   deriving( Typeable )
556 deriving instance (DataId name) => Data (FamilyInfo name)
557
558 \end{code}
559
560 ------------------------------
561 Simple classifiers
562
563 \begin{code}
564 -- | @True@ <=> argument is a @data@\/@newtype@
565 -- declaration.
566 isDataDecl :: TyClDecl name -> Bool
567 isDataDecl (DataDecl {}) = True
568 isDataDecl _other        = False
569
570 -- | type or type instance declaration
571 isSynDecl :: TyClDecl name -> Bool
572 isSynDecl (SynDecl {})   = True
573 isSynDecl _other        = False
574
575 -- | type class
576 isClassDecl :: TyClDecl name -> Bool
577 isClassDecl (ClassDecl {}) = True
578 isClassDecl _              = False
579
580 -- | type/data family declaration
581 isFamilyDecl :: TyClDecl name -> Bool
582 isFamilyDecl (FamDecl {})  = True
583 isFamilyDecl _other        = False
584
585 -- | type family declaration
586 isTypeFamilyDecl :: TyClDecl name -> Bool
587 isTypeFamilyDecl (FamDecl (FamilyDecl { fdInfo = info })) = case info of
588   OpenTypeFamily      -> True
589   ClosedTypeFamily {} -> True
590   _                   -> False
591 isTypeFamilyDecl _ = False
592
593 -- | open type family info
594 isOpenTypeFamilyInfo :: FamilyInfo name -> Bool
595 isOpenTypeFamilyInfo OpenTypeFamily = True
596 isOpenTypeFamilyInfo _              = False
597
598 -- | closed type family info
599 isClosedTypeFamilyInfo :: FamilyInfo name -> Bool
600 isClosedTypeFamilyInfo (ClosedTypeFamily {}) = True
601 isClosedTypeFamilyInfo _                     = False
602
603 -- | data family declaration
604 isDataFamilyDecl :: TyClDecl name -> Bool
605 isDataFamilyDecl (FamDecl (FamilyDecl { fdInfo = DataFamily })) = True
606 isDataFamilyDecl _other      = False
607
608 \end{code}
609
610 Dealing with names
611
612 \begin{code}
613 tyFamInstDeclName :: OutputableBndr name
614                   => TyFamInstDecl name -> name
615 tyFamInstDeclName = unLoc . tyFamInstDeclLName
616
617 tyFamInstDeclLName :: OutputableBndr name
618                    => TyFamInstDecl name -> Located name
619 tyFamInstDeclLName (TyFamInstDecl { tfid_eqn =
620                      (L _ (TyFamEqn { tfe_tycon = ln })) })
621   = ln
622
623 tyClDeclLName :: TyClDecl name -> Located name
624 tyClDeclLName (FamDecl { tcdFam = FamilyDecl { fdLName = ln } }) = ln
625 tyClDeclLName decl = tcdLName decl
626
627 tcdName :: TyClDecl name -> name
628 tcdName = unLoc . tyClDeclLName
629
630 tyClDeclTyVars :: OutputableBndr name => TyClDecl name -> LHsTyVarBndrs name
631 tyClDeclTyVars (FamDecl { tcdFam = FamilyDecl { fdTyVars = tvs } }) = tvs
632 tyClDeclTyVars d = tcdTyVars d
633 \end{code}
634
635 \begin{code}
636 countTyClDecls :: [TyClDecl name] -> (Int, Int, Int, Int, Int)
637         -- class, synonym decls, data, newtype, family decls
638 countTyClDecls decls
639  = (count isClassDecl    decls,
640     count isSynDecl      decls,  -- excluding...
641     count isDataTy       decls,  -- ...family...
642     count isNewTy        decls,  -- ...instances
643     count isFamilyDecl   decls)
644  where
645    isDataTy DataDecl{ tcdDataDefn = HsDataDefn { dd_ND = DataType } } = True
646    isDataTy _                                                       = False
647
648    isNewTy DataDecl{ tcdDataDefn = HsDataDefn { dd_ND = NewType } } = True
649    isNewTy _                                                      = False
650
651 -- | Does this declaration have a complete, user-supplied kind signature?
652 -- See Note [Complete user-supplied kind signatures]
653 hsDeclHasCusk :: TyClDecl name -> Bool
654 hsDeclHasCusk (FamDecl { tcdFam = fam_decl }) = famDeclHasCusk fam_decl
655 hsDeclHasCusk (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs })
656   = hsTvbAllKinded tyvars && rhs_annotated rhs
657   where
658     rhs_annotated (L _ ty) = case ty of
659       HsParTy lty  -> rhs_annotated lty
660       HsKindSig {} -> True
661       _            -> False
662 hsDeclHasCusk (DataDecl { tcdTyVars = tyvars })  = hsTvbAllKinded tyvars
663 hsDeclHasCusk (ClassDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars
664
665 -- | Does this family declaration have a complete, user-supplied kind signature?
666 famDeclHasCusk :: FamilyDecl name -> Bool
667 famDeclHasCusk (FamilyDecl { fdInfo = ClosedTypeFamily _
668                            , fdTyVars = tyvars
669                            , fdKindSig = m_sig })
670   = hsTvbAllKinded tyvars && isJust m_sig
671 famDeclHasCusk _ = True  -- all open families have CUSKs!
672 \end{code}
673
674 Note [Complete user-supplied kind signatures]
675 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
676 We kind-check declarations differently if they have a complete, user-supplied
677 kind signature (CUSK). This is because we can safely generalise a CUSKed
678 declaration before checking all of the others, supporting polymorphic recursion.
679 See https://ghc.haskell.org/trac/ghc/wiki/GhcKinds/KindInference#Proposednewstrategy
680 and #9200 for lots of discussion of how we got here.
681
682 A declaration has a CUSK if we can know its complete kind without doing any inference,
683 at all. Here are the rules:
684
685  - A class or datatype is said to have a CUSK if and only if all of its type
686 variables are annotated. Its result kind is, by construction, Constraint or *
687 respectively.
688
689  - A type synonym has a CUSK if and only if all of its type variables and its
690 RHS are annotated with kinds.
691
692  - A closed type family is said to have a CUSK if and only if all of its type
693 variables and its return type are annotated.
694
695  - An open type family always has a CUSK -- unannotated type variables (and return type) default to *.
696
697 \begin{code}
698 instance OutputableBndr name
699               => Outputable (TyClDecl name) where
700
701     ppr (FamDecl { tcdFam = decl }) = ppr decl
702     ppr (SynDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdRhs = rhs })
703       = hang (ptext (sLit "type") <+>
704               pp_vanilla_decl_head ltycon tyvars [] <+> equals)
705           4 (ppr rhs)
706
707     ppr (DataDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdDataDefn = defn })
708       = pp_data_defn (pp_vanilla_decl_head ltycon tyvars) defn
709
710     ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars,
711                     tcdFDs  = fds,
712                     tcdSigs = sigs, tcdMeths = methods,
713                     tcdATs = ats, tcdATDefs = at_defs})
714       | null sigs && isEmptyBag methods && null ats && null at_defs -- No "where" part
715       = top_matter
716
717       | otherwise       -- Laid out
718       = vcat [ top_matter <+> ptext (sLit "where")
719              , nest 2 $ pprDeclList (map ppr ats ++
720                                      map ppr_fam_deflt_eqn at_defs ++
721                                      pprLHsBindsForUser methods sigs) ]
722       where
723         top_matter = ptext (sLit "class")
724                      <+> pp_vanilla_decl_head lclas tyvars (unLoc context)
725                      <+> pprFundeps (map unLoc fds)
726
727 instance OutputableBndr name => Outputable (TyClGroup name) where
728   ppr (TyClGroup { group_tyclds = tyclds, group_roles = roles })
729     = ppr tyclds $$
730       ppr roles
731
732 instance (OutputableBndr name) => Outputable (FamilyDecl name) where
733   ppr (FamilyDecl { fdInfo = info, fdLName = ltycon,
734                     fdTyVars = tyvars, fdKindSig = mb_kind})
735       = vcat [ pprFlavour info <+> pp_vanilla_decl_head ltycon tyvars [] <+> pp_kind <+> pp_where
736              , nest 2 $ pp_eqns ]
737         where
738           pp_kind = case mb_kind of
739                       Nothing   -> empty
740                       Just kind -> dcolon <+> ppr kind
741           (pp_where, pp_eqns) = case info of
742             ClosedTypeFamily eqns -> ( ptext (sLit "where")
743                                      , if null eqns
744                                        then ptext (sLit "..")
745                                        else vcat $ map ppr_fam_inst_eqn eqns )
746             _                     -> (empty, empty)
747
748 pprFlavour :: FamilyInfo name -> SDoc
749 pprFlavour DataFamily            = ptext (sLit "data family")
750 pprFlavour OpenTypeFamily        = ptext (sLit "type family")
751 pprFlavour (ClosedTypeFamily {}) = ptext (sLit "type family")
752
753 instance Outputable (FamilyInfo name) where
754   ppr = pprFlavour
755
756 pp_vanilla_decl_head :: OutputableBndr name
757    => Located name
758    -> LHsTyVarBndrs name
759    -> HsContext name
760    -> SDoc
761 pp_vanilla_decl_head thing tyvars context
762  = hsep [pprHsContext context, pprPrefixOcc (unLoc thing), ppr tyvars]
763
764 pp_fam_inst_lhs :: OutputableBndr name
765    => Located name
766    -> HsTyPats name
767    -> HsContext name
768    -> SDoc
769 pp_fam_inst_lhs thing (HsWB { hswb_cts = typats }) context -- explicit type patterns
770    = hsep [ pprHsContext context, pprPrefixOcc (unLoc thing)
771           , hsep (map (pprParendHsType.unLoc) typats)]
772
773 pprTyClDeclFlavour :: TyClDecl a -> SDoc
774 pprTyClDeclFlavour (ClassDecl {})   = ptext (sLit "class")
775 pprTyClDeclFlavour (SynDecl {})     = ptext (sLit "type")
776 pprTyClDeclFlavour (FamDecl { tcdFam = FamilyDecl { fdInfo = info }})
777   = pprFlavour info
778 pprTyClDeclFlavour (DataDecl { tcdDataDefn = HsDataDefn { dd_ND = nd } })
779   = ppr nd
780 \end{code}
781
782 %************************************************************************
783 %*                                                                      *
784 \subsection[ConDecl]{A data-constructor declaration}
785 %*                                                                      *
786 %************************************************************************
787
788 \begin{code}
789
790 data HsDataDefn name   -- The payload of a data type defn
791                        -- Used *both* for vanilla data declarations,
792                        --       *and* for data family instances
793   = -- | Declares a data type or newtype, giving its constructors
794     -- @
795     --  data/newtype T a = <constrs>
796     --  data/newtype instance T [a] = <constrs>
797     -- @
798     HsDataDefn { dd_ND     :: NewOrData,
799                  dd_ctxt   :: LHsContext name,           -- ^ Context
800                  dd_cType  :: Maybe (Located CType),
801                  dd_kindSig:: Maybe (LHsKind name),
802                      -- ^ Optional kind signature.
803                      --
804                      -- @(Just k)@ for a GADT-style @data@,
805                      -- or @data instance@ decl, with explicit kind sig
806                      --
807                      -- Always @Nothing@ for H98-syntax decls
808
809                  dd_cons   :: [LConDecl name],
810                      -- ^ Data constructors
811                      --
812                      -- For @data T a = T1 | T2 a@
813                      --   the 'LConDecl's all have 'ResTyH98'.
814                      -- For @data T a where { T1 :: T a }@
815                      --   the 'LConDecls' all have 'ResTyGADT'.
816
817                  dd_derivs :: Maybe (Located [LHsType name])
818                      -- ^ Derivings; @Nothing@ => not specified,
819                      --              @Just []@ => derive exactly what is asked
820                      --
821                      -- These "types" must be of form
822                      -- @
823                      --      forall ab. C ty1 ty2
824                      -- @
825                      -- Typically the foralls and ty args are empty, but they
826                      -- are non-empty for the newtype-deriving case
827                      --
828                      --  - 'ApiAnnotation.AnnKeywordId' :
829                      --       'ApiAnnotation.AnnDeriving',
830                      --       'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose'
831    }
832     deriving( Typeable )
833 deriving instance (DataId id) => Data (HsDataDefn id)
834
835 data NewOrData
836   = NewType                     -- ^ @newtype Blah ...@
837   | DataType                    -- ^ @data Blah ...@
838   deriving( Eq, Data, Typeable )                -- Needed because Demand derives Eq
839
840 type LConDecl name = Located (ConDecl name)
841       -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when
842       --   in a GADT constructor list
843
844 -- |
845 --
846 -- @
847 -- data T b = forall a. Eq a => MkT a b
848 --   MkT :: forall b a. Eq a => MkT a b
849 --
850 -- data T b where
851 --      MkT1 :: Int -> T Int
852 --
853 -- data T = Int `MkT` Int
854 --        | MkT2
855 --
856 -- data T a where
857 --      Int `MkT` Int :: T Int
858 -- @
859 --
860 -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen',
861 --            'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnCLose',
862 --            'ApiAnnotation.AnnEqual','ApiAnnotation.AnnVbar',
863 --            'ApiAnnotation.AnnDarrow','ApiAnnotation.AnnDarrow',
864 --            'ApiAnnotation.AnnForall','ApiAnnotation.AnnDot'
865 data ConDecl name
866   = ConDecl
867     { con_names     :: [Located name]
868         -- ^ Constructor names.  This is used for the DataCon itself, and for
869         -- the user-callable wrapper Id.
870         -- It is a list to deal with GADT constructors of the form
871         --   T1, T2, T3 :: <payload>
872     , con_explicit  :: HsExplicitFlag
873         -- ^ Is there an user-written forall? (cf. 'HsTypes.HsForAllTy')
874
875     , con_qvars     :: LHsTyVarBndrs name
876         -- ^ Type variables.  Depending on 'con_res' this describes the
877         -- following entities
878         --
879         --  - ResTyH98:  the constructor's *existential* type variables
880         --  - ResTyGADT: *all* the constructor's quantified type variables
881         --
882         -- If con_explicit is Implicit, then con_qvars is irrelevant
883         -- until after renaming.
884
885     , con_cxt       :: LHsContext name
886         -- ^ The context.  This /does not/ include the \"stupid theta\" which
887         -- lives only in the 'TyData' decl.
888
889     , con_details   :: HsConDeclDetails name
890         -- ^ The main payload
891
892     , con_res       :: ResType (LHsType name)
893         -- ^ Result type of the constructor
894
895     , con_doc       :: Maybe LHsDocString
896         -- ^ A possible Haddock comment.
897
898     , con_old_rec :: Bool
899         -- ^ TEMPORARY field; True <=> user has employed now-deprecated syntax for
900         --                             GADT-style record decl   C { blah } :: T a b
901         -- Remove this when we no longer parse this stuff, and hence do not
902         -- need to report decprecated use
903     } deriving (Typeable)
904 deriving instance (DataId name) => Data (ConDecl name)
905
906 type HsConDeclDetails name = HsConDetails (LBangType name) [LConDeclField name]
907
908 hsConDeclArgTys :: HsConDeclDetails name -> [LBangType name]
909 hsConDeclArgTys (PrefixCon tys)    = tys
910 hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2]
911 hsConDeclArgTys (RecCon flds)      = map (cd_fld_type . unLoc) flds
912
913 data ResType ty
914    = ResTyH98           -- Constructor was declared using Haskell 98 syntax
915    | ResTyGADT ty       -- Constructor was declared using GADT-style syntax,
916                         --      and here is its result type
917    deriving (Data, Typeable)
918
919 instance Outputable ty => Outputable (ResType ty) where
920          -- Debugging only
921    ppr ResTyH98       = ptext (sLit "ResTyH98")
922    ppr (ResTyGADT ty) = ptext (sLit "ResTyGADT") <+> ppr ty
923 \end{code}
924
925
926 \begin{code}
927 pp_data_defn :: OutputableBndr name
928                   => (HsContext name -> SDoc)   -- Printing the header
929                   -> HsDataDefn name
930                   -> SDoc
931 pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = L _ context
932                                 , dd_kindSig = mb_sig
933                                 , dd_cons = condecls, dd_derivs = derivings })
934   | null condecls
935   = ppr new_or_data <+> pp_hdr context <+> pp_sig
936
937   | otherwise
938   = hang (ppr new_or_data <+> pp_hdr context <+> pp_sig)
939        2 (pp_condecls condecls $$ pp_derivings)
940   where
941     pp_sig = case mb_sig of
942                Nothing   -> empty
943                Just kind -> dcolon <+> ppr kind
944     pp_derivings = case derivings of
945                      Nothing       -> empty
946                      Just (L _ ds) -> hsep [ptext (sLit "deriving"),
947                                             parens (interpp'SP ds)]
948
949 instance OutputableBndr name => Outputable (HsDataDefn name) where
950    ppr d = pp_data_defn (\_ -> ptext (sLit "Naked HsDataDefn")) d
951
952 instance Outputable NewOrData where
953   ppr NewType  = ptext (sLit "newtype")
954   ppr DataType = ptext (sLit "data")
955
956 pp_condecls :: OutputableBndr name => [LConDecl name] -> SDoc
957 pp_condecls cs@(L _ ConDecl{ con_res = ResTyGADT _ } : _) -- In GADT syntax
958   = hang (ptext (sLit "where")) 2 (vcat (map ppr cs))
959 pp_condecls cs                    -- In H98 syntax
960   = equals <+> sep (punctuate (ptext (sLit " |")) (map ppr cs))
961
962 instance (OutputableBndr name) => Outputable (ConDecl name) where
963     ppr = pprConDecl
964
965 pprConDecl :: OutputableBndr name => ConDecl name -> SDoc
966 pprConDecl (ConDecl { con_names = cons, con_explicit = expl, con_qvars = tvs
967                     , con_cxt = cxt, con_details = details
968                     , con_res = ResTyH98, con_doc = doc })
969   = sep [ppr_mbDoc doc, pprHsForAll expl tvs cxt, ppr_details details]
970   where
971     ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprInfixOcc cons, ppr t2]
972     ppr_details (PrefixCon tys)  = hsep (pprPrefixOcc cons
973                                    : map (pprParendHsType . unLoc) tys)
974     ppr_details (RecCon fields)  = ppr_con_names cons
975                                  <+> pprConDeclFields fields
976
977 pprConDecl (ConDecl { con_names = cons, con_explicit = expl, con_qvars = tvs
978                     , con_cxt = cxt, con_details = PrefixCon arg_tys
979                     , con_res = ResTyGADT res_ty })
980   = ppr_con_names cons <+> dcolon <+>
981     sep [pprHsForAll expl tvs cxt, ppr (foldr mk_fun_ty res_ty arg_tys)]
982   where
983     mk_fun_ty a b = noLoc (HsFunTy a b)
984
985 pprConDecl (ConDecl { con_names = cons, con_explicit = expl, con_qvars = tvs
986                     , con_cxt = cxt, con_details = RecCon fields, con_res = ResTyGADT res_ty })
987   = sep [ppr_con_names cons <+> dcolon <+> pprHsForAll expl tvs cxt,
988          pprConDeclFields fields <+> arrow <+> ppr res_ty]
989
990 pprConDecl decl@(ConDecl { con_details = InfixCon ty1 ty2, con_res = ResTyGADT {} })
991   = pprConDecl (decl { con_details = PrefixCon [ty1,ty2] })
992         -- In GADT syntax we don't allow infix constructors
993         -- so if we ever trip over one (albeit I can't see how that
994         -- can happen) print it like a prefix one
995
996 ppr_con_names :: (OutputableBndr name) => [Located name] -> SDoc
997 ppr_con_names [x] = ppr x
998 ppr_con_names xs  = interpp'SP xs
999
1000 instance (Outputable name) => OutputableBndr [Located name] where
1001   pprBndr _bs xs = cat $ punctuate comma (map ppr xs)
1002
1003   pprPrefixOcc [x] = ppr x
1004   pprPrefixOcc xs  = cat $ punctuate comma (map ppr xs)
1005
1006   pprInfixOcc [x] = ppr x
1007   pprInfixOcc xs  = cat $ punctuate comma (map ppr xs)
1008 \end{code}
1009
1010 %************************************************************************
1011 %*                                                                      *
1012                 Instance declarations
1013 %*                                                                      *
1014 %************************************************************************
1015
1016 Note [Type family instance declarations in HsSyn]
1017 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1018 The data type TyFamEqn represents one equation of a type family instance.
1019 It is parameterised over its tfe_pats field:
1020
1021  * An ordinary type family instance declaration looks like this in source Haskell
1022       type instance T [a] Int = a -> a
1023    (or something similar for a closed family)
1024    It is represented by a TyFamInstEqn, with *type* in the tfe_pats field.
1025
1026  * On the other hand, the *default instance* of an associated type looksl like
1027    this in source Haskell
1028       class C a where
1029         type T a b
1030         type T a b = a -> b   -- The default instance
1031    It is represented by a TyFamDefltEqn, with *type variables8 in the tfe_pats field.
1032
1033 \begin{code}
1034 ----------------- Type synonym family instances -------------
1035 type LTyFamInstEqn  name = Located (TyFamInstEqn  name)
1036   -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi'
1037   --   when in a list
1038 type LTyFamDefltEqn name = Located (TyFamDefltEqn name)
1039
1040 type HsTyPats name = HsWithBndrs name [LHsType name]
1041             -- ^ Type patterns (with kind and type bndrs)
1042             -- See Note [Family instance declaration binders]
1043
1044 type TyFamInstEqn  name = TyFamEqn name (HsTyPats name)
1045 type TyFamDefltEqn name = TyFamEqn name (LHsTyVarBndrs name)
1046   -- See Note [Type family instance declarations in HsSyn]
1047
1048 -- | One equation in a type family instance declaration
1049 -- See Note [Type family instance declarations in HsSyn]
1050 data TyFamEqn name pats
1051   = TyFamEqn
1052        { tfe_tycon :: Located name
1053        , tfe_pats  :: pats
1054        , tfe_rhs   :: LHsType name }
1055     -- ^
1056     --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual'
1057   deriving( Typeable )
1058 deriving instance (DataId name, Data pats) => Data (TyFamEqn name pats)
1059
1060 type LTyFamInstDecl name = Located (TyFamInstDecl name)
1061 data TyFamInstDecl name
1062   = TyFamInstDecl
1063        { tfid_eqn  :: LTyFamInstEqn name
1064        , tfid_fvs  :: PostRn name NameSet }
1065     -- ^
1066     --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType',
1067     --           'ApiAnnotation.AnnInstance',
1068   deriving( Typeable )
1069 deriving instance (DataId name) => Data (TyFamInstDecl name)
1070
1071 ----------------- Data family instances -------------
1072
1073 type LDataFamInstDecl name = Located (DataFamInstDecl name)
1074 data DataFamInstDecl name
1075   = DataFamInstDecl
1076        { dfid_tycon :: Located name
1077        , dfid_pats  :: HsTyPats name      -- LHS
1078        , dfid_defn  :: HsDataDefn  name   -- RHS
1079        , dfid_fvs   :: PostRn name NameSet } -- Free vars for
1080                                              -- dependency analysis
1081     -- ^
1082     --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnData',
1083     --           'ApiAnnotation.AnnNewType','ApiAnnotation.AnnInstance',
1084     --           'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpen',
1085     --           'ApiAnnotation.AnnClose'
1086   deriving( Typeable )
1087 deriving instance (DataId name) => Data (DataFamInstDecl name)
1088
1089
1090 ----------------- Class instances -------------
1091
1092 type LClsInstDecl name = Located (ClsInstDecl name)
1093 data ClsInstDecl name
1094   = ClsInstDecl
1095       { cid_poly_ty :: LHsType name    -- Context => Class Instance-type
1096                                        -- Using a polytype means that the renamer conveniently
1097                                        -- figures out the quantified type variables for us.
1098       , cid_binds         :: LHsBinds name           -- Class methods
1099       , cid_sigs          :: [LSig name]             -- User-supplied pragmatic info
1100       , cid_tyfam_insts   :: [LTyFamInstDecl name]   -- Type family instances
1101       , cid_datafam_insts :: [LDataFamInstDecl name] -- Data family instances
1102       , cid_overlap_mode  :: Maybe (Located OverlapMode)
1103          -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
1104          --                                    'ApiAnnotation.AnnClose',
1105
1106       }
1107     -- ^
1108     --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnInstance',
1109     --           'ApiAnnotation.AnnWhere',
1110     --           'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose',
1111     --
1112   deriving (Typeable)
1113 deriving instance (DataId id) => Data (ClsInstDecl id)
1114
1115
1116 ----------------- Instances of all kinds -------------
1117
1118 type LInstDecl name = Located (InstDecl name)
1119 data InstDecl name  -- Both class and family instances
1120   = ClsInstD
1121       { cid_inst  :: ClsInstDecl name }
1122   | DataFamInstD              -- data family instance
1123       { dfid_inst :: DataFamInstDecl name }
1124   | TyFamInstD              -- type family instance
1125       { tfid_inst :: TyFamInstDecl name }
1126   deriving (Typeable)
1127 deriving instance (DataId id) => Data (InstDecl id)
1128 \end{code}
1129
1130 Note [Family instance declaration binders]
1131 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1132 A {Ty|Data}FamInstDecl is a data/type family instance declaration
1133 the pats field is LHS patterns, and the tvs of the HsBSig
1134 tvs are fv(pat_tys), *including* ones that are already in scope
1135
1136    Eg   class C s t where
1137           type F t p :: *
1138         instance C w (a,b) where
1139           type F (a,b) x = x->a
1140    The tcdTyVars of the F decl are {a,b,x}, even though the F decl
1141    is nested inside the 'instance' decl.
1142
1143    However after the renamer, the uniques will match up:
1144         instance C w7 (a8,b9) where
1145           type F (a8,b9) x10 = x10->a8
1146    so that we can compare the type patter in the 'instance' decl and
1147    in the associated 'type' decl
1148
1149 \begin{code}
1150 instance (OutputableBndr name) => Outputable (TyFamInstDecl name) where
1151   ppr = pprTyFamInstDecl TopLevel
1152
1153 pprTyFamInstDecl :: OutputableBndr name => TopLevelFlag -> TyFamInstDecl name -> SDoc
1154 pprTyFamInstDecl top_lvl (TyFamInstDecl { tfid_eqn = eqn })
1155    = ptext (sLit "type") <+> ppr_instance_keyword top_lvl <+> ppr_fam_inst_eqn eqn
1156
1157 ppr_instance_keyword :: TopLevelFlag -> SDoc
1158 ppr_instance_keyword TopLevel    = ptext (sLit "instance")
1159 ppr_instance_keyword NotTopLevel = empty
1160
1161 ppr_fam_inst_eqn :: OutputableBndr name => LTyFamInstEqn name -> SDoc
1162 ppr_fam_inst_eqn (L _ (TyFamEqn { tfe_tycon = tycon
1163                                 , tfe_pats  = pats
1164                                 , tfe_rhs   = rhs }))
1165     = pp_fam_inst_lhs tycon pats [] <+> equals <+> ppr rhs
1166
1167 ppr_fam_deflt_eqn :: OutputableBndr name => LTyFamDefltEqn name -> SDoc
1168 ppr_fam_deflt_eqn (L _ (TyFamEqn { tfe_tycon = tycon
1169                                  , tfe_pats  = tvs
1170                                  , tfe_rhs   = rhs }))
1171     = pp_vanilla_decl_head tycon tvs [] <+> equals <+> ppr rhs
1172
1173 instance (OutputableBndr name) => Outputable (DataFamInstDecl name) where
1174   ppr = pprDataFamInstDecl TopLevel
1175
1176 pprDataFamInstDecl :: OutputableBndr name => TopLevelFlag -> DataFamInstDecl name -> SDoc
1177 pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_tycon = tycon
1178                                             , dfid_pats  = pats
1179                                             , dfid_defn  = defn })
1180   = pp_data_defn pp_hdr defn
1181   where
1182     pp_hdr ctxt = ppr_instance_keyword top_lvl <+> pp_fam_inst_lhs tycon pats ctxt
1183
1184 pprDataFamInstFlavour :: DataFamInstDecl name -> SDoc
1185 pprDataFamInstFlavour (DataFamInstDecl { dfid_defn = (HsDataDefn { dd_ND = nd }) })
1186   = ppr nd
1187
1188 instance (OutputableBndr name) => Outputable (ClsInstDecl name) where
1189     ppr (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = binds
1190                      , cid_sigs = sigs, cid_tyfam_insts = ats
1191                      , cid_overlap_mode = mbOverlap
1192                      , cid_datafam_insts = adts })
1193       | null sigs, null ats, null adts, isEmptyBag binds  -- No "where" part
1194       = top_matter
1195
1196       | otherwise       -- Laid out
1197       = vcat [ top_matter <+> ptext (sLit "where")
1198              , nest 2 $ pprDeclList $
1199                map (pprTyFamInstDecl NotTopLevel . unLoc)   ats ++
1200                map (pprDataFamInstDecl NotTopLevel . unLoc) adts ++
1201                pprLHsBindsForUser binds sigs ]
1202       where
1203         top_matter = ptext (sLit "instance") <+> ppOverlapPragma mbOverlap
1204                                              <+> ppr inst_ty
1205
1206 ppOverlapPragma :: Maybe (Located OverlapMode) -> SDoc
1207 ppOverlapPragma mb =
1208   case mb of
1209     Nothing           -> empty
1210     Just (L _ NoOverlap)    -> ptext (sLit "{-# NO_OVERLAP #-}")
1211     Just (L _ Overlappable) -> ptext (sLit "{-# OVERLAPPABLE #-}")
1212     Just (L _ Overlapping)  -> ptext (sLit "{-# OVERLAPPING #-}")
1213     Just (L _ Overlaps)     -> ptext (sLit "{-# OVERLAPS #-}")
1214     Just (L _ Incoherent)   -> ptext (sLit "{-# INCOHERENT #-}")
1215
1216
1217
1218
1219 instance (OutputableBndr name) => Outputable (InstDecl name) where
1220     ppr (ClsInstD     { cid_inst  = decl }) = ppr decl
1221     ppr (TyFamInstD   { tfid_inst = decl }) = ppr decl
1222     ppr (DataFamInstD { dfid_inst = decl }) = ppr decl
1223
1224 -- Extract the declarations of associated data types from an instance
1225
1226 instDeclDataFamInsts :: [LInstDecl name] -> [DataFamInstDecl name]
1227 instDeclDataFamInsts inst_decls
1228   = concatMap do_one inst_decls
1229   where
1230     do_one (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fam_insts } }))
1231       = map unLoc fam_insts
1232     do_one (L _ (DataFamInstD { dfid_inst = fam_inst }))      = [fam_inst]
1233     do_one (L _ (TyFamInstD {}))                              = []
1234 \end{code}
1235
1236 %************************************************************************
1237 %*                                                                      *
1238 \subsection[DerivDecl]{A stand-alone instance deriving declaration}
1239 %*                                                                      *
1240 %************************************************************************
1241
1242 \begin{code}
1243 type LDerivDecl name = Located (DerivDecl name)
1244
1245 data DerivDecl name = DerivDecl
1246         { deriv_type :: LHsType name
1247         , deriv_overlap_mode :: Maybe (Located OverlapMode)
1248          -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
1249          --                                    'ApiAnnotation.AnnClose',
1250          --                                    'ApiAnnotation.AnnDeriving',
1251          --                                    'ApiAnnotation.AnnInstance',
1252         }
1253   deriving (Typeable)
1254 deriving instance (DataId name) => Data (DerivDecl name)
1255
1256 instance (OutputableBndr name) => Outputable (DerivDecl name) where
1257     ppr (DerivDecl ty o)
1258         = hsep [ptext (sLit "deriving instance"), ppOverlapPragma o, ppr ty]
1259 \end{code}
1260
1261 %************************************************************************
1262 %*                                                                      *
1263 \subsection[DefaultDecl]{A @default@ declaration}
1264 %*                                                                      *
1265 %************************************************************************
1266
1267 There can only be one default declaration per module, but it is hard
1268 for the parser to check that; we pass them all through in the abstract
1269 syntax, and that restriction must be checked in the front end.
1270
1271 \begin{code}
1272 type LDefaultDecl name = Located (DefaultDecl name)
1273
1274 data DefaultDecl name
1275   = DefaultDecl [LHsType name]
1276         -- ^ - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnDefault',
1277         --          'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose'
1278
1279   deriving (Typeable)
1280 deriving instance (DataId name) => Data (DefaultDecl name)
1281
1282 instance (OutputableBndr name)
1283               => Outputable (DefaultDecl name) where
1284
1285     ppr (DefaultDecl tys)
1286       = ptext (sLit "default") <+> parens (interpp'SP tys)
1287 \end{code}
1288
1289 %************************************************************************
1290 %*                                                                      *
1291 \subsection{Foreign function interface declaration}
1292 %*                                                                      *
1293 %************************************************************************
1294
1295 \begin{code}
1296
1297 -- foreign declarations are distinguished as to whether they define or use a
1298 -- Haskell name
1299 --
1300 --  * the Boolean value indicates whether the pre-standard deprecated syntax
1301 --   has been used
1302 --
1303 type LForeignDecl name = Located (ForeignDecl name)
1304
1305 data ForeignDecl name
1306   = ForeignImport (Located name) -- defines this name
1307                   (LHsType name) -- sig_ty
1308                   (PostTc name Coercion) -- rep_ty ~ sig_ty
1309                   ForeignImport
1310   | ForeignExport (Located name) -- uses this name
1311                   (LHsType name) -- sig_ty
1312                   (PostTc name Coercion)  -- sig_ty ~ rep_ty
1313                   ForeignExport
1314         -- ^
1315         --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnForeign',
1316         --           'ApiAnnotation.AnnImport','ApiAnnotation.AnnExport',
1317         --           'ApiAnnotation.AnnDcolon'
1318   deriving (Typeable)
1319 deriving instance (DataId name) => Data (ForeignDecl name)
1320 {-
1321     In both ForeignImport and ForeignExport:
1322         sig_ty is the type given in the Haskell code
1323         rep_ty is the representation for this type, i.e. with newtypes
1324                coerced away and type functions evaluated.
1325     Thus if the declaration is valid, then rep_ty will only use types
1326     such as Int and IO that we know how to make foreign calls with.
1327 -}
1328
1329 noForeignImportCoercionYet :: PlaceHolder
1330 noForeignImportCoercionYet = PlaceHolder
1331
1332 noForeignExportCoercionYet :: PlaceHolder
1333 noForeignExportCoercionYet = PlaceHolder
1334
1335 -- Specification Of an imported external entity in dependence on the calling
1336 -- convention
1337 --
1338 data ForeignImport = -- import of a C entity
1339                      --
1340                      --  * the two strings specifying a header file or library
1341                      --   may be empty, which indicates the absence of a
1342                      --   header or object specification (both are not used
1343                      --   in the case of `CWrapper' and when `CFunction'
1344                      --   has a dynamic target)
1345                      --
1346                      --  * the calling convention is irrelevant for code
1347                      --   generation in the case of `CLabel', but is needed
1348                      --   for pretty printing
1349                      --
1350                      --  * `Safety' is irrelevant for `CLabel' and `CWrapper'
1351                      --
1352                      CImport  (Located CCallConv) -- ccall or stdcall
1353                               (Located Safety)  -- interruptible, safe or unsafe
1354                               (Maybe Header)  -- name of C header
1355                               CImportSpec     -- details of the C entity
1356                               (Located FastString) -- original source text for
1357                                                    -- the C entity
1358   deriving (Data, Typeable)
1359
1360 -- details of an external C entity
1361 --
1362 data CImportSpec = CLabel    CLabelString     -- import address of a C label
1363                  | CFunction CCallTarget      -- static or dynamic function
1364                  | CWrapper                   -- wrapper to expose closures
1365                                               -- (former f.e.d.)
1366   deriving (Data, Typeable)
1367
1368 -- specification of an externally exported entity in dependence on the calling
1369 -- convention
1370 --
1371 data ForeignExport = CExport  (Located CExportSpec) -- contains the calling
1372                                                     -- convention
1373                               (Located FastString)  -- original source text for
1374                                                     -- the C entity
1375   deriving (Data, Typeable)
1376
1377 -- pretty printing of foreign declarations
1378 --
1379
1380 instance OutputableBndr name => Outputable (ForeignDecl name) where
1381   ppr (ForeignImport n ty _ fimport) =
1382     hang (ptext (sLit "foreign import") <+> ppr fimport <+> ppr n)
1383        2 (dcolon <+> ppr ty)
1384   ppr (ForeignExport n ty _ fexport) =
1385     hang (ptext (sLit "foreign export") <+> ppr fexport <+> ppr n)
1386        2 (dcolon <+> ppr ty)
1387
1388 instance Outputable ForeignImport where
1389   ppr (CImport  cconv safety mHeader spec _) =
1390     ppr cconv <+> ppr safety <+>
1391     char '"' <> pprCEntity spec <> char '"'
1392     where
1393       pp_hdr = case mHeader of
1394                Nothing -> empty
1395                Just (Header header) -> ftext header
1396
1397       pprCEntity (CLabel lbl) =
1398         ptext (sLit "static") <+> pp_hdr <+> char '&' <> ppr lbl
1399       pprCEntity (CFunction (StaticTarget lbl _ isFun)) =
1400             ptext (sLit "static")
1401         <+> pp_hdr
1402         <+> (if isFun then empty else ptext (sLit "value"))
1403         <+> ppr lbl
1404       pprCEntity (CFunction (DynamicTarget)) =
1405         ptext (sLit "dynamic")
1406       pprCEntity (CWrapper) = ptext (sLit "wrapper")
1407
1408 instance Outputable ForeignExport where
1409   ppr (CExport  (L _ (CExportStatic lbl cconv)) _) =
1410     ppr cconv <+> char '"' <> ppr lbl <> char '"'
1411 \end{code}
1412
1413
1414 %************************************************************************
1415 %*                                                                      *
1416 \subsection{Transformation rules}
1417 %*                                                                      *
1418 %************************************************************************
1419
1420 \begin{code}
1421 type LRuleDecl name = Located (RuleDecl name)
1422
1423 data RuleDecl name
1424   = HsRule                      -- Source rule
1425         (Located RuleName)      -- Rule name
1426         Activation
1427         [LRuleBndr name]        -- Forall'd vars; after typechecking this
1428                                 --   includes tyvars
1429         (Located (HsExpr name)) -- LHS
1430         (PostRn name NameSet)   -- Free-vars from the LHS
1431         (Located (HsExpr name)) -- RHS
1432         (PostRn name NameSet)   -- Free-vars from the RHS
1433         -- ^
1434         --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual',
1435         --           'ApiAnnotation.AnnOpen','ApiAnnotation.AnnVal',
1436         --           'ApiAnnotation.AnnClose','ApiAnnotation.AnnTilde',
1437         --           'ApiAnnotation.AnnForall','ApiAnnotation.AnnDot',
1438   deriving (Typeable)
1439 deriving instance (DataId name) => Data (RuleDecl name)
1440
1441 type LRuleBndr name = Located (RuleBndr name)
1442 data RuleBndr name
1443   = RuleBndr (Located name)
1444   | RuleBndrSig (Located name) (HsWithBndrs name (LHsType name))
1445         -- ^
1446         --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
1447         --     'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnClose'
1448   deriving (Typeable)
1449 deriving instance (DataId name) => Data (RuleBndr name)
1450
1451 collectRuleBndrSigTys :: [RuleBndr name] -> [HsWithBndrs name (LHsType name)]
1452 collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs]
1453
1454 instance OutputableBndr name => Outputable (RuleDecl name) where
1455   ppr (HsRule name act ns lhs _fv_lhs rhs _fv_rhs)
1456         = sep [text "{-# RULES" <+> doubleQuotes (ftext $ unLoc name)
1457                                 <+> ppr act,
1458                nest 4 (pp_forall <+> pprExpr (unLoc lhs)),
1459                nest 4 (equals <+> pprExpr (unLoc rhs) <+> text "#-}") ]
1460         where
1461           pp_forall | null ns   = empty
1462                     | otherwise = forAllLit <+> fsep (map ppr ns) <> dot
1463
1464 instance OutputableBndr name => Outputable (RuleBndr name) where
1465    ppr (RuleBndr name) = ppr name
1466    ppr (RuleBndrSig name ty) = ppr name <> dcolon <> ppr ty
1467 \end{code}
1468
1469
1470 %************************************************************************
1471 %*                                                                      *
1472 \subsection{Vectorisation declarations}
1473 %*                                                                      *
1474 %************************************************************************
1475
1476 A vectorisation pragma, one of
1477
1478   {-# VECTORISE f = closure1 g (scalar_map g) #-}
1479   {-# VECTORISE SCALAR f #-}
1480   {-# NOVECTORISE f #-}
1481
1482   {-# VECTORISE type T = ty #-}
1483   {-# VECTORISE SCALAR type T #-}
1484
1485 \begin{code}
1486 type LVectDecl name = Located (VectDecl name)
1487
1488 data VectDecl name
1489   = HsVect
1490       (Located name)
1491       (LHsExpr name)
1492         -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
1493         --           'ApiAnnotation.AnnEqual','ApiAnnotation.AnnClose'
1494   | HsNoVect
1495       (Located name)
1496         -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
1497         --                                    'ApiAnnotation.AnnClose'
1498   | HsVectTypeIn                -- pre type-checking
1499       Bool                      -- 'TRUE' => SCALAR declaration
1500       (Located name)
1501       (Maybe (Located name))    -- 'Nothing' => no right-hand side
1502         -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
1503         --           'ApiAnnotation.AnnType','ApiAnnotation.AnnClose',
1504         --           'ApiAnnotation.AnnEqual'
1505   | HsVectTypeOut               -- post type-checking
1506       Bool                      -- 'TRUE' => SCALAR declaration
1507       TyCon
1508       (Maybe TyCon)             -- 'Nothing' => no right-hand side
1509   | HsVectClassIn               -- pre type-checking
1510       (Located name)
1511         -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
1512         --           'ApiAnnotation.AnnClass','ApiAnnotation.AnnClose',
1513   | HsVectClassOut              -- post type-checking
1514       Class
1515   | HsVectInstIn                -- pre type-checking (always SCALAR)  !!!FIXME: should be superfluous now
1516       (LHsType name)
1517   | HsVectInstOut               -- post type-checking (always SCALAR) !!!FIXME: should be superfluous now
1518       ClsInst
1519   deriving (Typeable)
1520 deriving instance (DataId name) => Data (VectDecl name)
1521
1522 lvectDeclName :: NamedThing name => LVectDecl name -> Name
1523 lvectDeclName (L _ (HsVect         (L _ name) _))   = getName name
1524 lvectDeclName (L _ (HsNoVect       (L _ name)))     = getName name
1525 lvectDeclName (L _ (HsVectTypeIn   _ (L _ name) _)) = getName name
1526 lvectDeclName (L _ (HsVectTypeOut  _ tycon _))      = getName tycon
1527 lvectDeclName (L _ (HsVectClassIn  (L _ name)))     = getName name
1528 lvectDeclName (L _ (HsVectClassOut cls))            = getName cls
1529 lvectDeclName (L _ (HsVectInstIn   _))              = panic "HsDecls.lvectDeclName: HsVectInstIn"
1530 lvectDeclName (L _ (HsVectInstOut  _))              = panic "HsDecls.lvectDeclName: HsVectInstOut"
1531
1532 lvectInstDecl :: LVectDecl name -> Bool
1533 lvectInstDecl (L _ (HsVectInstIn _))  = True
1534 lvectInstDecl (L _ (HsVectInstOut _)) = True
1535 lvectInstDecl _                       = False
1536
1537 instance OutputableBndr name => Outputable (VectDecl name) where
1538   ppr (HsVect v rhs)
1539     = sep [text "{-# VECTORISE" <+> ppr v,
1540            nest 4 $
1541              pprExpr (unLoc rhs) <+> text "#-}" ]
1542   ppr (HsNoVect v)
1543     = sep [text "{-# NOVECTORISE" <+> ppr v <+> text "#-}" ]
1544   ppr (HsVectTypeIn False t Nothing)
1545     = sep [text "{-# VECTORISE type" <+> ppr t <+> text "#-}" ]
1546   ppr (HsVectTypeIn False t (Just t'))
1547     = sep [text "{-# VECTORISE type" <+> ppr t, text "=", ppr t', text "#-}" ]
1548   ppr (HsVectTypeIn True t Nothing)
1549     = sep [text "{-# VECTORISE SCALAR type" <+> ppr t <+> text "#-}" ]
1550   ppr (HsVectTypeIn True t (Just t'))
1551     = sep [text "{-# VECTORISE SCALAR type" <+> ppr t, text "=", ppr t', text "#-}" ]
1552   ppr (HsVectTypeOut False t Nothing)
1553     = sep [text "{-# VECTORISE type" <+> ppr t <+> text "#-}" ]
1554   ppr (HsVectTypeOut False t (Just t'))
1555     = sep [text "{-# VECTORISE type" <+> ppr t, text "=", ppr t', text "#-}" ]
1556   ppr (HsVectTypeOut True t Nothing)
1557     = sep [text "{-# VECTORISE SCALAR type" <+> ppr t <+> text "#-}" ]
1558   ppr (HsVectTypeOut True t (Just t'))
1559     = sep [text "{-# VECTORISE SCALAR type" <+> ppr t, text "=", ppr t', text "#-}" ]
1560   ppr (HsVectClassIn c)
1561     = sep [text "{-# VECTORISE class" <+> ppr c <+> text "#-}" ]
1562   ppr (HsVectClassOut c)
1563     = sep [text "{-# VECTORISE class" <+> ppr c <+> text "#-}" ]
1564   ppr (HsVectInstIn ty)
1565     = sep [text "{-# VECTORISE SCALAR instance" <+> ppr ty <+> text "#-}" ]
1566   ppr (HsVectInstOut i)
1567     = sep [text "{-# VECTORISE SCALAR instance" <+> ppr i <+> text "#-}" ]
1568 \end{code}
1569
1570 %************************************************************************
1571 %*                                                                      *
1572 \subsection[DocDecl]{Document comments}
1573 %*                                                                      *
1574 %************************************************************************
1575
1576 \begin{code}
1577
1578 type LDocDecl = Located (DocDecl)
1579
1580 data DocDecl
1581   = DocCommentNext HsDocString
1582   | DocCommentPrev HsDocString
1583   | DocCommentNamed String HsDocString
1584   | DocGroup Int HsDocString
1585   deriving (Data, Typeable)
1586
1587 -- Okay, I need to reconstruct the document comments, but for now:
1588 instance Outputable DocDecl where
1589   ppr _ = text "<document comment>"
1590
1591 docDeclDoc :: DocDecl -> HsDocString
1592 docDeclDoc (DocCommentNext d) = d
1593 docDeclDoc (DocCommentPrev d) = d
1594 docDeclDoc (DocCommentNamed _ d) = d
1595 docDeclDoc (DocGroup _ d) = d
1596
1597 \end{code}
1598
1599 %************************************************************************
1600 %*                                                                      *
1601 \subsection[DeprecDecl]{Deprecations}
1602 %*                                                                      *
1603 %************************************************************************
1604
1605 We use exported entities for things to deprecate.
1606
1607 \begin{code}
1608 type LWarnDecl name = Located (WarnDecl name)
1609
1610 data WarnDecl name = Warning name WarningTxt
1611   deriving (Data, Typeable)
1612
1613 instance OutputableBndr name => Outputable (WarnDecl name) where
1614     ppr (Warning thing txt)
1615       = hsep [text "{-# DEPRECATED", ppr thing, doubleQuotes (ppr txt), text "#-}"]
1616 \end{code}
1617
1618 %************************************************************************
1619 %*                                                                      *
1620 \subsection[AnnDecl]{Annotations}
1621 %*                                                                      *
1622 %************************************************************************
1623
1624 \begin{code}
1625 type LAnnDecl name = Located (AnnDecl name)
1626
1627 data AnnDecl name = HsAnnotation (AnnProvenance name) (Located (HsExpr name))
1628       -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
1629       --           'ApiAnnotation.AnnType'
1630       --           'ApiAnnotation.AnnModule'
1631       --           'ApiAnnotation.AnnClose'
1632   deriving (Typeable)
1633 deriving instance (DataId name) => Data (AnnDecl name)
1634
1635 instance (OutputableBndr name) => Outputable (AnnDecl name) where
1636     ppr (HsAnnotation provenance expr)
1637       = hsep [text "{-#", pprAnnProvenance provenance, pprExpr (unLoc expr), text "#-}"]
1638
1639
1640 data AnnProvenance name = ValueAnnProvenance name
1641                         | TypeAnnProvenance name
1642                         | ModuleAnnProvenance
1643   deriving (Data, Typeable, Functor, Foldable, Traversable)
1644
1645 annProvenanceName_maybe :: AnnProvenance name -> Maybe name
1646 annProvenanceName_maybe (ValueAnnProvenance name) = Just name
1647 annProvenanceName_maybe (TypeAnnProvenance name)  = Just name
1648 annProvenanceName_maybe ModuleAnnProvenance       = Nothing
1649
1650 pprAnnProvenance :: OutputableBndr name => AnnProvenance name -> SDoc
1651 pprAnnProvenance ModuleAnnProvenance       = ptext (sLit "ANN module")
1652 pprAnnProvenance (ValueAnnProvenance name) = ptext (sLit "ANN") <+> ppr name
1653 pprAnnProvenance (TypeAnnProvenance name)  = ptext (sLit "ANN type") <+> ppr name
1654 \end{code}
1655
1656 %************************************************************************
1657 %*                                                                      *
1658 \subsection[RoleAnnot]{Role annotations}
1659 %*                                                                      *
1660 %************************************************************************
1661
1662 \begin{code}
1663 type LRoleAnnotDecl name = Located (RoleAnnotDecl name)
1664
1665 -- See #8185 for more info about why role annotations are
1666 -- top-level declarations
1667 data RoleAnnotDecl name
1668   = RoleAnnotDecl (Located name)         -- type constructor
1669                   [Located (Maybe Role)] -- optional annotations
1670       -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType',
1671       --           'ApiAnnotation.AnnRole'
1672   deriving (Data, Typeable)
1673
1674 instance OutputableBndr name => Outputable (RoleAnnotDecl name) where
1675   ppr (RoleAnnotDecl ltycon roles)
1676     = ptext (sLit "type role") <+> ppr ltycon <+>
1677       hsep (map (pp_role . unLoc) roles)
1678     where
1679       pp_role Nothing  = underscore
1680       pp_role (Just r) = ppr r
1681
1682 roleAnnotDeclName :: RoleAnnotDecl name -> name
1683 roleAnnotDeclName (RoleAnnotDecl (L _ name) _) = name
1684
1685 \end{code}