never executed always true always false
    1 {-# LANGUAGE ConstraintKinds #-}
    2 {-|
    3 Module      : GHC.Hs.Utils
    4 Description : Generic helpers for the HsSyn type.
    5 Copyright   : (c) The University of Glasgow, 1992-2006
    6 
    7 Here we collect a variety of helper functions that construct or
    8 analyse HsSyn.  All these functions deal with generic HsSyn; functions
    9 which deal with the instantiated versions are located elsewhere:
   10 
   11    Parameterised by          Module
   12    ----------------          -------------
   13    GhcPs/RdrName             GHC.Parser.PostProcess
   14    GhcRn/Name                GHC.Rename.*
   15    GhcTc/Id                  GHC.Tc.Utils.Zonk
   16 
   17 The @mk*@ functions attempt to construct a not-completely-useless SrcSpan
   18 from their components, compared with the @nl*@ functions which
   19 just attach noSrcSpan to everything.
   20 
   21 -}
   22 
   23 
   24 {-# LANGUAGE ScopedTypeVariables #-}
   25 {-# LANGUAGE FlexibleContexts #-}
   26 {-# LANGUAGE TypeFamilies #-}
   27 {-# LANGUAGE PatternSynonyms #-}
   28 {-# LANGUAGE ViewPatterns #-}
   29 {-# LANGUAGE TypeApplications #-}
   30 {-# LANGUAGE DataKinds #-}
   31 {-# LANGUAGE FlexibleInstances #-}
   32 {-# LANGUAGE LambdaCase #-}
   33 {-# LANGUAGE GADTs #-}
   34 
   35 {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
   36 
   37 module GHC.Hs.Utils(
   38   -- * Terms
   39   mkHsPar, mkHsApp, mkHsAppWith, mkHsApps, mkHsAppsWith,
   40   mkHsAppType, mkHsAppTypes, mkHsCaseAlt,
   41   mkSimpleMatch, unguardedGRHSs, unguardedRHS,
   42   mkMatchGroup, mkMatch, mkPrefixFunRhs, mkHsLam, mkHsIf,
   43   mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo,
   44   mkHsDictLet, mkHsLams,
   45   mkHsOpApp, mkHsDo, mkHsDoAnns, mkHsComp, mkHsCompAnns, mkHsWrapPat, mkHsWrapPatCo,
   46   mkLHsPar, mkHsCmdWrap, mkLHsCmdWrap,
   47   mkHsCmdIf, mkConLikeTc,
   48 
   49   nlHsTyApp, nlHsTyApps, nlHsVar, nl_HsVar, nlHsDataCon,
   50   nlHsLit, nlHsApp, nlHsApps, nlHsSyntaxApps,
   51   nlHsIntLit, nlHsVarApps,
   52   nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,
   53   mkLHsTupleExpr, mkLHsVarTuple, missingTupArg,
   54   mkLocatedList,
   55 
   56   -- * Constructing general big tuples
   57   -- $big_tuples
   58   mkChunkified, chunkify,
   59 
   60   -- * Bindings
   61   mkFunBind, mkVarBind, mkHsVarBind, mkSimpleGeneratedFunBind, mkTopFunBind,
   62   mkPatSynBind,
   63   isInfixFunBind,
   64   spanHsLocaLBinds,
   65 
   66   -- * Literals
   67   mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, mkHsStringPrimLit,
   68   mkHsCharPrimLit,
   69 
   70   -- * Patterns
   71   mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConVarPatName, nlConPat,
   72   nlConPatName, nlInfixConPat, nlNullaryConPat, nlWildConPat, nlWildPat,
   73   nlWildPatName, nlTuplePat, mkParPat, nlParPat,
   74   mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup,
   75 
   76   -- * Types
   77   mkHsAppTy, mkHsAppKindTy,
   78   hsTypeToHsSigType, hsTypeToHsSigWcType, mkClassOpSigs, mkHsSigEnv,
   79   nlHsAppTy, nlHsAppKindTy, nlHsTyVar, nlHsFunTy, nlHsParTy, nlHsTyConApp,
   80 
   81   -- * Stmts
   82   mkTransformStmt, mkTransformByStmt, mkBodyStmt,
   83   mkPsBindStmt, mkRnBindStmt, mkTcBindStmt,
   84   mkLastStmt,
   85   emptyTransStmt, mkGroupUsingStmt, mkGroupByUsingStmt,
   86   emptyRecStmt, emptyRecStmtName, emptyRecStmtId, mkRecStmt,
   87   unitRecStmtTc,
   88   mkLetStmt,
   89 
   90   -- * Template Haskell
   91   mkUntypedSplice, mkTypedSplice,
   92   mkHsQuasiQuote,
   93 
   94   -- * Collecting binders
   95   isUnliftedHsBind, isBangedHsBind,
   96 
   97   collectLocalBinders, collectHsValBinders, collectHsBindListBinders,
   98   collectHsIdBinders,
   99   collectHsBindsBinders, collectHsBindBinders, collectMethodBinders,
  100 
  101   collectPatBinders, collectPatsBinders,
  102   collectLStmtsBinders, collectStmtsBinders,
  103   collectLStmtBinders, collectStmtBinders,
  104   CollectPass(..), CollectFlag(..),
  105 
  106   hsLTyClDeclBinders, hsTyClForeignBinders,
  107   hsPatSynSelectors, getPatSynBinds,
  108   hsForeignDeclsBinders, hsGroupBinders, hsDataFamInstBinders,
  109 
  110   -- * Collecting implicit binders
  111   lStmtsImplicits, hsValBindsImplicits, lPatImplicits
  112   ) where
  113 
  114 import GHC.Prelude
  115 
  116 import GHC.Hs.Decls
  117 import GHC.Hs.Binds
  118 import GHC.Hs.Expr
  119 import GHC.Hs.Pat
  120 import GHC.Hs.Type
  121 import GHC.Hs.Lit
  122 import Language.Haskell.Syntax.Extension
  123 import GHC.Hs.Extension
  124 import GHC.Parser.Annotation
  125 
  126 import GHC.Tc.Types.Evidence
  127 import GHC.Core.TyCo.Rep
  128 import GHC.Core.Multiplicity ( pattern Many )
  129 import GHC.Builtin.Types ( unitTy )
  130 import GHC.Tc.Utils.TcType
  131 import GHC.Core.DataCon
  132 import GHC.Core.ConLike
  133 import GHC.Types.Id
  134 import GHC.Types.Name
  135 import GHC.Types.Name.Set hiding ( unitFV )
  136 import GHC.Types.Name.Env
  137 import GHC.Types.Name.Reader
  138 import GHC.Types.Var
  139 import GHC.Types.Basic
  140 import GHC.Types.SrcLoc
  141 import GHC.Types.Fixity
  142 import GHC.Types.SourceText
  143 import GHC.Data.FastString
  144 import GHC.Data.Bag
  145 import GHC.Settings.Constants
  146 
  147 import GHC.Utils.Misc
  148 import GHC.Utils.Outputable
  149 import GHC.Utils.Panic
  150 
  151 import Data.Either
  152 import Data.Function
  153 import Data.List ( partition, deleteBy )
  154 import Data.Proxy
  155 
  156 {-
  157 ************************************************************************
  158 *                                                                      *
  159         Some useful helpers for constructing syntax
  160 *                                                                      *
  161 ************************************************************************
  162 
  163 These functions attempt to construct a not-completely-useless 'SrcSpan'
  164 from their components, compared with the @nl*@ functions below which
  165 just attach 'noSrcSpan' to everything.
  166 -}
  167 
  168 -- | @e => (e)@
  169 mkHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
  170 mkHsPar e = L (getLoc e) (gHsPar e)
  171 
  172 mkSimpleMatch :: (Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
  173                         ~ SrcSpanAnnA,
  174                   Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
  175                         ~ SrcAnn NoEpAnns)
  176               => HsMatchContext (GhcPass p)
  177               -> [LPat (GhcPass p)] -> LocatedA (body (GhcPass p))
  178               -> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
  179 mkSimpleMatch ctxt pats rhs
  180   = L loc $
  181     Match { m_ext = noAnn, m_ctxt = ctxt, m_pats = pats
  182           , m_grhss = unguardedGRHSs (locA loc) rhs noAnn }
  183   where
  184     loc = case pats of
  185                 []      -> getLoc rhs
  186                 (pat:_) -> combineSrcSpansA (getLoc pat) (getLoc rhs)
  187 
  188 unguardedGRHSs :: Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
  189                      ~ SrcAnn NoEpAnns
  190                => SrcSpan -> LocatedA (body (GhcPass p)) -> EpAnn GrhsAnn
  191                -> GRHSs (GhcPass p) (LocatedA (body (GhcPass p)))
  192 unguardedGRHSs loc rhs an
  193   = GRHSs emptyComments (unguardedRHS an loc rhs) emptyLocalBinds
  194 
  195 unguardedRHS :: Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
  196                      ~ SrcAnn NoEpAnns
  197              => EpAnn GrhsAnn -> SrcSpan -> LocatedA (body (GhcPass p))
  198              -> [LGRHS (GhcPass p) (LocatedA (body (GhcPass p)))]
  199 unguardedRHS an loc rhs = [L (noAnnSrcSpan loc) (GRHS an [] rhs)]
  200 
  201 type AnnoBody p body
  202   = ( XMG (GhcPass p) (LocatedA (body (GhcPass p))) ~ NoExtField
  203     , Anno [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))] ~ SrcSpanAnnL
  204     , Anno (Match (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpanAnnA
  205     )
  206 
  207 mkMatchGroup :: AnnoBody p body
  208              => Origin
  209              -> LocatedL [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]
  210              -> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))
  211 mkMatchGroup origin matches = MG { mg_ext = noExtField
  212                                  , mg_alts = matches
  213                                  , mg_origin = origin }
  214 
  215 mkLocatedList :: Semigroup a
  216   => [GenLocated (SrcAnn a) e2] -> LocatedAn an [GenLocated (SrcAnn a) e2]
  217 mkLocatedList [] = noLocA []
  218 mkLocatedList ms = L (noAnnSrcSpan $ locA $ combineLocsA (head ms) (last ms)) ms
  219 
  220 mkHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
  221 mkHsApp e1 e2 = addCLocAA e1 e2 (HsApp noComments e1 e2)
  222 
  223 mkHsAppWith
  224   :: (LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> HsExpr (GhcPass id) -> LHsExpr (GhcPass id))
  225   -> LHsExpr (GhcPass id)
  226   -> LHsExpr (GhcPass id)
  227   -> LHsExpr (GhcPass id)
  228 mkHsAppWith mkLocated e1 e2 = mkLocated e1 e2 (HsApp noAnn e1 e2)
  229 
  230 mkHsApps
  231   :: LHsExpr (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
  232 mkHsApps = mkHsAppsWith addCLocAA
  233 
  234 mkHsAppsWith
  235  :: (LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> HsExpr (GhcPass id) -> LHsExpr (GhcPass id))
  236  -> LHsExpr (GhcPass id)
  237  -> [LHsExpr (GhcPass id)]
  238  -> LHsExpr (GhcPass id)
  239 mkHsAppsWith mkLocated = foldl' (mkHsAppWith mkLocated)
  240 
  241 mkHsAppType :: LHsExpr GhcRn -> LHsWcType GhcRn -> LHsExpr GhcRn
  242 mkHsAppType e t = addCLocAA t_body e (HsAppType noExtField e paren_wct)
  243   where
  244     t_body    = hswc_body t
  245     paren_wct = t { hswc_body = parenthesizeHsType appPrec t_body }
  246 
  247 mkHsAppTypes :: LHsExpr GhcRn -> [LHsWcType GhcRn] -> LHsExpr GhcRn
  248 mkHsAppTypes = foldl' mkHsAppType
  249 
  250 mkHsLam :: (IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExtField)
  251         => [LPat (GhcPass p)]
  252         -> LHsExpr (GhcPass p)
  253         -> LHsExpr (GhcPass p)
  254 mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam noExtField matches))
  255   where
  256     matches = mkMatchGroup Generated
  257                            (noLocA [mkSimpleMatch LambdaExpr pats' body])
  258     pats' = map (parenthesizePat appPrec) pats
  259 
  260 mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr GhcTc -> LHsExpr GhcTc
  261 mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars
  262                                        <.> mkWpLams dicts) expr
  263 
  264 -- |A simple case alternative with a single pattern, no binds, no guards;
  265 -- pre-typechecking
  266 mkHsCaseAlt :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
  267                      ~ SrcAnn NoEpAnns,
  268                  Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
  269                         ~ SrcSpanAnnA)
  270             => LPat (GhcPass p) -> (LocatedA (body (GhcPass p)))
  271             -> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
  272 mkHsCaseAlt pat expr
  273   = mkSimpleMatch CaseAlt [pat] expr
  274 
  275 nlHsTyApp :: Id -> [Type] -> LHsExpr GhcTc
  276 nlHsTyApp fun_id tys
  277   = noLocA (mkHsWrap (mkWpTyApps tys) (HsVar noExtField (noLocA fun_id)))
  278 
  279 nlHsTyApps :: Id -> [Type] -> [LHsExpr GhcTc] -> LHsExpr GhcTc
  280 nlHsTyApps fun_id tys xs = foldl' nlHsApp (nlHsTyApp fun_id tys) xs
  281 
  282 --------- Adding parens ---------
  283 -- | Wrap in parens if @'hsExprNeedsParens' appPrec@ says it needs them
  284 -- So @f x@ becomes @(f x)@, but @3@ stays as @3@.
  285 mkLHsPar :: IsPass id => LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
  286 mkLHsPar = parenthesizeHsExpr appPrec
  287 
  288 mkParPat :: IsPass p => LPat (GhcPass p) -> LPat (GhcPass p)
  289 mkParPat = parenthesizePat appPrec
  290 
  291 nlParPat :: LPat (GhcPass name) -> LPat (GhcPass name)
  292 nlParPat p = noLocA (gParPat p)
  293 
  294 -------------------------------
  295 -- These are the bits of syntax that contain rebindable names
  296 -- See GHC.Rename.Env.lookupSyntax
  297 
  298 mkHsIntegral   :: IntegralLit -> HsOverLit GhcPs
  299 mkHsFractional :: FractionalLit -> HsOverLit GhcPs
  300 mkHsIsString   :: SourceText -> FastString -> HsOverLit GhcPs
  301 mkHsDo         :: HsDoFlavour -> LocatedL [ExprLStmt GhcPs] -> HsExpr GhcPs
  302 mkHsDoAnns     :: HsDoFlavour -> LocatedL [ExprLStmt GhcPs] -> EpAnn AnnList -> HsExpr GhcPs
  303 mkHsComp       :: HsDoFlavour -> [ExprLStmt GhcPs] -> LHsExpr GhcPs
  304                -> HsExpr GhcPs
  305 mkHsCompAnns   :: HsDoFlavour -> [ExprLStmt GhcPs] -> LHsExpr GhcPs
  306                -> EpAnn AnnList
  307                -> HsExpr GhcPs
  308 
  309 mkNPat      :: LocatedAn NoEpAnns (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs) -> EpAnn [AddEpAnn]
  310             -> Pat GhcPs
  311 mkNPlusKPat :: LocatedN RdrName -> LocatedAn NoEpAnns (HsOverLit GhcPs) -> EpAnn EpaLocation
  312             -> Pat GhcPs
  313 
  314 -- NB: The following functions all use noSyntaxExpr: the generated expressions
  315 --     will not work with rebindable syntax if used after the renamer
  316 mkLastStmt :: IsPass idR => LocatedA (bodyR (GhcPass idR))
  317            -> StmtLR (GhcPass idL) (GhcPass idR) (LocatedA (bodyR (GhcPass idR)))
  318 mkBodyStmt :: LocatedA (bodyR GhcPs)
  319            -> StmtLR (GhcPass idL) GhcPs (LocatedA (bodyR GhcPs))
  320 mkPsBindStmt :: EpAnn [AddEpAnn] -> LPat GhcPs -> LocatedA (bodyR GhcPs)
  321              -> StmtLR GhcPs GhcPs (LocatedA (bodyR GhcPs))
  322 mkRnBindStmt :: LPat GhcRn -> LocatedA (bodyR GhcRn)
  323              -> StmtLR GhcRn GhcRn (LocatedA (bodyR GhcRn))
  324 mkTcBindStmt :: LPat GhcTc -> LocatedA (bodyR GhcTc)
  325              -> StmtLR GhcTc GhcTc (LocatedA (bodyR GhcTc))
  326 
  327 emptyRecStmt     :: (Anno [GenLocated
  328                              (Anno (StmtLR (GhcPass idL) GhcPs bodyR))
  329                              (StmtLR (GhcPass idL) GhcPs bodyR)]
  330                         ~ SrcSpanAnnL)
  331                  => StmtLR (GhcPass idL) GhcPs bodyR
  332 emptyRecStmtName :: (Anno [GenLocated
  333                              (Anno (StmtLR GhcRn GhcRn bodyR))
  334                              (StmtLR GhcRn GhcRn bodyR)]
  335                         ~ SrcSpanAnnL)
  336                  => StmtLR GhcRn GhcRn bodyR
  337 emptyRecStmtId   :: Stmt GhcTc (LocatedA (HsCmd GhcTc))
  338 mkRecStmt        :: (Anno [GenLocated
  339                              (Anno (StmtLR (GhcPass idL) GhcPs bodyR))
  340                              (StmtLR (GhcPass idL) GhcPs bodyR)]
  341                         ~ SrcSpanAnnL)
  342                  => EpAnn AnnList
  343                  -> LocatedL [LStmtLR (GhcPass idL) GhcPs bodyR]
  344                  -> StmtLR (GhcPass idL) GhcPs bodyR
  345 
  346 
  347 mkHsIntegral     i  = OverLit noExtField (HsIntegral       i)
  348 mkHsFractional   f  = OverLit noExtField (HsFractional     f)
  349 mkHsIsString src s  = OverLit noExtField (HsIsString   src s)
  350 
  351 mkHsDo     ctxt stmts      = HsDo noAnn ctxt stmts
  352 mkHsDoAnns ctxt stmts anns = HsDo anns  ctxt stmts
  353 mkHsComp ctxt stmts expr = mkHsCompAnns ctxt stmts expr noAnn
  354 mkHsCompAnns ctxt stmts expr anns = mkHsDoAnns ctxt (mkLocatedList (stmts ++ [last_stmt])) anns
  355   where
  356     -- Strip the annotations from the location, they are in the embedded expr
  357     last_stmt = L (noAnnSrcSpan $ getLocA expr) $ mkLastStmt expr
  358 
  359 -- restricted to GhcPs because other phases might need a SyntaxExpr
  360 mkHsIf :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> EpAnn AnnsIf
  361        -> HsExpr GhcPs
  362 mkHsIf c a b anns = HsIf anns c a b
  363 
  364 -- restricted to GhcPs because other phases might need a SyntaxExpr
  365 mkHsCmdIf :: LHsExpr GhcPs -> LHsCmd GhcPs -> LHsCmd GhcPs -> EpAnn AnnsIf
  366        -> HsCmd GhcPs
  367 mkHsCmdIf c a b anns = HsCmdIf anns noSyntaxExpr c a b
  368 
  369 mkNPat lit neg anns  = NPat anns lit neg noSyntaxExpr
  370 mkNPlusKPat id lit anns
  371   = NPlusKPat anns id lit (unLoc lit) noSyntaxExpr noSyntaxExpr
  372 
  373 mkTransformStmt    :: EpAnn [AddEpAnn] -> [ExprLStmt GhcPs] -> LHsExpr GhcPs
  374                    -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
  375 mkTransformByStmt  :: EpAnn [AddEpAnn] -> [ExprLStmt GhcPs] -> LHsExpr GhcPs
  376                    -> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
  377 mkGroupUsingStmt   :: EpAnn [AddEpAnn] -> [ExprLStmt GhcPs] -> LHsExpr GhcPs
  378                    -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
  379 mkGroupByUsingStmt :: EpAnn [AddEpAnn] -> [ExprLStmt GhcPs] -> LHsExpr GhcPs
  380                    -> LHsExpr GhcPs
  381                    -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
  382 
  383 emptyTransStmt :: EpAnn [AddEpAnn] -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
  384 emptyTransStmt anns = TransStmt { trS_ext = anns
  385                                 , trS_form = panic "emptyTransStmt: form"
  386                                 , trS_stmts = [], trS_bndrs = []
  387                                 , trS_by = Nothing, trS_using = noLocA noExpr
  388                                 , trS_ret = noSyntaxExpr, trS_bind = noSyntaxExpr
  389                                 , trS_fmap = noExpr }
  390 mkTransformStmt    a ss u   = (emptyTransStmt a) { trS_form = ThenForm,  trS_stmts = ss, trS_using = u }
  391 mkTransformByStmt  a ss u b = (emptyTransStmt a) { trS_form = ThenForm,  trS_stmts = ss, trS_using = u, trS_by = Just b }
  392 mkGroupUsingStmt   a ss u   = (emptyTransStmt a) { trS_form = GroupForm, trS_stmts = ss, trS_using = u }
  393 mkGroupByUsingStmt a ss b u = (emptyTransStmt a) { trS_form = GroupForm, trS_stmts = ss, trS_using = u, trS_by = Just b }
  394 
  395 mkLastStmt body = LastStmt noExtField body Nothing noSyntaxExpr
  396 mkBodyStmt body
  397   = BodyStmt noExtField body noSyntaxExpr noSyntaxExpr
  398 mkPsBindStmt ann pat body = BindStmt ann pat body
  399 mkRnBindStmt pat body = BindStmt (XBindStmtRn { xbsrn_bindOp = noSyntaxExpr, xbsrn_failOp = Nothing }) pat body
  400 mkTcBindStmt pat body = BindStmt (XBindStmtTc { xbstc_bindOp = noSyntaxExpr,
  401                                                 xbstc_boundResultType = unitTy,
  402                                                    -- unitTy is a dummy value
  403                                                    -- can't panic here: it's forced during zonking
  404                                                 xbstc_boundResultMult = Many,
  405                                                 xbstc_failOp = Nothing }) pat body
  406 
  407 emptyRecStmt' :: forall idL idR body .
  408   (WrapXRec (GhcPass idR) [LStmtLR (GhcPass idL) (GhcPass idR) body], IsPass idR)
  409               => XRecStmt (GhcPass idL) (GhcPass idR) body
  410               -> StmtLR (GhcPass idL) (GhcPass idR) body
  411 emptyRecStmt' tyVal =
  412    RecStmt
  413      { recS_stmts = wrapXRec @(GhcPass idR) []
  414      , recS_later_ids = []
  415      , recS_rec_ids = []
  416      , recS_ret_fn = noSyntaxExpr
  417      , recS_mfix_fn = noSyntaxExpr
  418      , recS_bind_fn = noSyntaxExpr
  419      , recS_ext = tyVal }
  420 
  421 unitRecStmtTc :: RecStmtTc
  422 unitRecStmtTc = RecStmtTc { recS_bind_ty = unitTy
  423                           , recS_later_rets = []
  424                           , recS_rec_rets = []
  425                           , recS_ret_ty = unitTy }
  426 
  427 emptyRecStmt     = emptyRecStmt' noAnn
  428 emptyRecStmtName = emptyRecStmt' noExtField
  429 emptyRecStmtId   = emptyRecStmt' unitRecStmtTc
  430                                         -- a panic might trigger during zonking
  431 mkRecStmt anns stmts  = (emptyRecStmt' anns) { recS_stmts = stmts }
  432 
  433 mkLetStmt :: EpAnn [AddEpAnn] -> HsLocalBinds GhcPs -> StmtLR GhcPs GhcPs (LocatedA b)
  434 mkLetStmt anns binds = LetStmt anns binds
  435 
  436 -------------------------------
  437 -- | A useful function for building @OpApps@.  The operator is always a
  438 -- variable, and we don't know the fixity yet.
  439 mkHsOpApp :: LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
  440 mkHsOpApp e1 op e2 = OpApp noAnn e1 (noLocA (HsVar noExtField (noLocA op))) e2
  441 
  442 unqualSplice :: RdrName
  443 unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice"))
  444 
  445 mkUntypedSplice :: EpAnn [AddEpAnn] -> SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs
  446 mkUntypedSplice ann hasParen e = HsUntypedSplice ann hasParen unqualSplice e
  447 
  448 mkTypedSplice :: EpAnn [AddEpAnn] -> SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs
  449 mkTypedSplice ann hasParen e = HsTypedSplice ann hasParen unqualSplice e
  450 
  451 mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsSplice GhcPs
  452 mkHsQuasiQuote quoter span quote
  453   = HsQuasiQuote noExtField unqualSplice quoter span quote
  454 
  455 mkHsString :: String -> HsLit (GhcPass p)
  456 mkHsString s = HsString NoSourceText (mkFastString s)
  457 
  458 mkHsStringPrimLit :: FastString -> HsLit (GhcPass p)
  459 mkHsStringPrimLit fs = HsStringPrim NoSourceText (bytesFS fs)
  460 
  461 mkHsCharPrimLit :: Char -> HsLit (GhcPass p)
  462 mkHsCharPrimLit c = HsChar NoSourceText c
  463 
  464 mkConLikeTc :: ConLike -> HsExpr GhcTc
  465 mkConLikeTc con = XExpr (ConLikeTc con [] [])
  466 
  467 {-
  468 ************************************************************************
  469 *                                                                      *
  470         Constructing syntax with no location info
  471 *                                                                      *
  472 ************************************************************************
  473 -}
  474 
  475 nlHsVar :: IsSrcSpanAnn p a
  476         => IdP (GhcPass p) -> LHsExpr (GhcPass p)
  477 nlHsVar n = noLocA (HsVar noExtField (noLocA n))
  478 
  479 nl_HsVar :: IsSrcSpanAnn p a
  480         => IdP (GhcPass p) -> HsExpr (GhcPass p)
  481 nl_HsVar n = HsVar noExtField (noLocA n)
  482 
  483 -- | NB: Only for 'LHsExpr' 'Id'.
  484 nlHsDataCon :: DataCon -> LHsExpr GhcTc
  485 nlHsDataCon con = noLocA (mkConLikeTc (RealDataCon con))
  486 
  487 nlHsLit :: HsLit (GhcPass p) -> LHsExpr (GhcPass p)
  488 nlHsLit n = noLocA (HsLit noComments n)
  489 
  490 nlHsIntLit :: Integer -> LHsExpr (GhcPass p)
  491 nlHsIntLit n = noLocA (HsLit noComments (HsInt noExtField (mkIntegralLit n)))
  492 
  493 nlVarPat :: IsSrcSpanAnn p a
  494         => IdP (GhcPass p) -> LPat (GhcPass p)
  495 nlVarPat n = noLocA (VarPat noExtField (noLocA n))
  496 
  497 nlLitPat :: HsLit GhcPs -> LPat GhcPs
  498 nlLitPat l = noLocA (LitPat noExtField l)
  499 
  500 nlHsApp :: IsPass id => LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
  501 nlHsApp f x = noLocA (HsApp noComments f (mkLHsPar x))
  502 
  503 nlHsSyntaxApps :: SyntaxExprTc -> [LHsExpr GhcTc]
  504                -> LHsExpr GhcTc
  505 nlHsSyntaxApps (SyntaxExprTc { syn_expr      = fun
  506                              , syn_arg_wraps = arg_wraps
  507                              , syn_res_wrap  = res_wrap }) args
  508   = mkLHsWrap res_wrap (foldl' nlHsApp (noLocA fun) (zipWithEqual "nlHsSyntaxApps"
  509                                                      mkLHsWrap arg_wraps args))
  510 nlHsSyntaxApps NoSyntaxExprTc args = pprPanic "nlHsSyntaxApps" (ppr args)
  511   -- this function should never be called in scenarios where there is no
  512   -- syntax expr
  513 
  514 nlHsApps :: IsSrcSpanAnn p a
  515          => IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
  516 nlHsApps f xs = foldl' nlHsApp (nlHsVar f) xs
  517 
  518 nlHsVarApps :: IsSrcSpanAnn p a
  519             => IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
  520 nlHsVarApps f xs = noLocA (foldl' mk (HsVar noExtField (noLocA f))
  521                                          (map ((HsVar noExtField) . noLocA) xs))
  522                  where
  523                    mk f a = HsApp noComments (noLocA f) (noLocA a)
  524 
  525 nlConVarPat :: RdrName -> [RdrName] -> LPat GhcPs
  526 nlConVarPat con vars = nlConPat con (map nlVarPat vars)
  527 
  528 nlConVarPatName :: Name -> [Name] -> LPat GhcRn
  529 nlConVarPatName con vars = nlConPatName con (map nlVarPat vars)
  530 
  531 nlInfixConPat :: RdrName -> LPat GhcPs -> LPat GhcPs -> LPat GhcPs
  532 nlInfixConPat con l r = noLocA $ ConPat
  533   { pat_con = noLocA con
  534   , pat_args = InfixCon (parenthesizePat opPrec l)
  535                         (parenthesizePat opPrec r)
  536   , pat_con_ext = noAnn
  537   }
  538 
  539 nlConPat :: RdrName -> [LPat GhcPs] -> LPat GhcPs
  540 nlConPat con pats = noLocA $ ConPat
  541   { pat_con_ext = noAnn
  542   , pat_con = noLocA con
  543   , pat_args = PrefixCon [] (map (parenthesizePat appPrec) pats)
  544   }
  545 
  546 nlConPatName :: Name -> [LPat GhcRn] -> LPat GhcRn
  547 nlConPatName con pats = noLocA $ ConPat
  548   { pat_con_ext = noExtField
  549   , pat_con = noLocA con
  550   , pat_args = PrefixCon [] (map (parenthesizePat appPrec) pats)
  551   }
  552 
  553 nlNullaryConPat :: RdrName -> LPat GhcPs
  554 nlNullaryConPat con = noLocA $ ConPat
  555   { pat_con_ext = noAnn
  556   , pat_con = noLocA con
  557   , pat_args = PrefixCon [] []
  558   }
  559 
  560 nlWildConPat :: DataCon -> LPat GhcPs
  561 nlWildConPat con = noLocA $ ConPat
  562   { pat_con_ext = noAnn
  563   , pat_con = noLocA $ getRdrName con
  564   , pat_args = PrefixCon [] $
  565      replicate (dataConSourceArity con)
  566                nlWildPat
  567   }
  568 
  569 -- | Wildcard pattern - after parsing
  570 nlWildPat :: LPat GhcPs
  571 nlWildPat  = noLocA (WildPat noExtField )
  572 
  573 -- | Wildcard pattern - after renaming
  574 nlWildPatName :: LPat GhcRn
  575 nlWildPatName  = noLocA (WildPat noExtField )
  576 
  577 nlHsDo :: HsDoFlavour -> [LStmt GhcPs (LHsExpr GhcPs)]
  578        -> LHsExpr GhcPs
  579 nlHsDo ctxt stmts = noLocA (mkHsDo ctxt (noLocA stmts))
  580 
  581 nlHsOpApp :: LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
  582 nlHsOpApp e1 op e2 = noLocA (mkHsOpApp e1 op e2)
  583 
  584 nlHsLam  :: LMatch GhcPs (LHsExpr GhcPs) -> LHsExpr GhcPs
  585 nlHsPar  :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
  586 nlHsCase :: LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)]
  587          -> LHsExpr GhcPs
  588 nlList   :: [LHsExpr GhcPs] -> LHsExpr GhcPs
  589 
  590 -- AZ:Is this used?
  591 nlHsLam match = noLocA (HsLam noExtField (mkMatchGroup Generated (noLocA [match])))
  592 nlHsPar e     = noLocA (gHsPar e)
  593 
  594 -- nlHsIf should generate if-expressions which are NOT subject to
  595 -- RebindableSyntax, so the first field of HsIf is False. (#12080)
  596 nlHsIf :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
  597 nlHsIf cond true false = noLocA (HsIf noAnn cond true false)
  598 
  599 nlHsCase expr matches
  600   = noLocA (HsCase noAnn expr (mkMatchGroup Generated (noLocA matches)))
  601 nlList exprs          = noLocA (ExplicitList noAnn exprs)
  602 
  603 nlHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
  604 nlHsTyVar :: IsSrcSpanAnn p a
  605           => IdP (GhcPass p)                            -> LHsType (GhcPass p)
  606 nlHsFunTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
  607 nlHsParTy :: LHsType (GhcPass p)                        -> LHsType (GhcPass p)
  608 
  609 nlHsAppTy f t = noLocA (HsAppTy noExtField f (parenthesizeHsType appPrec t))
  610 nlHsTyVar x   = noLocA (HsTyVar noAnn NotPromoted (noLocA x))
  611 nlHsFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) (parenthesizeHsType funPrec a) b)
  612 nlHsParTy t   = noLocA (HsParTy noAnn t)
  613 
  614 nlHsTyConApp :: IsSrcSpanAnn p a
  615              => LexicalFixity -> IdP (GhcPass p)
  616              -> [LHsTypeArg (GhcPass p)] -> LHsType (GhcPass p)
  617 nlHsTyConApp fixity tycon tys
  618   | Infix <- fixity
  619   , HsValArg ty1 : HsValArg ty2 : rest <- tys
  620   = foldl' mk_app (noLocA $ HsOpTy noExtField ty1 (noLocA tycon) ty2) rest
  621   | otherwise
  622   = foldl' mk_app (nlHsTyVar tycon) tys
  623   where
  624     mk_app :: LHsType (GhcPass p) -> LHsTypeArg (GhcPass p) -> LHsType (GhcPass p)
  625     mk_app fun@(L _ (HsOpTy {})) arg = mk_app (noLocA $ HsParTy noAnn fun) arg
  626       -- parenthesize things like `(A + B) C`
  627     mk_app fun (HsValArg ty) = noLocA (HsAppTy noExtField fun (parenthesizeHsType appPrec ty))
  628     mk_app fun (HsTypeArg _ ki) = noLocA (HsAppKindTy noSrcSpan fun (parenthesizeHsType appPrec ki))
  629     mk_app fun (HsArgPar _) = noLocA (HsParTy noAnn fun)
  630 
  631 nlHsAppKindTy ::
  632   LHsType (GhcPass p) -> LHsKind (GhcPass p) -> LHsType (GhcPass p)
  633 nlHsAppKindTy f k
  634   = noLocA (HsAppKindTy noSrcSpan f (parenthesizeHsType appPrec k))
  635 
  636 {-
  637 Tuples.  All these functions are *pre-typechecker* because they lack
  638 types on the tuple.
  639 -}
  640 
  641 mkLHsTupleExpr :: [LHsExpr (GhcPass p)] -> XExplicitTuple (GhcPass p)
  642                -> LHsExpr (GhcPass p)
  643 -- Makes a pre-typechecker boxed tuple, deals with 1 case
  644 mkLHsTupleExpr [e] _ = e
  645 mkLHsTupleExpr es ext
  646   = noLocA $ ExplicitTuple ext (map (Present noAnn) es) Boxed
  647 
  648 mkLHsVarTuple :: IsSrcSpanAnn p a
  649                => [IdP (GhcPass p)]  -> XExplicitTuple (GhcPass p)
  650               -> LHsExpr (GhcPass p)
  651 mkLHsVarTuple ids ext = mkLHsTupleExpr (map nlHsVar ids) ext
  652 
  653 nlTuplePat :: [LPat GhcPs] -> Boxity -> LPat GhcPs
  654 nlTuplePat pats box = noLocA (TuplePat noAnn pats box)
  655 
  656 missingTupArg :: EpAnn EpaLocation -> HsTupArg GhcPs
  657 missingTupArg ann = Missing ann
  658 
  659 mkLHsPatTup :: [LPat GhcRn] -> LPat GhcRn
  660 mkLHsPatTup []     = noLocA $ TuplePat noExtField [] Boxed
  661 mkLHsPatTup [lpat] = lpat
  662 mkLHsPatTup lpats  = L (getLoc (head lpats)) $ TuplePat noExtField lpats Boxed
  663 
  664 -- | The Big equivalents for the source tuple expressions
  665 mkBigLHsVarTup :: IsSrcSpanAnn p a
  666                => [IdP (GhcPass p)] -> XExplicitTuple (GhcPass p)
  667                -> LHsExpr (GhcPass p)
  668 mkBigLHsVarTup ids anns = mkBigLHsTup (map nlHsVar ids) anns
  669 
  670 mkBigLHsTup :: [LHsExpr (GhcPass id)] -> XExplicitTuple (GhcPass id)
  671             -> LHsExpr (GhcPass id)
  672 mkBigLHsTup es anns = mkChunkified (\e -> mkLHsTupleExpr e anns) es
  673 
  674 -- | The Big equivalents for the source tuple patterns
  675 mkBigLHsVarPatTup :: [IdP GhcRn] -> LPat GhcRn
  676 mkBigLHsVarPatTup bs = mkBigLHsPatTup (map nlVarPat bs)
  677 
  678 mkBigLHsPatTup :: [LPat GhcRn] -> LPat GhcRn
  679 mkBigLHsPatTup = mkChunkified mkLHsPatTup
  680 
  681 -- $big_tuples
  682 -- #big_tuples#
  683 --
  684 -- GHCs built in tuples can only go up to 'mAX_TUPLE_SIZE' in arity, but
  685 -- we might conceivably want to build such a massive tuple as part of the
  686 -- output of a desugaring stage (notably that for list comprehensions).
  687 --
  688 -- We call tuples above this size \"big tuples\", and emulate them by
  689 -- creating and pattern matching on >nested< tuples that are expressible
  690 -- by GHC.
  691 --
  692 -- Nesting policy: it's better to have a 2-tuple of 10-tuples (3 objects)
  693 -- than a 10-tuple of 2-tuples (11 objects), so we want the leaves of any
  694 -- construction to be big.
  695 --
  696 -- If you just use the 'mkBigCoreTup', 'mkBigCoreVarTupTy', 'mkTupleSelector'
  697 -- and 'mkTupleCase' functions to do all your work with tuples you should be
  698 -- fine, and not have to worry about the arity limitation at all.
  699 
  700 -- | Lifts a \"small\" constructor into a \"big\" constructor by recursive decomposition
  701 mkChunkified :: ([a] -> a)      -- ^ \"Small\" constructor function, of maximum input arity 'mAX_TUPLE_SIZE'
  702              -> [a]             -- ^ Possible \"big\" list of things to construct from
  703              -> a               -- ^ Constructed thing made possible by recursive decomposition
  704 mkChunkified small_tuple as = mk_big_tuple (chunkify as)
  705   where
  706         -- Each sub-list is short enough to fit in a tuple
  707     mk_big_tuple [as] = small_tuple as
  708     mk_big_tuple as_s = mk_big_tuple (chunkify (map small_tuple as_s))
  709 
  710 chunkify :: [a] -> [[a]]
  711 -- ^ Split a list into lists that are small enough to have a corresponding
  712 -- tuple arity. The sub-lists of the result all have length <= 'mAX_TUPLE_SIZE'
  713 -- But there may be more than 'mAX_TUPLE_SIZE' sub-lists
  714 chunkify xs
  715   | n_xs <= mAX_TUPLE_SIZE = [xs]
  716   | otherwise              = split xs
  717   where
  718     n_xs     = length xs
  719     split [] = []
  720     split xs = take mAX_TUPLE_SIZE xs : split (drop mAX_TUPLE_SIZE xs)
  721 
  722 {-
  723 ************************************************************************
  724 *                                                                      *
  725         LHsSigType and LHsSigWcType
  726 *                                                                      *
  727 ********************************************************************* -}
  728 
  729 -- | Convert an 'LHsType' to an 'LHsSigType'.
  730 hsTypeToHsSigType :: LHsType GhcPs -> LHsSigType GhcPs
  731 hsTypeToHsSigType lty@(L loc ty) = L loc $ case ty of
  732   HsForAllTy { hst_tele = HsForAllInvis { hsf_xinvis = an
  733                                         , hsf_invis_bndrs = bndrs }
  734              , hst_body = body }
  735     -> mkHsExplicitSigType an bndrs body
  736   _ -> mkHsImplicitSigType lty
  737 
  738 -- | Convert an 'LHsType' to an 'LHsSigWcType'.
  739 hsTypeToHsSigWcType :: LHsType GhcPs -> LHsSigWcType GhcPs
  740 hsTypeToHsSigWcType = mkHsWildCardBndrs . hsTypeToHsSigType
  741 
  742 mkHsSigEnv :: forall a. (LSig GhcRn -> Maybe ([LocatedN Name], a))
  743                      -> [LSig GhcRn]
  744                      -> NameEnv a
  745 mkHsSigEnv get_info sigs
  746   = mkNameEnv          (mk_pairs ordinary_sigs)
  747    `extendNameEnvList` (mk_pairs gen_dm_sigs)
  748    -- The subtlety is this: in a class decl with a
  749    -- default-method signature as well as a method signature
  750    -- we want the latter to win (#12533)
  751    --    class C x where
  752    --       op :: forall a . x a -> x a
  753    --       default op :: forall b . x b -> x b
  754    --       op x = ...(e :: b -> b)...
  755    -- The scoped type variables of the 'default op', namely 'b',
  756    -- scope over the code for op.   The 'forall a' does not!
  757    -- This applies both in the renamer and typechecker, both
  758    -- of which use this function
  759   where
  760     (gen_dm_sigs, ordinary_sigs) = partition is_gen_dm_sig sigs
  761     is_gen_dm_sig (L _ (ClassOpSig _ True _ _)) = True
  762     is_gen_dm_sig _                             = False
  763 
  764     mk_pairs :: [LSig GhcRn] -> [(Name, a)]
  765     mk_pairs sigs = [ (n,a) | Just (ns,a) <- map get_info sigs
  766                             , L _ n <- ns ]
  767 
  768 mkClassOpSigs :: [LSig GhcPs] -> [LSig GhcPs]
  769 -- ^ Convert 'TypeSig' to 'ClassOpSig'.
  770 -- The former is what is parsed, but the latter is
  771 -- what we need in class/instance declarations
  772 mkClassOpSigs sigs
  773   = map fiddle sigs
  774   where
  775     fiddle (L loc (TypeSig anns nms ty))
  776       = L loc (ClassOpSig anns False nms (dropWildCards ty))
  777     fiddle sig = sig
  778 
  779 {- *********************************************************************
  780 *                                                                      *
  781     --------- HsWrappers: type args, dict args, casts ---------
  782 *                                                                      *
  783 ********************************************************************* -}
  784 
  785 mkLHsWrap :: HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
  786 mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e)
  787 
  788 mkHsWrap :: HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
  789 mkHsWrap co_fn e | isIdHsWrapper co_fn = e
  790 mkHsWrap co_fn e                       = XExpr (WrapExpr $ HsWrap co_fn e)
  791 
  792 mkHsWrapCo :: TcCoercionN   -- A Nominal coercion  a ~N b
  793            -> HsExpr GhcTc -> HsExpr GhcTc
  794 mkHsWrapCo co e = mkHsWrap (mkWpCastN co) e
  795 
  796 mkHsWrapCoR :: TcCoercionR   -- A Representational coercion  a ~R b
  797             -> HsExpr GhcTc -> HsExpr GhcTc
  798 mkHsWrapCoR co e = mkHsWrap (mkWpCastR co) e
  799 
  800 mkLHsWrapCo :: TcCoercionN -> LHsExpr GhcTc -> LHsExpr GhcTc
  801 mkLHsWrapCo co (L loc e) = L loc (mkHsWrapCo co e)
  802 
  803 mkHsCmdWrap :: HsWrapper -> HsCmd GhcTc -> HsCmd GhcTc
  804 mkHsCmdWrap w cmd | isIdHsWrapper w = cmd
  805                   | otherwise       = XCmd (HsWrap w cmd)
  806 
  807 mkLHsCmdWrap :: HsWrapper -> LHsCmd GhcTc -> LHsCmd GhcTc
  808 mkLHsCmdWrap w (L loc c) = L loc (mkHsCmdWrap w c)
  809 
  810 mkHsWrapPat :: HsWrapper -> Pat GhcTc -> Type -> Pat GhcTc
  811 mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p
  812                        | otherwise           = XPat $ CoPat co_fn p ty
  813 
  814 mkHsWrapPatCo :: TcCoercionN -> Pat GhcTc -> Type -> Pat GhcTc
  815 mkHsWrapPatCo co pat ty | isTcReflCo co = pat
  816                         | otherwise     = XPat $ CoPat (mkWpCastN co) pat ty
  817 
  818 mkHsDictLet :: TcEvBinds -> LHsExpr GhcTc -> LHsExpr GhcTc
  819 mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr
  820 
  821 {-
  822 l
  823 ************************************************************************
  824 *                                                                      *
  825                 Bindings; with a location at the top
  826 *                                                                      *
  827 ************************************************************************
  828 -}
  829 
  830 mkFunBind :: Origin -> LocatedN RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
  831           -> HsBind GhcPs
  832 -- ^ Not infix, with place holders for coercion and free vars
  833 mkFunBind origin fn ms
  834   = FunBind { fun_id = fn
  835             , fun_matches = mkMatchGroup origin (noLocA ms)
  836             , fun_ext = noExtField
  837             , fun_tick = [] }
  838 
  839 mkTopFunBind :: Origin -> LocatedN Name -> [LMatch GhcRn (LHsExpr GhcRn)]
  840              -> HsBind GhcRn
  841 -- ^ In Name-land, with empty bind_fvs
  842 mkTopFunBind origin fn ms = FunBind { fun_id = fn
  843                                     , fun_matches = mkMatchGroup origin (noLocA ms)
  844                                     , fun_ext  = emptyNameSet -- NB: closed
  845                                                               --     binding
  846                                     , fun_tick = [] }
  847 
  848 mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs
  849 mkHsVarBind loc var rhs = mkSimpleGeneratedFunBind loc var [] rhs
  850 
  851 mkVarBind :: IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p)
  852 mkVarBind var rhs = L (getLoc rhs) $
  853                     VarBind { var_ext = noExtField,
  854                               var_id = var, var_rhs = rhs }
  855 
  856 mkPatSynBind :: LocatedN RdrName -> HsPatSynDetails GhcPs
  857              -> LPat GhcPs -> HsPatSynDir GhcPs -> EpAnn [AddEpAnn] -> HsBind GhcPs
  858 mkPatSynBind name details lpat dir anns = PatSynBind noExtField psb
  859   where
  860     psb = PSB{ psb_ext = anns
  861              , psb_id = name
  862              , psb_args = details
  863              , psb_def = lpat
  864              , psb_dir = dir }
  865 
  866 -- |If any of the matches in the 'FunBind' are infix, the 'FunBind' is
  867 -- considered infix.
  868 isInfixFunBind :: forall id1 id2. UnXRec id2 => HsBindLR id1 id2 -> Bool
  869 isInfixFunBind (FunBind { fun_matches = MG _ matches _ })
  870   = any (isInfixMatch . unXRec @id2) (unXRec @id2 matches)
  871 isInfixFunBind _ = False
  872 
  873 -- |Return the 'SrcSpan' encompassing the contents of any enclosed binds
  874 spanHsLocaLBinds :: HsLocalBinds (GhcPass p) -> SrcSpan
  875 spanHsLocaLBinds (EmptyLocalBinds _) = noSrcSpan
  876 spanHsLocaLBinds (HsValBinds _ (ValBinds _ bs sigs))
  877   = foldr combineSrcSpans noSrcSpan (bsSpans ++ sigsSpans)
  878   where
  879     bsSpans :: [SrcSpan]
  880     bsSpans = map getLocA $ bagToList bs
  881     sigsSpans :: [SrcSpan]
  882     sigsSpans = map getLocA sigs
  883 spanHsLocaLBinds (HsValBinds _ (XValBindsLR (NValBinds bs sigs)))
  884   = foldr combineSrcSpans noSrcSpan (bsSpans ++ sigsSpans)
  885   where
  886     bsSpans :: [SrcSpan]
  887     bsSpans = map getLocA $ concatMap (bagToList . snd) bs
  888     sigsSpans :: [SrcSpan]
  889     sigsSpans = map getLocA sigs
  890 spanHsLocaLBinds (HsIPBinds _ (IPBinds _ bs))
  891   = foldr combineSrcSpans noSrcSpan (map getLocA bs)
  892 
  893 ------------
  894 -- | Convenience function using 'mkFunBind'.
  895 -- This is for generated bindings only, do not use for user-written code.
  896 mkSimpleGeneratedFunBind :: SrcSpan -> RdrName -> [LPat GhcPs]
  897                 -> LHsExpr GhcPs -> LHsBind GhcPs
  898 mkSimpleGeneratedFunBind loc fun pats expr
  899   = L (noAnnSrcSpan loc) $ mkFunBind Generated (L (noAnnSrcSpan loc) fun)
  900               [mkMatch (mkPrefixFunRhs (L (noAnnSrcSpan loc) fun)) pats expr
  901                        emptyLocalBinds]
  902 
  903 -- | Make a prefix, non-strict function 'HsMatchContext'
  904 mkPrefixFunRhs :: LIdP p -> HsMatchContext p
  905 mkPrefixFunRhs n = FunRhs { mc_fun = n
  906                           , mc_fixity = Prefix
  907                           , mc_strictness = NoSrcStrict }
  908 
  909 ------------
  910 mkMatch :: forall p. IsPass p
  911         => HsMatchContext (GhcPass p)
  912         -> [LPat (GhcPass p)]
  913         -> LHsExpr (GhcPass p)
  914         -> HsLocalBinds (GhcPass p)
  915         -> LMatch (GhcPass p) (LHsExpr (GhcPass p))
  916 mkMatch ctxt pats expr binds
  917   = noLocA (Match { m_ext   = noAnn
  918                   , m_ctxt  = ctxt
  919                   , m_pats  = map mkParPat pats
  920                   , m_grhss = GRHSs emptyComments (unguardedRHS noAnn noSrcSpan expr) binds })
  921 
  922 {-
  923 ************************************************************************
  924 *                                                                      *
  925         Collecting binders
  926 *                                                                      *
  927 ************************************************************************
  928 
  929 Get all the binders in some HsBindGroups, IN THE ORDER OF APPEARANCE. eg.
  930 
  931 ...
  932 where
  933   (x, y) = ...
  934   f i j  = ...
  935   [a, b] = ...
  936 
  937 it should return [x, y, f, a, b] (remember, order important).
  938 
  939 Note [Collect binders only after renaming]
  940 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  941 These functions should only be used on HsSyn *after* the renamer,
  942 to return a [Name] or [Id].  Before renaming the record punning
  943 and wild-card mechanism makes it hard to know what is bound.
  944 So these functions should not be applied to (HsSyn RdrName)
  945 
  946 Note [Unlifted id check in isUnliftedHsBind]
  947 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  948 The function isUnliftedHsBind is used to complain if we make a top-level
  949 binding for a variable of unlifted type.
  950 
  951 Such a binding is illegal if the top-level binding would be unlifted;
  952 but also if the local letrec generated by desugaring AbsBinds would be.
  953 E.g.
  954       f :: Num a => (# a, a #)
  955       g :: Num a => a -> a
  956       f = ...g...
  957       g = ...g...
  958 
  959 The top-level bindings for f,g are not unlifted (because of the Num a =>),
  960 but the local, recursive, monomorphic bindings are:
  961 
  962       t = /\a \(d:Num a).
  963          letrec fm :: (# a, a #) = ...g...
  964                 gm :: a -> a = ...f...
  965          in (fm, gm)
  966 
  967 Here the binding for 'fm' is illegal.  So generally we check the abe_mono types.
  968 
  969 BUT we have a special case when abs_sig is true;
  970   see Note [The abs_sig field of AbsBinds] in GHC.Hs.Binds
  971 -}
  972 
  973 ----------------- Bindings --------------------------
  974 
  975 -- | Should we treat this as an unlifted bind? This will be true for any
  976 -- bind that binds an unlifted variable, but we must be careful around
  977 -- AbsBinds. See Note [Unlifted id check in isUnliftedHsBind]. For usage
  978 -- information, see Note [Strict binds checks] is GHC.HsToCore.Binds.
  979 isUnliftedHsBind :: HsBind GhcTc -> Bool  -- works only over typechecked binds
  980 isUnliftedHsBind bind
  981   | AbsBinds { abs_exports = exports, abs_sig = has_sig } <- bind
  982   = if has_sig
  983     then any (is_unlifted_id . abe_poly) exports
  984     else any (is_unlifted_id . abe_mono) exports
  985     -- If has_sig is True we will never generate a binding for abe_mono,
  986     -- so we don't need to worry about it being unlifted. The abe_poly
  987     -- binding might not be: e.g. forall a. Num a => (# a, a #)
  988 
  989   | otherwise
  990   = any is_unlifted_id (collectHsBindBinders CollNoDictBinders bind)
  991   where
  992     is_unlifted_id id = isUnliftedType (idType id)
  993 
  994 -- | Is a binding a strict variable or pattern bind (e.g. @!x = ...@)?
  995 isBangedHsBind :: HsBind GhcTc -> Bool
  996 isBangedHsBind (AbsBinds { abs_binds = binds })
  997   = anyBag (isBangedHsBind . unLoc) binds
  998 isBangedHsBind (FunBind {fun_matches = matches})
  999   | [L _ match] <- unLoc $ mg_alts matches
 1000   , FunRhs{mc_strictness = SrcStrict} <- m_ctxt match
 1001   = True
 1002 isBangedHsBind (PatBind {pat_lhs = pat})
 1003   = isBangedLPat pat
 1004 isBangedHsBind _
 1005   = False
 1006 
 1007 collectLocalBinders :: CollectPass (GhcPass idL)
 1008                     => CollectFlag (GhcPass idL)
 1009                     -> HsLocalBindsLR (GhcPass idL) (GhcPass idR)
 1010                     -> [IdP (GhcPass idL)]
 1011 collectLocalBinders flag = \case
 1012     HsValBinds _ binds -> collectHsIdBinders flag binds
 1013                           -- No pattern synonyms here
 1014     HsIPBinds {}       -> []
 1015     EmptyLocalBinds _  -> []
 1016 
 1017 collectHsIdBinders :: CollectPass (GhcPass idL)
 1018                    => CollectFlag (GhcPass idL)
 1019                    -> HsValBindsLR (GhcPass idL) (GhcPass idR)
 1020                    -> [IdP (GhcPass idL)]
 1021 -- ^ Collect 'Id' binders only, or 'Id's + pattern synonyms, respectively
 1022 collectHsIdBinders flag = collect_hs_val_binders True flag
 1023 
 1024 collectHsValBinders :: CollectPass (GhcPass idL)
 1025                     => CollectFlag (GhcPass idL)
 1026                     -> HsValBindsLR (GhcPass idL) (GhcPass idR)
 1027                     -> [IdP (GhcPass idL)]
 1028 collectHsValBinders flag = collect_hs_val_binders False flag
 1029 
 1030 collectHsBindBinders :: CollectPass p
 1031                      => CollectFlag p
 1032                      -> HsBindLR p idR
 1033                      -> [IdP p]
 1034 -- ^ Collect both 'Id's and pattern-synonym binders
 1035 collectHsBindBinders flag b = collect_bind False flag b []
 1036 
 1037 collectHsBindsBinders :: CollectPass p
 1038                       => CollectFlag p
 1039                       -> LHsBindsLR p idR
 1040                       -> [IdP p]
 1041 collectHsBindsBinders flag binds = collect_binds False flag binds []
 1042 
 1043 collectHsBindListBinders :: forall p idR. CollectPass p
 1044                          => CollectFlag p
 1045                          -> [LHsBindLR p idR]
 1046                          -> [IdP p]
 1047 -- ^ Same as 'collectHsBindsBinders', but works over a list of bindings
 1048 collectHsBindListBinders flag = foldr (collect_bind False flag . unXRec @p) []
 1049 
 1050 collect_hs_val_binders :: CollectPass (GhcPass idL)
 1051                        => Bool
 1052                        -> CollectFlag (GhcPass idL)
 1053                        -> HsValBindsLR (GhcPass idL) (GhcPass idR)
 1054                        -> [IdP (GhcPass idL)]
 1055 collect_hs_val_binders ps flag = \case
 1056     ValBinds _ binds _              -> collect_binds ps flag binds []
 1057     XValBindsLR (NValBinds binds _) -> collect_out_binds ps flag binds
 1058 
 1059 collect_out_binds :: forall p. CollectPass p
 1060                   => Bool
 1061                   -> CollectFlag p
 1062                   -> [(RecFlag, LHsBinds p)]
 1063                   -> [IdP p]
 1064 collect_out_binds ps flag = foldr (collect_binds ps flag . snd) []
 1065 
 1066 collect_binds :: forall p idR. CollectPass p
 1067               => Bool
 1068               -> CollectFlag p
 1069               -> LHsBindsLR p idR
 1070               -> [IdP p]
 1071               -> [IdP p]
 1072 -- ^ Collect 'Id's, or 'Id's + pattern synonyms, depending on boolean flag
 1073 collect_binds ps flag binds acc = foldr (collect_bind ps flag . unXRec @p) acc binds
 1074 
 1075 collect_bind :: forall p idR. CollectPass p
 1076              => Bool
 1077              -> CollectFlag p
 1078              -> HsBindLR p idR
 1079              -> [IdP p]
 1080              -> [IdP p]
 1081 collect_bind _ flag (PatBind { pat_lhs = p })           acc = collect_lpat flag p acc
 1082 collect_bind _ _ (FunBind { fun_id = f })            acc = unXRec @p f : acc
 1083 collect_bind _ _ (VarBind { var_id = f })            acc = f : acc
 1084 collect_bind _ _ (AbsBinds { abs_exports = dbinds }) acc = map abe_poly dbinds ++ acc
 1085         -- I don't think we want the binders from the abe_binds
 1086 
 1087         -- binding (hence see AbsBinds) is in zonking in GHC.Tc.Utils.Zonk
 1088 collect_bind omitPatSyn _ (PatSynBind _ (PSB { psb_id = ps })) acc
 1089   | omitPatSyn                  = acc
 1090   | otherwise                   = unXRec @p ps : acc
 1091 collect_bind _ _ (PatSynBind _ (XPatSynBind _)) acc = acc
 1092 collect_bind _ _ (XHsBindsLR _) acc = acc
 1093 
 1094 collectMethodBinders :: forall idL idR. UnXRec idL => LHsBindsLR idL idR -> [LIdP idL]
 1095 -- ^ Used exclusively for the bindings of an instance decl which are all
 1096 -- 'FunBinds'
 1097 collectMethodBinders binds = foldr (get . unXRec @idL) [] binds
 1098   where
 1099     get (FunBind { fun_id = f }) fs = f : fs
 1100     get _                        fs = fs
 1101        -- Someone else complains about non-FunBinds
 1102 
 1103 ----------------- Statements --------------------------
 1104 --
 1105 collectLStmtsBinders
 1106   :: CollectPass (GhcPass idL)
 1107   => CollectFlag (GhcPass idL)
 1108   -> [LStmtLR (GhcPass idL) (GhcPass idR) body]
 1109   -> [IdP (GhcPass idL)]
 1110 collectLStmtsBinders flag = concatMap (collectLStmtBinders flag)
 1111 
 1112 collectStmtsBinders
 1113   :: (CollectPass (GhcPass idL))
 1114   => CollectFlag (GhcPass idL)
 1115   -> [StmtLR (GhcPass idL) (GhcPass idR) body]
 1116   -> [IdP (GhcPass idL)]
 1117 collectStmtsBinders flag = concatMap (collectStmtBinders flag)
 1118 
 1119 collectLStmtBinders
 1120   :: (CollectPass (GhcPass idL))
 1121   => CollectFlag (GhcPass idL)
 1122   -> LStmtLR (GhcPass idL) (GhcPass idR) body
 1123   -> [IdP (GhcPass idL)]
 1124 collectLStmtBinders flag = collectStmtBinders flag . unLoc
 1125 
 1126 collectStmtBinders
 1127   :: CollectPass (GhcPass idL)
 1128   => CollectFlag (GhcPass idL)
 1129   -> StmtLR (GhcPass idL) (GhcPass idR) body
 1130   -> [IdP (GhcPass idL)]
 1131   -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
 1132 collectStmtBinders flag = \case
 1133     BindStmt _ pat _ -> collectPatBinders flag pat
 1134     LetStmt _  binds -> collectLocalBinders flag binds
 1135     BodyStmt {}      -> []
 1136     LastStmt {}      -> []
 1137     ParStmt _ xs _ _ -> collectLStmtsBinders flag [s | ParStmtBlock _ ss _ _ <- xs, s <- ss]
 1138     TransStmt { trS_stmts = stmts } -> collectLStmtsBinders flag stmts
 1139     RecStmt { recS_stmts = L _ ss } -> collectLStmtsBinders flag ss
 1140     ApplicativeStmt _ args _        -> concatMap collectArgBinders args
 1141         where
 1142          collectArgBinders = \case
 1143             (_, ApplicativeArgOne { app_arg_pattern = pat }) -> collectPatBinders flag pat
 1144             (_, ApplicativeArgMany { bv_pattern = pat })     -> collectPatBinders flag pat
 1145 
 1146 
 1147 ----------------- Patterns --------------------------
 1148 
 1149 collectPatBinders
 1150     :: CollectPass p
 1151     => CollectFlag p
 1152     -> LPat p
 1153     -> [IdP p]
 1154 collectPatBinders flag pat = collect_lpat flag pat []
 1155 
 1156 collectPatsBinders
 1157     :: CollectPass p
 1158     => CollectFlag p
 1159     -> [LPat p]
 1160     -> [IdP p]
 1161 collectPatsBinders flag pats = foldr (collect_lpat flag) [] pats
 1162 
 1163 
 1164 -------------
 1165 
 1166 -- | Indicate if evidence binders have to be collected.
 1167 --
 1168 -- This type is used as a boolean (should we collect evidence binders or not?)
 1169 -- but also to pass an evidence that the AST has been typechecked when we do
 1170 -- want to collect evidence binders, otherwise these binders are not available.
 1171 --
 1172 -- See Note [Dictionary binders in ConPatOut]
 1173 data CollectFlag p where
 1174     -- | Don't collect evidence binders
 1175     CollNoDictBinders   :: CollectFlag p
 1176     -- | Collect evidence binders
 1177     CollWithDictBinders :: CollectFlag GhcTc
 1178 
 1179 collect_lpat :: forall p. (CollectPass p)
 1180              => CollectFlag p
 1181              -> LPat p
 1182              -> [IdP p]
 1183              -> [IdP p]
 1184 collect_lpat flag pat bndrs = collect_pat flag (unXRec @p pat) bndrs
 1185 
 1186 collect_pat :: forall p. CollectPass p
 1187             => CollectFlag p
 1188             -> Pat p
 1189             -> [IdP p]
 1190             -> [IdP p]
 1191 collect_pat flag pat bndrs = case pat of
 1192   VarPat _ var          -> unXRec @p var : bndrs
 1193   WildPat _             -> bndrs
 1194   LazyPat _ pat         -> collect_lpat flag pat bndrs
 1195   BangPat _ pat         -> collect_lpat flag pat bndrs
 1196   AsPat _ a pat         -> unXRec @p a : collect_lpat flag pat bndrs
 1197   ViewPat _ _ pat       -> collect_lpat flag pat bndrs
 1198   ParPat _ _ pat _      -> collect_lpat flag pat bndrs
 1199   ListPat _ pats        -> foldr (collect_lpat flag) bndrs pats
 1200   TuplePat _ pats _     -> foldr (collect_lpat flag) bndrs pats
 1201   SumPat _ pat _ _      -> collect_lpat flag pat bndrs
 1202   LitPat _ _            -> bndrs
 1203   NPat {}               -> bndrs
 1204   NPlusKPat _ n _ _ _ _ -> unXRec @p n : bndrs
 1205   SigPat _ pat _        -> collect_lpat flag pat bndrs
 1206   XPat ext              -> collectXXPat (Proxy @p) flag ext bndrs
 1207   SplicePat _ (HsSpliced _ _ (HsSplicedPat pat))
 1208                         -> collect_pat flag pat bndrs
 1209   SplicePat _ _         -> bndrs
 1210   -- See Note [Dictionary binders in ConPatOut]
 1211   ConPat {pat_args=ps}  -> case flag of
 1212     CollNoDictBinders   -> foldr (collect_lpat flag) bndrs (hsConPatArgs ps)
 1213     CollWithDictBinders -> foldr (collect_lpat flag) bndrs (hsConPatArgs ps)
 1214                            ++ collectEvBinders (cpt_binds (pat_con_ext pat))
 1215 
 1216 collectEvBinders :: TcEvBinds -> [Id]
 1217 collectEvBinders (EvBinds bs)   = foldr add_ev_bndr [] bs
 1218 collectEvBinders (TcEvBinds {}) = panic "ToDo: collectEvBinders"
 1219 
 1220 add_ev_bndr :: EvBind -> [Id] -> [Id]
 1221 add_ev_bndr (EvBind { eb_lhs = b }) bs | isId b    = b:bs
 1222                                        | otherwise = bs
 1223   -- A worry: what about coercion variable binders??
 1224 
 1225 
 1226 -- | This class specifies how to collect variable identifiers from extension patterns in the given pass.
 1227 -- Consumers of the GHC API that define their own passes should feel free to implement instances in order
 1228 -- to make use of functions which depend on it.
 1229 --
 1230 -- In particular, Haddock already makes use of this, with an instance for its 'DocNameI' pass so that
 1231 -- it can reuse the code in GHC for collecting binders.
 1232 class UnXRec p => CollectPass p where
 1233   collectXXPat :: Proxy p -> CollectFlag p -> XXPat p -> [IdP p] -> [IdP p]
 1234 
 1235 instance IsPass p => CollectPass (GhcPass p) where
 1236   collectXXPat _ flag ext =
 1237     case ghcPass @p of
 1238       GhcPs -> noExtCon ext
 1239       GhcRn
 1240         | HsPatExpanded _ pat <- ext
 1241         -> collect_pat flag pat
 1242       GhcTc -> case ext of
 1243         CoPat _ pat _      -> collect_pat flag pat
 1244         ExpansionPat _ pat -> collect_pat flag pat
 1245 
 1246 {-
 1247 Note [Dictionary binders in ConPatOut]
 1248 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 1249 
 1250 Should we collect dictionary binders in ConPatOut? It depends! Use CollectFlag
 1251 to choose.
 1252 
 1253 1. Pre-typechecker there are no ConPatOuts. Use CollNoDictBinders flag.
 1254 
 1255 2. In the desugarer, most of the time we don't want to collect evidence binders,
 1256    so we also use CollNoDictBinders flag.
 1257 
 1258    Example of why it matters:
 1259 
 1260    In a lazy pattern, for example f ~(C x y) = ..., we want to generate bindings
 1261    for x,y but not for dictionaries bound by C.
 1262    (The type checker ensures they would not be used.)
 1263 
 1264    Here's the problem.  Consider
 1265 
 1266         data T a where
 1267            C :: Num a => a -> Int -> T a
 1268 
 1269         f ~(C (n+1) m) = (n,m)
 1270 
 1271    Here, the pattern (C (n+1)) binds a hidden dictionary (d::Num a),
 1272    and *also* uses that dictionary to match the (n+1) pattern.  Yet, the
 1273    variables bound by the lazy pattern are n,m, *not* the dictionary d.
 1274    So in mkSelectorBinds in GHC.HsToCore.Utils, we want just m,n as the
 1275    variables bound.
 1276 
 1277    So in this case, we do *not* gather (a) dictionary and (b) dictionary
 1278    bindings as binders of a ConPatOut pattern.
 1279 
 1280 
 1281 3. On the other hand, desugaring of arrows needs evidence bindings and uses
 1282    CollWithDictBinders flag.
 1283 
 1284    Consider
 1285 
 1286         h :: (ArrowChoice a, Arrow a) => Int -> a (Int,Int) Int
 1287         h x = proc (y,z) -> case compare x y of
 1288                         GT -> returnA -< z+x
 1289 
 1290    The type checker turns the case into
 1291 
 1292         case compare x y of
 1293           GT { $dNum_123 = $dNum_Int } -> returnA -< (+) $dNum_123 z x
 1294 
 1295    That is, it attaches the $dNum_123 binding to a ConPatOut in scope.
 1296 
 1297    During desugaring, evidence binders must be collected because their sets are
 1298    intersected with free variable sets of subsequent commands to create
 1299    (minimal) command environments.  Failing to do it properly leads to bugs
 1300    (e.g., #18950).
 1301 
 1302    Note: attaching evidence binders to existing ConPatOut may be suboptimal for
 1303    arrows.  In the example above we would prefer to generate:
 1304 
 1305         case compare x y of
 1306           GT -> returnA -< let $dNum_123 = $dNum_Int in (+) $dNum_123 z x
 1307 
 1308    So that the evidence isn't passed into the command environment. This issue
 1309    doesn't arise with desugaring of non-arrow code because the simplifier can
 1310    freely float and inline let-expressions created for evidence binders. But
 1311    with arrow desugaring, the simplifier would have to see through the command
 1312    environment tuple which is more complicated.
 1313 
 1314 -}
 1315 
 1316 hsGroupBinders :: HsGroup GhcRn -> [Name]
 1317 hsGroupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
 1318                           hs_fords = foreign_decls })
 1319   =  collectHsValBinders CollNoDictBinders val_decls
 1320   ++ hsTyClForeignBinders tycl_decls foreign_decls
 1321 
 1322 hsTyClForeignBinders :: [TyClGroup GhcRn]
 1323                      -> [LForeignDecl GhcRn]
 1324                      -> [Name]
 1325 -- We need to look at instance declarations too,
 1326 -- because their associated types may bind data constructors
 1327 hsTyClForeignBinders tycl_decls foreign_decls
 1328   =    map unLoc (hsForeignDeclsBinders foreign_decls)
 1329     ++ getSelectorNames
 1330          (foldMap (foldMap hsLTyClDeclBinders . group_tyclds) tycl_decls
 1331          `mappend`
 1332          foldMap (foldMap hsLInstDeclBinders . group_instds) tycl_decls)
 1333   where
 1334     getSelectorNames :: ([LocatedA Name], [LFieldOcc GhcRn]) -> [Name]
 1335     getSelectorNames (ns, fs) = map unLoc ns ++ map (foExt . unLoc) fs
 1336 
 1337 -------------------
 1338 hsLTyClDeclBinders :: IsPass p
 1339                    => LocatedA (TyClDecl (GhcPass p))
 1340                    -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])
 1341 -- ^ Returns all the /binding/ names of the decl.  The first one is
 1342 -- guaranteed to be the name of the decl. The first component
 1343 -- represents all binding names except record fields; the second
 1344 -- represents field occurrences. For record fields mentioned in
 1345 -- multiple constructors, the SrcLoc will be from the first occurrence.
 1346 --
 1347 -- Each returned (Located name) has a SrcSpan for the /whole/ declaration.
 1348 -- See Note [SrcSpan for binders]
 1349 
 1350 hsLTyClDeclBinders (L loc (FamDecl { tcdFam = FamilyDecl
 1351                                             { fdLName = (L _ name) } }))
 1352   = ([L loc name], [])
 1353 hsLTyClDeclBinders (L loc (SynDecl
 1354                                { tcdLName = (L _ name) }))
 1355   = ([L loc name], [])
 1356 hsLTyClDeclBinders (L loc (ClassDecl
 1357                                { tcdLName = (L _ cls_name)
 1358                                , tcdSigs  = sigs
 1359                                , tcdATs   = ats }))
 1360   = (L loc cls_name :
 1361      [ L fam_loc fam_name | (L fam_loc (FamilyDecl
 1362                                         { fdLName = L _ fam_name })) <- ats ]
 1363      ++
 1364      [ L mem_loc mem_name
 1365                           | (L mem_loc (ClassOpSig _ False ns _)) <- sigs
 1366                           , (L _ mem_name) <- ns ]
 1367     , [])
 1368 hsLTyClDeclBinders (L loc (DataDecl    { tcdLName = (L _ name)
 1369                                        , tcdDataDefn = defn }))
 1370   = (\ (xs, ys) -> (L loc name : xs, ys)) $ hsDataDefnBinders defn
 1371 
 1372 
 1373 -------------------
 1374 hsForeignDeclsBinders :: forall p a. (UnXRec (GhcPass p), IsSrcSpanAnn p a)
 1375                       => [LForeignDecl (GhcPass p)] -> [LIdP (GhcPass p)]
 1376 -- ^ See Note [SrcSpan for binders]
 1377 hsForeignDeclsBinders foreign_decls
 1378   = [ L (noAnnSrcSpan (locA decl_loc)) n
 1379     | L decl_loc (ForeignImport { fd_name = L _ n })
 1380         <- foreign_decls]
 1381 
 1382 
 1383 -------------------
 1384 hsPatSynSelectors :: IsPass p => HsValBinds (GhcPass p) -> [FieldOcc (GhcPass p)]
 1385 -- ^ Collects record pattern-synonym selectors only; the pattern synonym
 1386 -- names are collected by 'collectHsValBinders'.
 1387 hsPatSynSelectors (ValBinds _ _ _) = panic "hsPatSynSelectors"
 1388 hsPatSynSelectors (XValBindsLR (NValBinds binds _))
 1389   = foldr addPatSynSelector [] . unionManyBags $ map snd binds
 1390 
 1391 addPatSynSelector :: forall p. UnXRec p => LHsBind p -> [FieldOcc p] -> [FieldOcc p]
 1392 addPatSynSelector bind sels
 1393   | PatSynBind _ (PSB { psb_args = RecCon as }) <- unXRec @p bind
 1394   = map recordPatSynField as ++ sels
 1395   | otherwise = sels
 1396 
 1397 getPatSynBinds :: forall id. UnXRec id
 1398                => [(RecFlag, LHsBinds id)] -> [PatSynBind id id]
 1399 getPatSynBinds binds
 1400   = [ psb | (_, lbinds) <- binds
 1401           , (unXRec @id -> (PatSynBind _ psb)) <- bagToList lbinds ]
 1402 
 1403 -------------------
 1404 hsLInstDeclBinders :: IsPass p
 1405                    => LInstDecl (GhcPass p)
 1406                    -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])
 1407 hsLInstDeclBinders (L _ (ClsInstD
 1408                              { cid_inst = ClsInstDecl
 1409                                           { cid_datafam_insts = dfis }}))
 1410   = foldMap (hsDataFamInstBinders . unLoc) dfis
 1411 hsLInstDeclBinders (L _ (DataFamInstD { dfid_inst = fi }))
 1412   = hsDataFamInstBinders fi
 1413 hsLInstDeclBinders (L _ (TyFamInstD {})) = mempty
 1414 
 1415 -------------------
 1416 -- | the 'SrcLoc' returned are for the whole declarations, not just the names
 1417 hsDataFamInstBinders :: IsPass p
 1418                      => DataFamInstDecl (GhcPass p)
 1419                      -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])
 1420 hsDataFamInstBinders (DataFamInstDecl { dfid_eqn = FamEqn { feqn_rhs = defn }})
 1421   = hsDataDefnBinders defn
 1422   -- There can't be repeated symbols because only data instances have binders
 1423 
 1424 -------------------
 1425 -- | the 'SrcLoc' returned are for the whole declarations, not just the names
 1426 hsDataDefnBinders :: IsPass p
 1427                   => HsDataDefn (GhcPass p)
 1428                   -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])
 1429 hsDataDefnBinders (HsDataDefn { dd_cons = cons })
 1430   = hsConDeclsBinders cons
 1431   -- See Note [Binders in family instances]
 1432 
 1433 -------------------
 1434 type Seen p = [LFieldOcc (GhcPass p)] -> [LFieldOcc (GhcPass p)]
 1435                  -- Filters out ones that have already been seen
 1436 
 1437 hsConDeclsBinders :: forall p. IsPass p
 1438                   => [LConDecl (GhcPass p)]
 1439                   -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])
 1440    -- See hsLTyClDeclBinders for what this does
 1441    -- The function is boringly complicated because of the records
 1442    -- And since we only have equality, we have to be a little careful
 1443 hsConDeclsBinders cons
 1444   = go id cons
 1445   where
 1446     go :: Seen p -> [LConDecl (GhcPass p)]
 1447        -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])
 1448     go _ [] = ([], [])
 1449     go remSeen (r:rs)
 1450       -- Don't re-mangle the location of field names, because we don't
 1451       -- have a record of the full location of the field declaration anyway
 1452       = let loc = getLoc r
 1453         in case unLoc r of
 1454            -- remove only the first occurrence of any seen field in order to
 1455            -- avoid circumventing detection of duplicate fields (#9156)
 1456            ConDeclGADT { con_names = names, con_g_args = args }
 1457              -> (map (L loc . unLoc) names ++ ns, flds ++ fs)
 1458              where
 1459                 (remSeen', flds) = get_flds_gadt remSeen args
 1460                 (ns, fs) = go remSeen' rs
 1461 
 1462            ConDeclH98 { con_name = name, con_args = args }
 1463              -> ([L loc (unLoc name)] ++ ns, flds ++ fs)
 1464              where
 1465                 (remSeen', flds) = get_flds_h98 remSeen args
 1466                 (ns, fs) = go remSeen' rs
 1467 
 1468     get_flds_h98 :: Seen p -> HsConDeclH98Details (GhcPass p)
 1469                  -> (Seen p, [LFieldOcc (GhcPass p)])
 1470     get_flds_h98 remSeen (RecCon flds) = get_flds remSeen flds
 1471     get_flds_h98 remSeen _ = (remSeen, [])
 1472 
 1473     get_flds_gadt :: Seen p -> HsConDeclGADTDetails (GhcPass p)
 1474                   -> (Seen p, [LFieldOcc (GhcPass p)])
 1475     get_flds_gadt remSeen (RecConGADT flds _) = get_flds remSeen flds
 1476     get_flds_gadt remSeen _ = (remSeen, [])
 1477 
 1478     get_flds :: Seen p -> LocatedL [LConDeclField (GhcPass p)]
 1479              -> (Seen p, [LFieldOcc (GhcPass p)])
 1480     get_flds remSeen flds = (remSeen', fld_names)
 1481        where
 1482           fld_names = remSeen (concatMap (cd_fld_names . unLoc) (unLoc flds))
 1483           remSeen' = foldr (.) remSeen
 1484                                [deleteBy ((==) `on` unLoc . foLabel . unLoc) v
 1485                                | v <- fld_names]
 1486 
 1487 {-
 1488 
 1489 Note [SrcSpan for binders]
 1490 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 1491 When extracting the (Located RdrNme) for a binder, at least for the
 1492 main name (the TyCon of a type declaration etc), we want to give it
 1493 the @SrcSpan@ of the whole /declaration/, not just the name itself
 1494 (which is how it appears in the syntax tree).  This SrcSpan (for the
 1495 entire declaration) is used as the SrcSpan for the Name that is
 1496 finally produced, and hence for error messages.  (See #8607.)
 1497 
 1498 Note [Binders in family instances]
 1499 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 1500 In a type or data family instance declaration, the type
 1501 constructor is an *occurrence* not a binding site
 1502     type instance T Int = Int -> Int   -- No binders
 1503     data instance S Bool = S1 | S2     -- Binders are S1,S2
 1504 
 1505 
 1506 ************************************************************************
 1507 *                                                                      *
 1508         Collecting binders the user did not write
 1509 *                                                                      *
 1510 ************************************************************************
 1511 
 1512 The job of this family of functions is to run through binding sites and find the set of all Names
 1513 that were defined "implicitly", without being explicitly written by the user.
 1514 
 1515 The main purpose is to find names introduced by record wildcards so that we can avoid
 1516 warning the user when they don't use those names (#4404)
 1517 
 1518 Since the addition of -Wunused-record-wildcards, this function returns a pair
 1519 of [(SrcSpan, [Name])]. Each element of the list is one set of implicit
 1520 binders, the first component of the tuple is the document describes the possible
 1521 fix to the problem (by removing the ..).
 1522 
 1523 This means there is some unfortunate coupling between this function and where it
 1524 is used but it's only used for one specific purpose in one place so it seemed
 1525 easier.
 1526 -}
 1527 
 1528 lStmtsImplicits :: [LStmtLR GhcRn (GhcPass idR) (LocatedA (body (GhcPass idR)))]
 1529                 -> [(SrcSpan, [Name])]
 1530 lStmtsImplicits = hs_lstmts
 1531   where
 1532     hs_lstmts :: [LStmtLR GhcRn (GhcPass idR) (LocatedA (body (GhcPass idR)))]
 1533               -> [(SrcSpan, [Name])]
 1534     hs_lstmts = concatMap (hs_stmt . unLoc)
 1535 
 1536     hs_stmt :: StmtLR GhcRn (GhcPass idR) (LocatedA (body (GhcPass idR)))
 1537             -> [(SrcSpan, [Name])]
 1538     hs_stmt (BindStmt _ pat _) = lPatImplicits pat
 1539     hs_stmt (ApplicativeStmt _ args _) = concatMap do_arg args
 1540       where do_arg (_, ApplicativeArgOne { app_arg_pattern = pat }) = lPatImplicits pat
 1541             do_arg (_, ApplicativeArgMany { app_stmts = stmts }) = hs_lstmts stmts
 1542     hs_stmt (LetStmt _ binds)     = hs_local_binds binds
 1543     hs_stmt (BodyStmt {})         = []
 1544     hs_stmt (LastStmt {})         = []
 1545     hs_stmt (ParStmt _ xs _ _)    = hs_lstmts [s | ParStmtBlock _ ss _ _ <- xs
 1546                                                 , s <- ss]
 1547     hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts
 1548     hs_stmt (RecStmt { recS_stmts = L _ ss }) = hs_lstmts ss
 1549 
 1550     hs_local_binds (HsValBinds _ val_binds) = hsValBindsImplicits val_binds
 1551     hs_local_binds (HsIPBinds {})           = []
 1552     hs_local_binds (EmptyLocalBinds _)      = []
 1553 
 1554 hsValBindsImplicits :: HsValBindsLR GhcRn (GhcPass idR) -> [(SrcSpan, [Name])]
 1555 hsValBindsImplicits (XValBindsLR (NValBinds binds _))
 1556   = concatMap (lhsBindsImplicits . snd) binds
 1557 hsValBindsImplicits (ValBinds _ binds _)
 1558   = lhsBindsImplicits binds
 1559 
 1560 lhsBindsImplicits :: LHsBindsLR GhcRn idR -> [(SrcSpan, [Name])]
 1561 lhsBindsImplicits = foldBag (++) (lhs_bind . unLoc) []
 1562   where
 1563     lhs_bind (PatBind { pat_lhs = lpat }) = lPatImplicits lpat
 1564     lhs_bind _ = []
 1565 
 1566 lPatImplicits :: LPat GhcRn -> [(SrcSpan, [Name])]
 1567 lPatImplicits = hs_lpat
 1568   where
 1569     hs_lpat lpat = hs_pat (unLoc lpat)
 1570 
 1571     hs_lpats = foldr (\pat rest -> hs_lpat pat ++ rest) []
 1572 
 1573     hs_pat (LazyPat _ pat)      = hs_lpat pat
 1574     hs_pat (BangPat _ pat)      = hs_lpat pat
 1575     hs_pat (AsPat _ _ pat)      = hs_lpat pat
 1576     hs_pat (ViewPat _ _ pat)    = hs_lpat pat
 1577     hs_pat (ParPat _ _ pat _)   = hs_lpat pat
 1578     hs_pat (ListPat _ pats)     = hs_lpats pats
 1579     hs_pat (TuplePat _ pats _)  = hs_lpats pats
 1580 
 1581     hs_pat (SigPat _ pat _)     = hs_lpat pat
 1582 
 1583     hs_pat (ConPat {pat_con=con, pat_args=ps}) = details con ps
 1584 
 1585     hs_pat _ = []
 1586 
 1587     details :: LocatedN Name -> HsConPatDetails GhcRn -> [(SrcSpan, [Name])]
 1588     details _ (PrefixCon _ ps) = hs_lpats ps
 1589     details n (RecCon fs)      =
 1590       [(err_loc, collectPatsBinders CollNoDictBinders implicit_pats) | Just{} <- [rec_dotdot fs] ]
 1591         ++ hs_lpats explicit_pats
 1592 
 1593       where implicit_pats = map (hfbRHS . unLoc) implicit
 1594             explicit_pats = map (hfbRHS . unLoc) explicit
 1595 
 1596 
 1597             (explicit, implicit) = partitionEithers [if pat_explicit then Left fld else Right fld
 1598                                                     | (i, fld) <- [0..] `zip` rec_flds fs
 1599                                                     ,  let  pat_explicit =
 1600                                                               maybe True ((i<) . unLoc)
 1601                                                                          (rec_dotdot fs)]
 1602             err_loc = maybe (getLocA n) getLoc (rec_dotdot fs)
 1603 
 1604     details _ (InfixCon p1 p2) = hs_lpat p1 ++ hs_lpat p2