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