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