never executed always true always false
1
2 {-# LANGUAGE ConstraintKinds #-}
3 {-# LANGUAGE DeriveDataTypeable #-}
4 {-# LANGUAGE FlexibleContexts #-}
5 {-# LANGUAGE FlexibleInstances #-}
6 {-# LANGUAGE ScopedTypeVariables #-}
7 {-# LANGUAGE TypeApplications #-}
8 {-# LANGUAGE TypeFamilies #-}
9 {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
10 -- in module Language.Haskell.Syntax.Extension
11
12 {-# OPTIONS_GHC -Wno-orphans #-} -- Outputable
13
14 {-
15 (c) The University of Glasgow 2006
16 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
17 -}
18
19
20 {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
21
22 -- | Abstract syntax of global declarations.
23 --
24 -- Definitions for: @SynDecl@ and @ConDecl@, @ClassDecl@,
25 -- @InstDecl@, @DefaultDecl@ and @ForeignDecl@.
26 module GHC.Hs.Decls (
27 -- * Toplevel declarations
28 HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving, LHsFunDep,
29 HsDerivingClause(..), LHsDerivingClause, DerivClauseTys(..), LDerivClauseTys,
30 NewOrData(..), newOrDataToFlavour,
31 StandaloneKindSig(..), LStandaloneKindSig, standaloneKindSigName,
32
33 -- ** Class or type declarations
34 TyClDecl(..), LTyClDecl, DataDeclRn(..),
35 TyClGroup(..),
36 tyClGroupTyClDecls, tyClGroupInstDecls, tyClGroupRoleDecls,
37 tyClGroupKindSigs,
38 isClassDecl, isDataDecl, isSynDecl, tcdName,
39 isFamilyDecl, isTypeFamilyDecl, isDataFamilyDecl,
40 isOpenTypeFamilyInfo, isClosedTypeFamilyInfo,
41 tyFamInstDeclName, tyFamInstDeclLName,
42 countTyClDecls, pprTyClDeclFlavour,
43 tyClDeclLName, tyClDeclTyVars,
44 hsDeclHasCusk, famResultKindSignature,
45 FamilyDecl(..), LFamilyDecl,
46 FunDep(..),
47
48 -- ** Instance declarations
49 InstDecl(..), LInstDecl, FamilyInfo(..),
50 TyFamInstDecl(..), LTyFamInstDecl, instDeclDataFamInsts,
51 TyFamDefltDecl, LTyFamDefltDecl,
52 DataFamInstDecl(..), LDataFamInstDecl,
53 pprDataFamInstFlavour, pprTyFamInstDecl, pprHsFamInstLHS,
54 FamEqn(..), TyFamInstEqn, LTyFamInstEqn, HsTyPats,
55 LClsInstDecl, ClsInstDecl(..),
56
57 -- ** Standalone deriving declarations
58 DerivDecl(..), LDerivDecl,
59 -- ** Deriving strategies
60 DerivStrategy(..), LDerivStrategy,
61 derivStrategyName, foldDerivStrategy, mapDerivStrategy,
62 XViaStrategyPs(..),
63 -- ** @RULE@ declarations
64 LRuleDecls,RuleDecls(..),RuleDecl(..),LRuleDecl,HsRuleRn(..),
65 HsRuleAnn(..),
66 RuleBndr(..),LRuleBndr,
67 collectRuleBndrSigTys,
68 flattenRuleDecls, pprFullRuleName,
69 -- ** @default@ declarations
70 DefaultDecl(..), LDefaultDecl,
71 -- ** Template haskell declaration splice
72 SpliceExplicitFlag(..),
73 SpliceDecl(..), LSpliceDecl,
74 -- ** Foreign function interface declarations
75 ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..),
76 CImportSpec(..),
77 -- ** Data-constructor declarations
78 ConDecl(..), LConDecl,
79 HsConDeclH98Details, HsConDeclGADTDetails(..), hsConDeclTheta,
80 getConNames, getRecConArgs_maybe,
81 -- ** Document comments
82 DocDecl(..), LDocDecl, docDeclDoc,
83 -- ** Deprecations
84 WarnDecl(..), LWarnDecl,
85 WarnDecls(..), LWarnDecls,
86 -- ** Annotations
87 AnnDecl(..), LAnnDecl,
88 AnnProvenance(..), annProvenanceName_maybe,
89 -- ** Role annotations
90 RoleAnnotDecl(..), LRoleAnnotDecl, roleAnnotDeclName,
91 -- ** Injective type families
92 FamilyResultSig(..), LFamilyResultSig, InjectivityAnn(..), LInjectivityAnn,
93 resultVariableName, familyDeclLName, familyDeclName,
94
95 -- * Grouping
96 HsGroup(..), emptyRdrGroup, emptyRnGroup, appendGroups, hsGroupInstDecls,
97 hsGroupTopLevelFixitySigs,
98
99 partitionBindsAndSigs,
100 ) where
101
102 -- friends:
103 import GHC.Prelude
104
105 import Language.Haskell.Syntax.Decls
106
107 import {-# SOURCE #-} GHC.Hs.Expr ( pprExpr, pprSpliceDecl )
108 -- Because Expr imports Decls via HsBracket
109
110 import GHC.Hs.Binds
111 import GHC.Hs.Type
112 import GHC.Hs.Doc
113 import GHC.Types.Basic
114 import GHC.Core.Coercion
115 import Language.Haskell.Syntax.Extension
116 import GHC.Hs.Extension
117 import GHC.Parser.Annotation
118 import GHC.Types.Name
119 import GHC.Types.Name.Set
120 import GHC.Types.Fixity
121
122 -- others:
123 import GHC.Utils.Outputable
124 import GHC.Utils.Panic
125 import GHC.Types.SrcLoc
126 import GHC.Types.SourceText
127 import GHC.Core.Type
128 import GHC.Types.ForeignCall
129
130 import GHC.Data.Bag
131 import GHC.Data.Maybe
132 import Data.Data (Data)
133
134 {-
135 ************************************************************************
136 * *
137 \subsection[HsDecl]{Declarations}
138 * *
139 ************************************************************************
140 -}
141
142 type instance XTyClD (GhcPass _) = NoExtField
143 type instance XInstD (GhcPass _) = NoExtField
144 type instance XDerivD (GhcPass _) = NoExtField
145 type instance XValD (GhcPass _) = NoExtField
146 type instance XSigD (GhcPass _) = NoExtField
147 type instance XKindSigD (GhcPass _) = NoExtField
148 type instance XDefD (GhcPass _) = NoExtField
149 type instance XForD (GhcPass _) = NoExtField
150 type instance XWarningD (GhcPass _) = NoExtField
151 type instance XAnnD (GhcPass _) = NoExtField
152 type instance XRuleD (GhcPass _) = NoExtField
153 type instance XSpliceD (GhcPass _) = NoExtField
154 type instance XDocD (GhcPass _) = NoExtField
155 type instance XRoleAnnotD (GhcPass _) = NoExtField
156 type instance XXHsDecl (GhcPass _) = NoExtCon
157
158 -- | Partition a list of HsDecls into function/pattern bindings, signatures,
159 -- type family declarations, type family instances, and documentation comments.
160 --
161 -- Panics when given a declaration that cannot be put into any of the output
162 -- groups.
163 --
164 -- The primary use of this function is to implement
165 -- 'GHC.Parser.PostProcess.cvBindsAndSigs'.
166 partitionBindsAndSigs
167 :: [LHsDecl GhcPs]
168 -> (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
169 [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl GhcPs])
170 partitionBindsAndSigs = go
171 where
172 go [] = (emptyBag, [], [], [], [], [])
173 go ((L l decl) : ds) =
174 let (bs, ss, ts, tfis, dfis, docs) = go ds in
175 case decl of
176 ValD _ b
177 -> (L l b `consBag` bs, ss, ts, tfis, dfis, docs)
178 SigD _ s
179 -> (bs, L l s : ss, ts, tfis, dfis, docs)
180 TyClD _ (FamDecl _ t)
181 -> (bs, ss, L l t : ts, tfis, dfis, docs)
182 InstD _ (TyFamInstD { tfid_inst = tfi })
183 -> (bs, ss, ts, L l tfi : tfis, dfis, docs)
184 InstD _ (DataFamInstD { dfid_inst = dfi })
185 -> (bs, ss, ts, tfis, L l dfi : dfis, docs)
186 DocD _ d
187 -> (bs, ss, ts, tfis, dfis, L l d : docs)
188 _ -> pprPanic "partitionBindsAndSigs" (ppr decl)
189
190 type instance XCHsGroup (GhcPass _) = NoExtField
191 type instance XXHsGroup (GhcPass _) = NoExtCon
192
193
194 emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup (GhcPass p)
195 emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn }
196 emptyRnGroup = emptyGroup { hs_valds = emptyValBindsOut }
197
198 emptyGroup = HsGroup { hs_ext = noExtField,
199 hs_tyclds = [],
200 hs_derivds = [],
201 hs_fixds = [], hs_defds = [], hs_annds = [],
202 hs_fords = [], hs_warnds = [], hs_ruleds = [],
203 hs_valds = error "emptyGroup hs_valds: Can't happen",
204 hs_splcds = [],
205 hs_docs = [] }
206
207 -- | The fixity signatures for each top-level declaration and class method
208 -- in an 'HsGroup'.
209 -- See Note [Top-level fixity signatures in an HsGroup]
210 hsGroupTopLevelFixitySigs :: HsGroup (GhcPass p) -> [LFixitySig (GhcPass p)]
211 hsGroupTopLevelFixitySigs (HsGroup{ hs_fixds = fixds, hs_tyclds = tyclds }) =
212 fixds ++ cls_fixds
213 where
214 cls_fixds = [ L loc sig
215 | L _ ClassDecl{tcdSigs = sigs} <- tyClGroupTyClDecls tyclds
216 , L loc (FixSig _ sig) <- sigs
217 ]
218
219 appendGroups :: HsGroup (GhcPass p) -> HsGroup (GhcPass p)
220 -> HsGroup (GhcPass p)
221 appendGroups
222 HsGroup {
223 hs_valds = val_groups1,
224 hs_splcds = spliceds1,
225 hs_tyclds = tyclds1,
226 hs_derivds = derivds1,
227 hs_fixds = fixds1,
228 hs_defds = defds1,
229 hs_annds = annds1,
230 hs_fords = fords1,
231 hs_warnds = warnds1,
232 hs_ruleds = rulds1,
233 hs_docs = docs1 }
234 HsGroup {
235 hs_valds = val_groups2,
236 hs_splcds = spliceds2,
237 hs_tyclds = tyclds2,
238 hs_derivds = derivds2,
239 hs_fixds = fixds2,
240 hs_defds = defds2,
241 hs_annds = annds2,
242 hs_fords = fords2,
243 hs_warnds = warnds2,
244 hs_ruleds = rulds2,
245 hs_docs = docs2 }
246 =
247 HsGroup {
248 hs_ext = noExtField,
249 hs_valds = val_groups1 `plusHsValBinds` val_groups2,
250 hs_splcds = spliceds1 ++ spliceds2,
251 hs_tyclds = tyclds1 ++ tyclds2,
252 hs_derivds = derivds1 ++ derivds2,
253 hs_fixds = fixds1 ++ fixds2,
254 hs_annds = annds1 ++ annds2,
255 hs_defds = defds1 ++ defds2,
256 hs_fords = fords1 ++ fords2,
257 hs_warnds = warnds1 ++ warnds2,
258 hs_ruleds = rulds1 ++ rulds2,
259 hs_docs = docs1 ++ docs2 }
260
261 instance (OutputableBndrId p) => Outputable (HsDecl (GhcPass p)) where
262 ppr (TyClD _ dcl) = ppr dcl
263 ppr (ValD _ binds) = ppr binds
264 ppr (DefD _ def) = ppr def
265 ppr (InstD _ inst) = ppr inst
266 ppr (DerivD _ deriv) = ppr deriv
267 ppr (ForD _ fd) = ppr fd
268 ppr (SigD _ sd) = ppr sd
269 ppr (KindSigD _ ksd) = ppr ksd
270 ppr (RuleD _ rd) = ppr rd
271 ppr (WarningD _ wd) = ppr wd
272 ppr (AnnD _ ad) = ppr ad
273 ppr (SpliceD _ dd) = ppr dd
274 ppr (DocD _ doc) = ppr doc
275 ppr (RoleAnnotD _ ra) = ppr ra
276
277 instance (OutputableBndrId p) => Outputable (HsGroup (GhcPass p)) where
278 ppr (HsGroup { hs_valds = val_decls,
279 hs_tyclds = tycl_decls,
280 hs_derivds = deriv_decls,
281 hs_fixds = fix_decls,
282 hs_warnds = deprec_decls,
283 hs_annds = ann_decls,
284 hs_fords = foreign_decls,
285 hs_defds = default_decls,
286 hs_ruleds = rule_decls })
287 = vcat_mb empty
288 [ppr_ds fix_decls, ppr_ds default_decls,
289 ppr_ds deprec_decls, ppr_ds ann_decls,
290 ppr_ds rule_decls,
291 if isEmptyValBinds val_decls
292 then Nothing
293 else Just (ppr val_decls),
294 ppr_ds (tyClGroupRoleDecls tycl_decls),
295 ppr_ds (tyClGroupKindSigs tycl_decls),
296 ppr_ds (tyClGroupTyClDecls tycl_decls),
297 ppr_ds (tyClGroupInstDecls tycl_decls),
298 ppr_ds deriv_decls,
299 ppr_ds foreign_decls]
300 where
301 ppr_ds :: Outputable a => [a] -> Maybe SDoc
302 ppr_ds [] = Nothing
303 ppr_ds ds = Just (vcat (map ppr ds))
304
305 vcat_mb :: SDoc -> [Maybe SDoc] -> SDoc
306 -- Concatenate vertically with white-space between non-blanks
307 vcat_mb _ [] = empty
308 vcat_mb gap (Nothing : ds) = vcat_mb gap ds
309 vcat_mb gap (Just d : ds) = gap $$ d $$ vcat_mb blankLine ds
310
311 type instance XSpliceDecl (GhcPass _) = NoExtField
312 type instance XXSpliceDecl (GhcPass _) = NoExtCon
313
314 instance OutputableBndrId p
315 => Outputable (SpliceDecl (GhcPass p)) where
316 ppr (SpliceDecl _ (L _ e) f) = pprSpliceDecl e f
317
318 {-
319 ************************************************************************
320 * *
321 Type and class declarations
322 * *
323 ************************************************************************
324 -}
325
326 type instance XFamDecl (GhcPass _) = NoExtField
327
328 type instance XSynDecl GhcPs = EpAnn [AddEpAnn]
329 type instance XSynDecl GhcRn = NameSet -- FVs
330 type instance XSynDecl GhcTc = NameSet -- FVs
331
332 type instance XDataDecl GhcPs = EpAnn [AddEpAnn]
333 type instance XDataDecl GhcRn = DataDeclRn
334 type instance XDataDecl GhcTc = DataDeclRn
335
336 type instance XClassDecl GhcPs = (EpAnn [AddEpAnn], AnnSortKey, LayoutInfo) -- See Note [Class LayoutInfo]
337 -- TODO:AZ:tidy up AnnSortKey above
338 type instance XClassDecl GhcRn = NameSet -- FVs
339 type instance XClassDecl GhcTc = NameSet -- FVs
340
341 type instance XXTyClDecl (GhcPass _) = NoExtCon
342
343 type instance XCTyFamInstDecl (GhcPass _) = EpAnn [AddEpAnn]
344 type instance XXTyFamInstDecl (GhcPass _) = NoExtCon
345
346 -- Dealing with names
347
348 tyFamInstDeclName :: Anno (IdGhcP p) ~ SrcSpanAnnN
349 => TyFamInstDecl (GhcPass p) -> IdP (GhcPass p)
350 tyFamInstDeclName = unLoc . tyFamInstDeclLName
351
352 tyFamInstDeclLName :: Anno (IdGhcP p) ~ SrcSpanAnnN
353 => TyFamInstDecl (GhcPass p) -> LocatedN (IdP (GhcPass p))
354 tyFamInstDeclLName (TyFamInstDecl { tfid_eqn = FamEqn { feqn_tycon = ln }})
355 = ln
356
357 tyClDeclLName :: Anno (IdGhcP p) ~ SrcSpanAnnN
358 => TyClDecl (GhcPass p) -> LocatedN (IdP (GhcPass p))
359 tyClDeclLName (FamDecl { tcdFam = fd }) = familyDeclLName fd
360 tyClDeclLName (SynDecl { tcdLName = ln }) = ln
361 tyClDeclLName (DataDecl { tcdLName = ln }) = ln
362 tyClDeclLName (ClassDecl { tcdLName = ln }) = ln
363
364 -- FIXME: tcdName is commonly used by both GHC and third-party tools, so it
365 -- needs to be polymorphic in the pass
366 tcdName :: Anno (IdGhcP p) ~ SrcSpanAnnN
367 => TyClDecl (GhcPass p) -> IdP (GhcPass p)
368 tcdName = unLoc . tyClDeclLName
369
370 -- | Does this declaration have a complete, user-supplied kind signature?
371 -- See Note [CUSKs: complete user-supplied kind signatures]
372 hsDeclHasCusk :: TyClDecl GhcRn -> Bool
373 hsDeclHasCusk (FamDecl { tcdFam =
374 FamilyDecl { fdInfo = fam_info
375 , fdTyVars = tyvars
376 , fdResultSig = L _ resultSig } }) =
377 case fam_info of
378 ClosedTypeFamily {} -> hsTvbAllKinded tyvars
379 && isJust (famResultKindSignature resultSig)
380 _ -> True -- Un-associated open type/data families have CUSKs
381 hsDeclHasCusk (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs })
382 = hsTvbAllKinded tyvars && isJust (hsTyKindSig rhs)
383 hsDeclHasCusk (DataDecl { tcdDExt = DataDeclRn { tcdDataCusk = cusk }}) = cusk
384 hsDeclHasCusk (ClassDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars
385
386 -- Pretty-printing TyClDecl
387 -- ~~~~~~~~~~~~~~~~~~~~~~~~
388
389 instance (OutputableBndrId p) => Outputable (TyClDecl (GhcPass p)) where
390
391 ppr (FamDecl { tcdFam = decl }) = ppr decl
392 ppr (SynDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity
393 , tcdRhs = rhs })
394 = hang (text "type" <+>
395 pp_vanilla_decl_head ltycon tyvars fixity Nothing <+> equals)
396 4 (ppr rhs)
397
398 ppr (DataDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity
399 , tcdDataDefn = defn })
400 = pp_data_defn (pp_vanilla_decl_head ltycon tyvars fixity) defn
401
402 ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars,
403 tcdFixity = fixity,
404 tcdFDs = fds,
405 tcdSigs = sigs, tcdMeths = methods,
406 tcdATs = ats, tcdATDefs = at_defs})
407 | null sigs && isEmptyBag methods && null ats && null at_defs -- No "where" part
408 = top_matter
409
410 | otherwise -- Laid out
411 = vcat [ top_matter <+> text "where"
412 , nest 2 $ pprDeclList (map (ppr . unLoc) ats ++
413 map (pprTyFamDefltDecl . unLoc) at_defs ++
414 pprLHsBindsForUser methods sigs) ]
415 where
416 top_matter = text "class"
417 <+> pp_vanilla_decl_head lclas tyvars fixity context
418 <+> pprFundeps (map unLoc fds)
419
420 instance OutputableBndrId p
421 => Outputable (TyClGroup (GhcPass p)) where
422 ppr (TyClGroup { group_tyclds = tyclds
423 , group_roles = roles
424 , group_kisigs = kisigs
425 , group_instds = instds
426 }
427 )
428 = hang (text "TyClGroup") 2 $
429 ppr kisigs $$
430 ppr tyclds $$
431 ppr roles $$
432 ppr instds
433
434 pp_vanilla_decl_head :: (OutputableBndrId p)
435 => XRec (GhcPass p) (IdP (GhcPass p))
436 -> LHsQTyVars (GhcPass p)
437 -> LexicalFixity
438 -> Maybe (LHsContext (GhcPass p))
439 -> SDoc
440 pp_vanilla_decl_head thing (HsQTvs { hsq_explicit = tyvars }) fixity context
441 = hsep [pprLHsContext context, pp_tyvars tyvars]
442 where
443 pp_tyvars (varl:varsr)
444 | fixity == Infix && length varsr > 1
445 = hsep [char '(',ppr (unLoc varl), pprInfixOcc (unLoc thing)
446 , (ppr.unLoc) (head varsr), char ')'
447 , hsep (map (ppr.unLoc) (tail varsr))]
448 | fixity == Infix
449 = hsep [ppr (unLoc varl), pprInfixOcc (unLoc thing)
450 , hsep (map (ppr.unLoc) varsr)]
451 | otherwise = hsep [ pprPrefixOcc (unLoc thing)
452 , hsep (map (ppr.unLoc) (varl:varsr))]
453 pp_tyvars [] = pprPrefixOcc (unLoc thing)
454
455 pprTyClDeclFlavour :: TyClDecl (GhcPass p) -> SDoc
456 pprTyClDeclFlavour (ClassDecl {}) = text "class"
457 pprTyClDeclFlavour (SynDecl {}) = text "type"
458 pprTyClDeclFlavour (FamDecl { tcdFam = FamilyDecl { fdInfo = info }})
459 = pprFlavour info <+> text "family"
460 pprTyClDeclFlavour (DataDecl { tcdDataDefn = HsDataDefn { dd_ND = nd } })
461 = ppr nd
462
463 instance OutputableBndrId p => Outputable (FunDep (GhcPass p)) where
464 ppr = pprFunDep
465
466 type instance XCFunDep (GhcPass _) = EpAnn [AddEpAnn]
467 type instance XXFunDep (GhcPass _) = NoExtCon
468
469 pprFundeps :: OutputableBndrId p => [FunDep (GhcPass p)] -> SDoc
470 pprFundeps [] = empty
471 pprFundeps fds = hsep (vbar : punctuate comma (map pprFunDep fds))
472
473 pprFunDep :: OutputableBndrId p => FunDep (GhcPass p) -> SDoc
474 pprFunDep (FunDep _ us vs) = hsep [interppSP us, arrow, interppSP vs]
475
476 {- *********************************************************************
477 * *
478 TyClGroup
479 Strongly connected components of
480 type, class, instance, and role declarations
481 * *
482 ********************************************************************* -}
483
484 type instance XCTyClGroup (GhcPass _) = NoExtField
485 type instance XXTyClGroup (GhcPass _) = NoExtCon
486
487
488 {- *********************************************************************
489 * *
490 Data and type family declarations
491 * *
492 ********************************************************************* -}
493
494 type instance XNoSig (GhcPass _) = NoExtField
495 type instance XCKindSig (GhcPass _) = NoExtField
496
497 type instance XTyVarSig (GhcPass _) = NoExtField
498 type instance XXFamilyResultSig (GhcPass _) = NoExtCon
499
500 type instance XCFamilyDecl (GhcPass _) = EpAnn [AddEpAnn]
501 type instance XXFamilyDecl (GhcPass _) = NoExtCon
502
503
504 ------------- Functions over FamilyDecls -----------
505
506 familyDeclLName :: FamilyDecl (GhcPass p) -> XRec (GhcPass p) (IdP (GhcPass p))
507 familyDeclLName (FamilyDecl { fdLName = n }) = n
508
509 familyDeclName :: FamilyDecl (GhcPass p) -> IdP (GhcPass p)
510 familyDeclName = unLoc . familyDeclLName
511
512 famResultKindSignature :: FamilyResultSig (GhcPass p) -> Maybe (LHsKind (GhcPass p))
513 famResultKindSignature (NoSig _) = Nothing
514 famResultKindSignature (KindSig _ ki) = Just ki
515 famResultKindSignature (TyVarSig _ bndr) =
516 case unLoc bndr of
517 UserTyVar _ _ _ -> Nothing
518 KindedTyVar _ _ _ ki -> Just ki
519
520 -- | Maybe return name of the result type variable
521 resultVariableName :: FamilyResultSig (GhcPass a) -> Maybe (IdP (GhcPass a))
522 resultVariableName (TyVarSig _ sig) = Just $ hsLTyVarName sig
523 resultVariableName _ = Nothing
524
525 ------------- Pretty printing FamilyDecls -----------
526
527 type instance XCInjectivityAnn (GhcPass _) = EpAnn [AddEpAnn]
528 type instance XXInjectivityAnn (GhcPass _) = NoExtCon
529
530 instance OutputableBndrId p
531 => Outputable (FamilyDecl (GhcPass p)) where
532 ppr (FamilyDecl { fdInfo = info, fdLName = ltycon
533 , fdTopLevel = top_level
534 , fdTyVars = tyvars
535 , fdFixity = fixity
536 , fdResultSig = L _ result
537 , fdInjectivityAnn = mb_inj })
538 = vcat [ pprFlavour info <+> pp_top_level <+>
539 pp_vanilla_decl_head ltycon tyvars fixity Nothing <+>
540 pp_kind <+> pp_inj <+> pp_where
541 , nest 2 $ pp_eqns ]
542 where
543 pp_top_level = case top_level of
544 TopLevel -> text "family"
545 NotTopLevel -> empty
546
547 pp_kind = case result of
548 NoSig _ -> empty
549 KindSig _ kind -> dcolon <+> ppr kind
550 TyVarSig _ tv_bndr -> text "=" <+> ppr tv_bndr
551 pp_inj = case mb_inj of
552 Just (L _ (InjectivityAnn _ lhs rhs)) ->
553 hsep [ vbar, ppr lhs, text "->", hsep (map ppr rhs) ]
554 Nothing -> empty
555 (pp_where, pp_eqns) = case info of
556 ClosedTypeFamily mb_eqns ->
557 ( text "where"
558 , case mb_eqns of
559 Nothing -> text ".."
560 Just eqns -> vcat $ map (ppr_fam_inst_eqn . unLoc) eqns )
561 _ -> (empty, empty)
562
563
564
565 {- *********************************************************************
566 * *
567 Data types and data constructors
568 * *
569 ********************************************************************* -}
570
571 type instance XCHsDataDefn (GhcPass _) = NoExtField
572 type instance XXHsDataDefn (GhcPass _) = NoExtCon
573
574 type instance XCHsDerivingClause (GhcPass _) = EpAnn [AddEpAnn]
575 type instance XXHsDerivingClause (GhcPass _) = NoExtCon
576
577 instance OutputableBndrId p
578 => Outputable (HsDerivingClause (GhcPass p)) where
579 ppr (HsDerivingClause { deriv_clause_strategy = dcs
580 , deriv_clause_tys = L _ dct })
581 = hsep [ text "deriving"
582 , pp_strat_before
583 , ppr dct
584 , pp_strat_after ]
585 where
586 -- @via@ is unique in that in comes /after/ the class being derived,
587 -- so we must special-case it.
588 (pp_strat_before, pp_strat_after) =
589 case dcs of
590 Just (L _ via@ViaStrategy{}) -> (empty, ppr via)
591 _ -> (ppDerivStrategy dcs, empty)
592
593 type instance XDctSingle (GhcPass _) = NoExtField
594 type instance XDctMulti (GhcPass _) = NoExtField
595 type instance XXDerivClauseTys (GhcPass _) = NoExtCon
596
597 instance OutputableBndrId p => Outputable (DerivClauseTys (GhcPass p)) where
598 ppr (DctSingle _ ty) = ppr ty
599 ppr (DctMulti _ tys) = parens (interpp'SP tys)
600
601 type instance XStandaloneKindSig GhcPs = EpAnn [AddEpAnn]
602 type instance XStandaloneKindSig GhcRn = NoExtField
603 type instance XStandaloneKindSig GhcTc = NoExtField
604
605 type instance XXStandaloneKindSig (GhcPass p) = NoExtCon
606
607 standaloneKindSigName :: StandaloneKindSig (GhcPass p) -> IdP (GhcPass p)
608 standaloneKindSigName (StandaloneKindSig _ lname _) = unLoc lname
609
610 type instance XConDeclGADT (GhcPass _) = EpAnn [AddEpAnn]
611 type instance XConDeclH98 (GhcPass _) = EpAnn [AddEpAnn]
612
613 type instance XXConDecl (GhcPass _) = NoExtCon
614
615 getConNames :: ConDecl GhcRn -> [LocatedN Name]
616 getConNames ConDeclH98 {con_name = name} = [name]
617 getConNames ConDeclGADT {con_names = names} = names
618
619 -- | Return @'Just' fields@ if a data constructor declaration uses record
620 -- syntax (i.e., 'RecCon'), where @fields@ are the field selectors.
621 -- Otherwise, return 'Nothing'.
622 getRecConArgs_maybe :: ConDecl GhcRn -> Maybe (LocatedL [LConDeclField GhcRn])
623 getRecConArgs_maybe (ConDeclH98{con_args = args}) = case args of
624 PrefixCon{} -> Nothing
625 RecCon flds -> Just flds
626 InfixCon{} -> Nothing
627 getRecConArgs_maybe (ConDeclGADT{con_g_args = args}) = case args of
628 PrefixConGADT{} -> Nothing
629 RecConGADT flds _ -> Just flds
630
631 hsConDeclTheta :: Maybe (LHsContext (GhcPass p)) -> [LHsType (GhcPass p)]
632 hsConDeclTheta Nothing = []
633 hsConDeclTheta (Just (L _ theta)) = theta
634
635 pp_data_defn :: (OutputableBndrId p)
636 => (Maybe (LHsContext (GhcPass p)) -> SDoc) -- Printing the header
637 -> HsDataDefn (GhcPass p)
638 -> SDoc
639 pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = context
640 , dd_cType = mb_ct
641 , dd_kindSig = mb_sig
642 , dd_cons = condecls, dd_derivs = derivings })
643 | null condecls
644 = ppr new_or_data <+> pp_ct <+> pp_hdr context <+> pp_sig
645 <+> pp_derivings derivings
646
647 | otherwise
648 = hang (ppr new_or_data <+> pp_ct <+> pp_hdr context <+> pp_sig)
649 2 (pp_condecls condecls $$ pp_derivings derivings)
650 where
651 pp_ct = case mb_ct of
652 Nothing -> empty
653 Just ct -> ppr ct
654 pp_sig = case mb_sig of
655 Nothing -> empty
656 Just kind -> dcolon <+> ppr kind
657 pp_derivings ds = vcat (map ppr ds)
658
659 instance OutputableBndrId p
660 => Outputable (HsDataDefn (GhcPass p)) where
661 ppr d = pp_data_defn (\_ -> text "Naked HsDataDefn") d
662
663 instance OutputableBndrId p
664 => Outputable (StandaloneKindSig (GhcPass p)) where
665 ppr (StandaloneKindSig _ v ki)
666 = text "type" <+> pprPrefixOcc (unLoc v) <+> text "::" <+> ppr ki
667
668 pp_condecls :: forall p. OutputableBndrId p => [LConDecl (GhcPass p)] -> SDoc
669 pp_condecls cs
670 | gadt_syntax -- In GADT syntax
671 = hang (text "where") 2 (vcat (map ppr cs))
672 | otherwise -- In H98 syntax
673 = equals <+> sep (punctuate (text " |") (map ppr cs))
674 where
675 gadt_syntax = case cs of
676 [] -> False
677 (L _ ConDeclH98{} : _) -> False
678 (L _ ConDeclGADT{} : _) -> True
679
680 instance (OutputableBndrId p) => Outputable (ConDecl (GhcPass p)) where
681 ppr = pprConDecl
682
683 pprConDecl :: forall p. OutputableBndrId p => ConDecl (GhcPass p) -> SDoc
684 pprConDecl (ConDeclH98 { con_name = L _ con
685 , con_ex_tvs = ex_tvs
686 , con_mb_cxt = mcxt
687 , con_args = args
688 , con_doc = doc })
689 = sep [ ppr_mbDoc doc
690 , pprHsForAll (mkHsForAllInvisTele noAnn ex_tvs) mcxt
691 , ppr_details args ]
692 where
693 -- In ppr_details: let's not print the multiplicities (they are always 1, by
694 -- definition) as they do not appear in an actual declaration.
695 ppr_details (InfixCon t1 t2) = hsep [ppr (hsScaledThing t1),
696 pprInfixOcc con,
697 ppr (hsScaledThing t2)]
698 ppr_details (PrefixCon _ tys) = hsep (pprPrefixOcc con
699 : map (pprHsType . unLoc . hsScaledThing) tys)
700 ppr_details (RecCon fields) = pprPrefixOcc con
701 <+> pprConDeclFields (unLoc fields)
702
703 pprConDecl (ConDeclGADT { con_names = cons, con_bndrs = L _ outer_bndrs
704 , con_mb_cxt = mcxt, con_g_args = args
705 , con_res_ty = res_ty, con_doc = doc })
706 = ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon
707 <+> (sep [pprHsOuterSigTyVarBndrs outer_bndrs <+> pprLHsContext mcxt,
708 sep (ppr_args args ++ [ppr res_ty]) ])
709 where
710 ppr_args (PrefixConGADT args) = map (\(HsScaled arr t) -> ppr t <+> ppr_arr arr) args
711 ppr_args (RecConGADT fields _) = [pprConDeclFields (unLoc fields) <+> arrow]
712
713 -- Display linear arrows as unrestricted with -XNoLinearTypes
714 -- (cf. dataConDisplayType in Note [Displaying linear fields] in GHC.Core.DataCon)
715 ppr_arr (HsLinearArrow _) = sdocOption sdocLinearTypes $ \show_linear_types ->
716 if show_linear_types then lollipop else arrow
717 ppr_arr arr = pprHsArrow arr
718
719 ppr_con_names :: (OutputableBndr a) => [GenLocated l a] -> SDoc
720 ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc)
721
722 {-
723 ************************************************************************
724 * *
725 Instance declarations
726 * *
727 ************************************************************************
728 -}
729
730 type instance XCFamEqn (GhcPass _) r = EpAnn [AddEpAnn]
731 type instance XXFamEqn (GhcPass _) r = NoExtCon
732
733 type instance Anno (FamEqn (GhcPass p) _) = SrcSpanAnnA
734
735 ----------------- Class instances -------------
736
737 type instance XCClsInstDecl GhcPs = (EpAnn [AddEpAnn], AnnSortKey) -- TODO:AZ:tidy up
738 type instance XCClsInstDecl GhcRn = NoExtField
739 type instance XCClsInstDecl GhcTc = NoExtField
740
741 type instance XXClsInstDecl (GhcPass _) = NoExtCon
742
743 ----------------- Instances of all kinds -------------
744
745 type instance XClsInstD (GhcPass _) = NoExtField
746
747 type instance XDataFamInstD GhcPs = EpAnn [AddEpAnn]
748 type instance XDataFamInstD GhcRn = NoExtField
749 type instance XDataFamInstD GhcTc = NoExtField
750
751 type instance XTyFamInstD GhcPs = NoExtField
752 type instance XTyFamInstD GhcRn = NoExtField
753 type instance XTyFamInstD GhcTc = NoExtField
754
755 type instance XXInstDecl (GhcPass _) = NoExtCon
756
757 instance OutputableBndrId p
758 => Outputable (TyFamInstDecl (GhcPass p)) where
759 ppr = pprTyFamInstDecl TopLevel
760
761 pprTyFamInstDecl :: (OutputableBndrId p)
762 => TopLevelFlag -> TyFamInstDecl (GhcPass p) -> SDoc
763 pprTyFamInstDecl top_lvl (TyFamInstDecl { tfid_eqn = eqn })
764 = text "type" <+> ppr_instance_keyword top_lvl <+> ppr_fam_inst_eqn eqn
765
766 ppr_instance_keyword :: TopLevelFlag -> SDoc
767 ppr_instance_keyword TopLevel = text "instance"
768 ppr_instance_keyword NotTopLevel = empty
769
770 pprTyFamDefltDecl :: (OutputableBndrId p)
771 => TyFamDefltDecl (GhcPass p) -> SDoc
772 pprTyFamDefltDecl = pprTyFamInstDecl NotTopLevel
773
774 ppr_fam_inst_eqn :: (OutputableBndrId p)
775 => TyFamInstEqn (GhcPass p) -> SDoc
776 ppr_fam_inst_eqn (FamEqn { feqn_tycon = L _ tycon
777 , feqn_bndrs = bndrs
778 , feqn_pats = pats
779 , feqn_fixity = fixity
780 , feqn_rhs = rhs })
781 = pprHsFamInstLHS tycon bndrs pats fixity Nothing <+> equals <+> ppr rhs
782
783 instance OutputableBndrId p
784 => Outputable (DataFamInstDecl (GhcPass p)) where
785 ppr = pprDataFamInstDecl TopLevel
786
787 pprDataFamInstDecl :: (OutputableBndrId p)
788 => TopLevelFlag -> DataFamInstDecl (GhcPass p) -> SDoc
789 pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_eqn =
790 (FamEqn { feqn_tycon = L _ tycon
791 , feqn_bndrs = bndrs
792 , feqn_pats = pats
793 , feqn_fixity = fixity
794 , feqn_rhs = defn })})
795 = pp_data_defn pp_hdr defn
796 where
797 pp_hdr mctxt = ppr_instance_keyword top_lvl
798 <+> pprHsFamInstLHS tycon bndrs pats fixity mctxt
799 -- pp_data_defn pretty-prints the kind sig. See #14817.
800
801 pprDataFamInstFlavour :: DataFamInstDecl (GhcPass p) -> SDoc
802 pprDataFamInstFlavour (DataFamInstDecl { dfid_eqn =
803 (FamEqn { feqn_rhs = HsDataDefn { dd_ND = nd }})})
804 = ppr nd
805
806 pprHsFamInstLHS :: (OutputableBndrId p)
807 => IdP (GhcPass p)
808 -> HsOuterFamEqnTyVarBndrs (GhcPass p)
809 -> HsTyPats (GhcPass p)
810 -> LexicalFixity
811 -> Maybe (LHsContext (GhcPass p))
812 -> SDoc
813 pprHsFamInstLHS thing bndrs typats fixity mb_ctxt
814 = hsep [ pprHsOuterFamEqnTyVarBndrs bndrs
815 , pprLHsContext mb_ctxt
816 , pprHsArgsApp thing fixity typats ]
817
818 instance OutputableBndrId p
819 => Outputable (ClsInstDecl (GhcPass p)) where
820 ppr (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = binds
821 , cid_sigs = sigs, cid_tyfam_insts = ats
822 , cid_overlap_mode = mbOverlap
823 , cid_datafam_insts = adts })
824 | null sigs, null ats, null adts, isEmptyBag binds -- No "where" part
825 = top_matter
826
827 | otherwise -- Laid out
828 = vcat [ top_matter <+> text "where"
829 , nest 2 $ pprDeclList $
830 map (pprTyFamInstDecl NotTopLevel . unLoc) ats ++
831 map (pprDataFamInstDecl NotTopLevel . unLoc) adts ++
832 pprLHsBindsForUser binds sigs ]
833 where
834 top_matter = text "instance" <+> ppOverlapPragma mbOverlap
835 <+> ppr inst_ty
836
837 ppDerivStrategy :: OutputableBndrId p
838 => Maybe (LDerivStrategy (GhcPass p)) -> SDoc
839 ppDerivStrategy mb =
840 case mb of
841 Nothing -> empty
842 Just (L _ ds) -> ppr ds
843
844 ppOverlapPragma :: Maybe (LocatedP OverlapMode) -> SDoc
845 ppOverlapPragma mb =
846 case mb of
847 Nothing -> empty
848 Just (L _ (NoOverlap s)) -> maybe_stext s "{-# NO_OVERLAP #-}"
849 Just (L _ (Overlappable s)) -> maybe_stext s "{-# OVERLAPPABLE #-}"
850 Just (L _ (Overlapping s)) -> maybe_stext s "{-# OVERLAPPING #-}"
851 Just (L _ (Overlaps s)) -> maybe_stext s "{-# OVERLAPS #-}"
852 Just (L _ (Incoherent s)) -> maybe_stext s "{-# INCOHERENT #-}"
853 where
854 maybe_stext NoSourceText alt = text alt
855 maybe_stext (SourceText src) _ = text src <+> text "#-}"
856
857
858 instance (OutputableBndrId p) => Outputable (InstDecl (GhcPass p)) where
859 ppr (ClsInstD { cid_inst = decl }) = ppr decl
860 ppr (TyFamInstD { tfid_inst = decl }) = ppr decl
861 ppr (DataFamInstD { dfid_inst = decl }) = ppr decl
862
863 -- Extract the declarations of associated data types from an instance
864
865 instDeclDataFamInsts :: [LInstDecl (GhcPass p)] -> [DataFamInstDecl (GhcPass p)]
866 instDeclDataFamInsts inst_decls
867 = concatMap do_one inst_decls
868 where
869 do_one :: LInstDecl (GhcPass p) -> [DataFamInstDecl (GhcPass p)]
870 do_one (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fam_insts } }))
871 = map unLoc fam_insts
872 do_one (L _ (DataFamInstD { dfid_inst = fam_inst })) = [fam_inst]
873 do_one (L _ (TyFamInstD {})) = []
874
875 {-
876 ************************************************************************
877 * *
878 \subsection[DerivDecl]{A stand-alone instance deriving declaration}
879 * *
880 ************************************************************************
881 -}
882
883 type instance XCDerivDecl (GhcPass _) = EpAnn [AddEpAnn]
884 type instance XXDerivDecl (GhcPass _) = NoExtCon
885
886 type instance Anno OverlapMode = SrcSpanAnnP
887
888 instance OutputableBndrId p
889 => Outputable (DerivDecl (GhcPass p)) where
890 ppr (DerivDecl { deriv_type = ty
891 , deriv_strategy = ds
892 , deriv_overlap_mode = o })
893 = hsep [ text "deriving"
894 , ppDerivStrategy ds
895 , text "instance"
896 , ppOverlapPragma o
897 , ppr ty ]
898
899 {-
900 ************************************************************************
901 * *
902 Deriving strategies
903 * *
904 ************************************************************************
905 -}
906
907 type instance XStockStrategy GhcPs = EpAnn [AddEpAnn]
908 type instance XStockStrategy GhcRn = NoExtField
909 type instance XStockStrategy GhcTc = NoExtField
910
911 type instance XAnyClassStrategy GhcPs = EpAnn [AddEpAnn]
912 type instance XAnyClassStrategy GhcRn = NoExtField
913 type instance XAnyClassStrategy GhcTc = NoExtField
914
915 type instance XNewtypeStrategy GhcPs = EpAnn [AddEpAnn]
916 type instance XNewtypeStrategy GhcRn = NoExtField
917 type instance XNewtypeStrategy GhcTc = NoExtField
918
919 type instance XViaStrategy GhcPs = XViaStrategyPs
920 type instance XViaStrategy GhcRn = LHsSigType GhcRn
921 type instance XViaStrategy GhcTc = Type
922
923 data XViaStrategyPs = XViaStrategyPs (EpAnn [AddEpAnn]) (LHsSigType GhcPs)
924
925 instance OutputableBndrId p
926 => Outputable (DerivStrategy (GhcPass p)) where
927 ppr (StockStrategy _) = text "stock"
928 ppr (AnyclassStrategy _) = text "anyclass"
929 ppr (NewtypeStrategy _) = text "newtype"
930 ppr (ViaStrategy ty) = text "via" <+> case ghcPass @p of
931 GhcPs -> ppr ty
932 GhcRn -> ppr ty
933 GhcTc -> ppr ty
934
935 instance Outputable XViaStrategyPs where
936 ppr (XViaStrategyPs _ t) = ppr t
937
938
939 -- | Eliminate a 'DerivStrategy'.
940 foldDerivStrategy :: (p ~ GhcPass pass)
941 => r -> (XViaStrategy p -> r) -> DerivStrategy p -> r
942 foldDerivStrategy other _ (StockStrategy _) = other
943 foldDerivStrategy other _ (AnyclassStrategy _) = other
944 foldDerivStrategy other _ (NewtypeStrategy _) = other
945 foldDerivStrategy _ via (ViaStrategy t) = via t
946
947 -- | Map over the @via@ type if dealing with 'ViaStrategy'. Otherwise,
948 -- return the 'DerivStrategy' unchanged.
949 mapDerivStrategy :: (p ~ GhcPass pass)
950 => (XViaStrategy p -> XViaStrategy p)
951 -> DerivStrategy p -> DerivStrategy p
952 mapDerivStrategy f ds = foldDerivStrategy ds (ViaStrategy . f) ds
953
954 {-
955 ************************************************************************
956 * *
957 \subsection[DefaultDecl]{A @default@ declaration}
958 * *
959 ************************************************************************
960 -}
961
962 type instance XCDefaultDecl GhcPs = EpAnn [AddEpAnn]
963 type instance XCDefaultDecl GhcRn = NoExtField
964 type instance XCDefaultDecl GhcTc = NoExtField
965
966 type instance XXDefaultDecl (GhcPass _) = NoExtCon
967
968 instance OutputableBndrId p
969 => Outputable (DefaultDecl (GhcPass p)) where
970 ppr (DefaultDecl _ tys)
971 = text "default" <+> parens (interpp'SP tys)
972
973 {-
974 ************************************************************************
975 * *
976 \subsection{Foreign function interface declaration}
977 * *
978 ************************************************************************
979 -}
980
981 type instance XForeignImport GhcPs = EpAnn [AddEpAnn]
982 type instance XForeignImport GhcRn = NoExtField
983 type instance XForeignImport GhcTc = Coercion
984
985 type instance XForeignExport GhcPs = EpAnn [AddEpAnn]
986 type instance XForeignExport GhcRn = NoExtField
987 type instance XForeignExport GhcTc = Coercion
988
989 type instance XXForeignDecl (GhcPass _) = NoExtCon
990
991 instance OutputableBndrId p
992 => Outputable (ForeignDecl (GhcPass p)) where
993 ppr (ForeignImport { fd_name = n, fd_sig_ty = ty, fd_fi = fimport })
994 = hang (text "foreign import" <+> ppr fimport <+> ppr n)
995 2 (dcolon <+> ppr ty)
996 ppr (ForeignExport { fd_name = n, fd_sig_ty = ty, fd_fe = fexport }) =
997 hang (text "foreign export" <+> ppr fexport <+> ppr n)
998 2 (dcolon <+> ppr ty)
999
1000 {-
1001 ************************************************************************
1002 * *
1003 \subsection{Rewrite rules}
1004 * *
1005 ************************************************************************
1006 -}
1007
1008 type instance XCRuleDecls GhcPs = EpAnn [AddEpAnn]
1009 type instance XCRuleDecls GhcRn = NoExtField
1010 type instance XCRuleDecls GhcTc = NoExtField
1011
1012 type instance XXRuleDecls (GhcPass _) = NoExtCon
1013
1014 type instance XHsRule GhcPs = EpAnn HsRuleAnn
1015 type instance XHsRule GhcRn = HsRuleRn
1016 type instance XHsRule GhcTc = HsRuleRn
1017
1018 type instance XXRuleDecl (GhcPass _) = NoExtCon
1019
1020 type instance Anno (SourceText, RuleName) = SrcAnn NoEpAnns
1021
1022 data HsRuleAnn
1023 = HsRuleAnn
1024 { ra_tyanns :: Maybe (AddEpAnn, AddEpAnn)
1025 -- ^ The locations of 'forall' and '.' for forall'd type vars
1026 -- Using AddEpAnn to capture possible unicode variants
1027 , ra_tmanns :: Maybe (AddEpAnn, AddEpAnn)
1028 -- ^ The locations of 'forall' and '.' for forall'd term vars
1029 -- Using AddEpAnn to capture possible unicode variants
1030 , ra_rest :: [AddEpAnn]
1031 } deriving (Data, Eq)
1032
1033 flattenRuleDecls :: [LRuleDecls (GhcPass p)] -> [LRuleDecl (GhcPass p)]
1034 flattenRuleDecls decls = concatMap (rds_rules . unLoc) decls
1035
1036 type instance XCRuleBndr (GhcPass _) = EpAnn [AddEpAnn]
1037 type instance XRuleBndrSig (GhcPass _) = EpAnn [AddEpAnn]
1038 type instance XXRuleBndr (GhcPass _) = NoExtCon
1039
1040 instance (OutputableBndrId p) => Outputable (RuleDecls (GhcPass p)) where
1041 ppr (HsRules { rds_src = st
1042 , rds_rules = rules })
1043 = pprWithSourceText st (text "{-# RULES")
1044 <+> vcat (punctuate semi (map ppr rules)) <+> text "#-}"
1045
1046 instance (OutputableBndrId p) => Outputable (RuleDecl (GhcPass p)) where
1047 ppr (HsRule { rd_name = name
1048 , rd_act = act
1049 , rd_tyvs = tys
1050 , rd_tmvs = tms
1051 , rd_lhs = lhs
1052 , rd_rhs = rhs })
1053 = sep [pprFullRuleName name <+> ppr act,
1054 nest 4 (pp_forall_ty tys <+> pp_forall_tm tys
1055 <+> pprExpr (unLoc lhs)),
1056 nest 6 (equals <+> pprExpr (unLoc rhs)) ]
1057 where
1058 pp_forall_ty Nothing = empty
1059 pp_forall_ty (Just qtvs) = forAllLit <+> fsep (map ppr qtvs) <> dot
1060 pp_forall_tm Nothing | null tms = empty
1061 pp_forall_tm _ = forAllLit <+> fsep (map ppr tms) <> dot
1062
1063 instance (OutputableBndrId p) => Outputable (RuleBndr (GhcPass p)) where
1064 ppr (RuleBndr _ name) = ppr name
1065 ppr (RuleBndrSig _ name ty) = parens (ppr name <> dcolon <> ppr ty)
1066
1067 {-
1068 ************************************************************************
1069 * *
1070 \subsection[DeprecDecl]{Deprecations}
1071 * *
1072 ************************************************************************
1073 -}
1074
1075 type instance XWarnings GhcPs = EpAnn [AddEpAnn]
1076 type instance XWarnings GhcRn = NoExtField
1077 type instance XWarnings GhcTc = NoExtField
1078
1079 type instance XXWarnDecls (GhcPass _) = NoExtCon
1080
1081 type instance XWarning (GhcPass _) = EpAnn [AddEpAnn]
1082 type instance XXWarnDecl (GhcPass _) = NoExtCon
1083
1084
1085 instance OutputableBndrId p
1086 => Outputable (WarnDecls (GhcPass p)) where
1087 ppr (Warnings _ (SourceText src) decls)
1088 = text src <+> vcat (punctuate comma (map ppr decls)) <+> text "#-}"
1089 ppr (Warnings _ NoSourceText _decls) = panic "WarnDecls"
1090
1091 instance OutputableBndrId p
1092 => Outputable (WarnDecl (GhcPass p)) where
1093 ppr (Warning _ thing txt)
1094 = hsep ( punctuate comma (map ppr thing))
1095 <+> ppr txt
1096
1097 {-
1098 ************************************************************************
1099 * *
1100 \subsection[AnnDecl]{Annotations}
1101 * *
1102 ************************************************************************
1103 -}
1104
1105 type instance XHsAnnotation (GhcPass _) = EpAnn AnnPragma
1106 type instance XXAnnDecl (GhcPass _) = NoExtCon
1107
1108 instance (OutputableBndrId p) => Outputable (AnnDecl (GhcPass p)) where
1109 ppr (HsAnnotation _ _ provenance expr)
1110 = hsep [text "{-#", pprAnnProvenance provenance, pprExpr (unLoc expr), text "#-}"]
1111
1112 pprAnnProvenance :: OutputableBndrId p => AnnProvenance (GhcPass p) -> SDoc
1113 pprAnnProvenance ModuleAnnProvenance = text "ANN module"
1114 pprAnnProvenance (ValueAnnProvenance (L _ name))
1115 = text "ANN" <+> ppr name
1116 pprAnnProvenance (TypeAnnProvenance (L _ name))
1117 = text "ANN type" <+> ppr name
1118
1119 {-
1120 ************************************************************************
1121 * *
1122 \subsection[RoleAnnot]{Role annotations}
1123 * *
1124 ************************************************************************
1125 -}
1126
1127 type instance XCRoleAnnotDecl GhcPs = EpAnn [AddEpAnn]
1128 type instance XCRoleAnnotDecl GhcRn = NoExtField
1129 type instance XCRoleAnnotDecl GhcTc = NoExtField
1130
1131 type instance XXRoleAnnotDecl (GhcPass _) = NoExtCon
1132
1133 type instance Anno (Maybe Role) = SrcAnn NoEpAnns
1134
1135 instance OutputableBndr (IdP (GhcPass p))
1136 => Outputable (RoleAnnotDecl (GhcPass p)) where
1137 ppr (RoleAnnotDecl _ ltycon roles)
1138 = text "type role" <+> pprPrefixOcc (unLoc ltycon) <+>
1139 hsep (map (pp_role . unLoc) roles)
1140 where
1141 pp_role Nothing = underscore
1142 pp_role (Just r) = ppr r
1143
1144 roleAnnotDeclName :: RoleAnnotDecl (GhcPass p) -> IdP (GhcPass p)
1145 roleAnnotDeclName (RoleAnnotDecl _ (L _ name) _) = name
1146
1147 {-
1148 ************************************************************************
1149 * *
1150 \subsection{Anno instances}
1151 * *
1152 ************************************************************************
1153 -}
1154
1155 type instance Anno (HsDecl (GhcPass _)) = SrcSpanAnnA
1156 type instance Anno (SpliceDecl (GhcPass p)) = SrcSpanAnnA
1157 type instance Anno (TyClDecl (GhcPass p)) = SrcSpanAnnA
1158 type instance Anno (FunDep (GhcPass p)) = SrcSpanAnnA
1159 type instance Anno (FamilyResultSig (GhcPass p)) = SrcAnn NoEpAnns
1160 type instance Anno (FamilyDecl (GhcPass p)) = SrcSpanAnnA
1161 type instance Anno (InjectivityAnn (GhcPass p)) = SrcAnn NoEpAnns
1162 type instance Anno CType = SrcSpanAnnP
1163 type instance Anno (HsDerivingClause (GhcPass p)) = SrcAnn NoEpAnns
1164 type instance Anno (DerivClauseTys (GhcPass _)) = SrcSpanAnnC
1165 type instance Anno (StandaloneKindSig (GhcPass p)) = SrcSpanAnnA
1166 type instance Anno (ConDecl (GhcPass p)) = SrcSpanAnnA
1167 type instance Anno Bool = SrcAnn NoEpAnns
1168 type instance Anno [LocatedA (ConDeclField (GhcPass _))] = SrcSpanAnnL
1169 type instance Anno (FamEqn p (LocatedA (HsType p))) = SrcSpanAnnA
1170 type instance Anno (TyFamInstDecl (GhcPass p)) = SrcSpanAnnA
1171 type instance Anno (DataFamInstDecl (GhcPass p)) = SrcSpanAnnA
1172 type instance Anno (FamEqn (GhcPass p) _) = SrcSpanAnnA
1173 type instance Anno (ClsInstDecl (GhcPass p)) = SrcSpanAnnA
1174 type instance Anno (InstDecl (GhcPass p)) = SrcSpanAnnA
1175 type instance Anno DocDecl = SrcSpanAnnA
1176 type instance Anno (DerivDecl (GhcPass p)) = SrcSpanAnnA
1177 type instance Anno OverlapMode = SrcSpanAnnP
1178 type instance Anno (DerivStrategy (GhcPass p)) = SrcAnn NoEpAnns
1179 type instance Anno (DefaultDecl (GhcPass p)) = SrcSpanAnnA
1180 type instance Anno (ForeignDecl (GhcPass p)) = SrcSpanAnnA
1181 type instance Anno (RuleDecls (GhcPass p)) = SrcSpanAnnA
1182 type instance Anno (RuleDecl (GhcPass p)) = SrcSpanAnnA
1183 type instance Anno (SourceText, RuleName) = SrcAnn NoEpAnns
1184 type instance Anno (RuleBndr (GhcPass p)) = SrcAnn NoEpAnns
1185 type instance Anno (WarnDecls (GhcPass p)) = SrcSpanAnnA
1186 type instance Anno (WarnDecl (GhcPass p)) = SrcSpanAnnA
1187 type instance Anno (AnnDecl (GhcPass p)) = SrcSpanAnnA
1188 type instance Anno (RoleAnnotDecl (GhcPass p)) = SrcSpanAnnA
1189 type instance Anno (Maybe Role) = SrcAnn NoEpAnns