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