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