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