Alan Zimmerman pushed to branch wip/az/epa-tidy-locatedxxx-7 at Glasgow Haskell Compiler / GHC Commits: cd00cfa6 by Alan Zimmerman at 2026-07-12T10:19:15+01:00 EPA: Keep binds and sigs together in HsValBindsLR We combine them into a single list for GhcPs, wrapped in the ValBind data type, which is the bind equivalent of ValD, having constructors for binds and sigs. This simplifies exact print processing, especially when using it to update the contents of local binds, as we no longer need AnnSortKey BindTag - - - - - 25 changed files: - compiler/GHC/Hs/Binds.hs - compiler/GHC/Hs/Instances.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Rename/Bind.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Tc/Deriv.hs - compiler/GHC/ThToHs.hs - compiler/Language/Haskell/Syntax/Binds.hs - compiler/Language/Haskell/Syntax/Extension.hs - ghc/GHCi/UI.hs - testsuite/tests/parser/should_compile/DumpSemis.stderr - testsuite/tests/printer/Test20297.stdout - utils/check-exact/ExactPrint.hs - utils/check-exact/Main.hs - utils/check-exact/Transform.hs - utils/check-exact/Utils.hs Changes: ===================================== compiler/GHC/Hs/Binds.hs ===================================== @@ -78,7 +78,7 @@ type instance XEmptyLocalBinds (GhcPass pL) (GhcPass pR) = NoExtField type instance XXHsLocalBindsLR (GhcPass pL) (GhcPass pR) = DataConCantHappen -- --------------------------------------------------------------------- -type instance XValBinds (GhcPass pL) (GhcPass pR) = AnnSortKey BindTag +type instance XValBinds (GhcPass pL) (GhcPass pR) = NoExtField type instance XXValBindsLR (GhcPass pL) _ = HsValBindGroups pL @@ -154,6 +154,10 @@ data AnnPSB instance NoAnn AnnPSB where noAnn = AnnPSB noAnn noAnn noAnn noAnn +instance HasLoc (ValBind (GhcPass p) (GhcPass p)) where + getHasLoc (VbBind b) = getHasLoc b + getHasLoc (VbSig s) = getHasLoc s + -- --------------------------------------------------------------------- -- | Typechecked, generalised bindings, used in the output to the type checker. @@ -442,8 +446,8 @@ instance (OutputableBndrId pl, OutputableBndrId pr) instance (OutputableBndrId pl, OutputableBndrId pr) => Outputable (HsValBindsLR (GhcPass pl) (GhcPass pr)) where - ppr (ValBinds _ binds sigs) - = pprDeclList (pprLHsBindsForUser binds sigs) + ppr (ValBinds _ binds) + = pprDeclList (pprLHsBindsForUser' binds) ppr (XValBindsLR (HsVBG bs sigs)) = getPprDebug $ \case @@ -487,6 +491,21 @@ pprLHsBindsForUser binds sigs sort_by_loc decls = sortBy (SrcLoc.leftmost_smallest `on` fst) decls +pprLHsBindsForUser' :: (OutputableBndrId idL, OutputableBndrId idR) + => [ValBind (GhcPass idL) (GhcPass idR)] -> [SDoc] +-- pprLHsBindsForUser is different to pprLHsBinds because +-- a) No braces: 'let' and 'where' include a list of HsBindGroups +-- and we don't want several groups of bindings each +-- with braces around +-- b) Sort by location before printing +-- c) Include signatures +pprLHsBindsForUser' binds + = map ppr_bind binds + where + ppr_bind (VbBind b) = ppr b + ppr_bind (VbSig s) = ppr s + + pprDeclList :: [SDoc] -> SDoc -- Braces with a space -- Print a bunch of declarations -- One could choose { d1; d2; ... }, using 'sep' @@ -507,11 +526,11 @@ eqEmptyLocalBinds (EmptyLocalBinds _) = True eqEmptyLocalBinds _ = False isEmptyValBinds :: HsValBindsLR (GhcPass a) (GhcPass b) -> Bool -isEmptyValBinds (ValBinds _ ds sigs) = isEmptyLHsBinds ds && null sigs +isEmptyValBinds (ValBinds _ binds) = null binds isEmptyValBinds (XValBindsLR (HsVBG ds sigs)) = null ds && null sigs emptyValBindsIn :: HsValBindsLR (GhcPass a) (GhcPass b) -emptyValBindsIn = ValBinds NoAnnSortKey [] [] +emptyValBindsIn = ValBinds noExtField [] emptyValBindsRn :: HsValBindsLR GhcRn GhcRn emptyValBindsRn = XValBindsLR (HsVBG [] []) @@ -532,8 +551,8 @@ hsValBindGroupsBinds binds ------------ plusHsValBinds :: HsValBinds (GhcPass a) -> HsValBinds (GhcPass a) -> HsValBinds(GhcPass a) -plusHsValBinds (ValBinds _ ds1 sigs1) (ValBinds _ ds2 sigs2) - = ValBinds NoAnnSortKey (ds1 ++ ds2) (sigs1 ++ sigs2) +plusHsValBinds (ValBinds _ ds1) (ValBinds _ ds2) + = ValBinds noExtField (ds1 ++ ds2) plusHsValBinds (XValBindsLR (HsVBG ds1 ss1)) (XValBindsLR (HsVBG ds2 ss2)) = XValBindsLR (HsVBG (ds1++ds2) (ss1++ss2)) plusHsValBinds _ _ ===================================== compiler/GHC/Hs/Instances.hs ===================================== @@ -73,6 +73,11 @@ deriving instance Data (HsValBindsLR GhcPs GhcRn) deriving instance Data (HsValBindsLR GhcRn GhcRn) deriving instance Data (HsValBindsLR GhcTc GhcTc) +deriving instance Data (ValBind GhcPs GhcPs) +deriving instance Data (ValBind GhcPs GhcRn) +deriving instance Data (ValBind GhcRn GhcRn) +deriving instance Data (ValBind GhcTc GhcTc) + -- deriving instance (DataIdLR pL pL) => Data (NHsValBindsLR pL) deriving instance Data (HsValBindGroups 'Parsed) deriving instance Data (HsValBindGroups 'Renamed) ===================================== compiler/GHC/Hs/Utils.hs ===================================== @@ -84,8 +84,8 @@ module GHC.Hs.Utils( -- * Collecting binders isUnliftedHsBind, isUnliftedHsBinds, isBangedHsBind, - collectLocalBinders, collectHsValBinders, collectHsBindListBinders, - collectHsIdBinders, + collectLocalBinders, collectHsValBinders, collectHsValBinders', collectHsBindListBinders, + collectHsIdBinders, collectHsIdBinders', collectHsBindsBinders, collectHsBindBinders, collectMethodBinders, collectPatBinders, collectPatsBinders, @@ -885,8 +885,11 @@ spanHsLocaLBinds (EmptyLocalBinds _) = noSrcSpan spanHsLocaLBinds (HsIPBinds _ (IPBinds _ bs)) = get_bind_spans bs [] -spanHsLocaLBinds (HsValBinds _ (ValBinds _ bs sigs)) - = get_bind_spans bs sigs +spanHsLocaLBinds (HsValBinds _ (ValBinds _ binds)) + = get_bind_spans bs ss + where + bs :: [LHsBindLR (GhcPass p) (GhcPass p)] + (bs,ss) = val_binds_and_sigs binds spanHsLocaLBinds (HsValBinds _ (XValBindsLR (HsVBG bs ss))) = get_bind_spans (hsValBindGroupsBinds @p bs) ss @@ -1085,12 +1088,25 @@ collectHsIdBinders :: (IsPass idL, CollectPass (GhcPass idL)) -- ^ Collect 'Id' binders only, or 'Id's + pattern synonyms, respectively collectHsIdBinders flag = collect_hs_val_binders True flag +collectHsIdBinders' :: (IsPass idL, CollectPass (GhcPass idL)) + => CollectFlag (GhcPass idL) + -> [LHsBindLR (GhcPass idL) idR] + -> [IdP (GhcPass idL)] +-- ^ Collect 'Id' binders only, or 'Id's + pattern synonyms, respectively +collectHsIdBinders' flag = collect_hs_val_binders' True flag + collectHsValBinders :: (IsPass idL, CollectPass (GhcPass idL)) => CollectFlag (GhcPass idL) -> HsValBindsLR (GhcPass idL) idR -> [IdP (GhcPass idL)] collectHsValBinders flag = collect_hs_val_binders False flag +collectHsValBinders' :: (IsPass idL, CollectPass (GhcPass idL)) + => CollectFlag (GhcPass idL) + -> [LHsBindLR (GhcPass idL) idR] + -> [IdP (GhcPass idL)] +collectHsValBinders' flag = collect_hs_val_binders' False flag + collectHsBindBinders :: CollectPass p => CollectFlag p -> HsBindLR p idR @@ -1117,9 +1133,17 @@ collect_hs_val_binders :: forall idL idR. (IsPass idL, CollectPass (GhcPass idL) -> HsValBindsLR (GhcPass idL) idR -> [IdP (GhcPass idL)] collect_hs_val_binders ps flag = \case - ValBinds _ binds _ -> collect_binds ps flag binds [] + ValBinds _ binds -> collect_binds ps flag (val_binds binds) [] XValBindsLR (HsVBG grps _) -> collect_binds ps flag (hsValBindGroupsBinds @idL grps) [] +collect_hs_val_binders' :: forall idL idR. (IsPass idL, CollectPass (GhcPass idL)) + => Bool + -> CollectFlag (GhcPass idL) + -> [LHsBindLR (GhcPass idL) idR] + -> [IdP (GhcPass idL)] +collect_hs_val_binders' ps flag binds = collect_binds ps flag binds [] + + collect_binds :: forall p idR. CollectPass p => Bool -> CollectFlag p @@ -1528,7 +1552,7 @@ hsForeignDeclsBinders foreign_decls hsPatSynSelectors :: IsPass p => HsValBinds (GhcPass p) -> [FieldOcc (GhcPass p)] -- ^ Collects record pattern-synonym selectors only; the pattern synonym -- names are collected by 'collectHsValBinders'. -hsPatSynSelectors (ValBinds _ _ _) = panic "hsPatSynSelectors" +hsPatSynSelectors (ValBinds _ _) = panic "hsPatSynSelectors" hsPatSynSelectors (XValBindsLR (HsVBG grps _)) = foldr addPatSynSelector [] $ hsValBindGroupsBinds grps @@ -1814,8 +1838,8 @@ hsValBindsImplicits :: HsValBindsLR GhcRn (GhcPass idR) -> [(SrcSpan, [ImplicitFieldBinders])] hsValBindsImplicits (XValBindsLR (HsVBG grps _)) = lhsBindsImplicits (hsValBindGroupsBinds grps) -hsValBindsImplicits (ValBinds _ binds _) - = lhsBindsImplicits binds +hsValBindsImplicits (ValBinds _ binds) + = lhsBindsImplicits (val_binds binds) lhsBindsImplicits :: LHsBindsLR GhcRn idR -> [(SrcSpan, [ImplicitFieldBinders])] lhsBindsImplicits = concatMap (lhs_bind . unLoc) ===================================== compiler/GHC/HsToCore/Quote.hs ===================================== @@ -338,8 +338,8 @@ hsScopedTvBinders binds = concatMap get_scoped_tvs sigs where sigs = case binds of - ValBinds _ _ sigs -> sigs - XValBindsLR (HsVBG _ sigs) -> sigs + ValBinds _ bs -> val_sigs bs + XValBindsLR (HsVBG _ sigs) -> sigs get_scoped_tvs :: LSig GhcRn -> [Name] get_scoped_tvs (L _ signature) @@ -2004,7 +2004,7 @@ rep_val_binds (XValBindsLR (HsVBG binds sigs)) = do { core1 <- rep_binds (concatMap snd binds) ; core2 <- rep_sigs sigs ; return (core1 ++ core2) } -rep_val_binds (ValBinds _ _ _) +rep_val_binds (ValBinds _ _) = panic "rep_val_binds: ValBinds" rep_binds :: LHsBinds GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))] ===================================== compiler/GHC/HsToCore/Ticks.hs ===================================== @@ -1438,7 +1438,7 @@ instance CollectFldBinders (HsLocalBinds GhcTc) where collectFldBinds HsIPBinds{} = emptyVarEnv collectFldBinds EmptyLocalBinds{} = emptyVarEnv instance CollectFldBinders (HsValBinds GhcTc) where - collectFldBinds (ValBinds _ bnds _) = collectFldBinds bnds + collectFldBinds (ValBinds _ bnds) = collectFldBinds (val_binds bnds) collectFldBinds (XValBindsLR (HsVBG grps _)) = collectFldBinds (hsValBindGroupsBinds @'Typechecked grps) instance CollectFldBinders (HsBind GhcTc) where ===================================== compiler/GHC/Iface/Ext/Ast.hs ===================================== @@ -1462,13 +1462,11 @@ instance HiePass p => ToHie (RScoped (HsLocalBinds (GhcPass p))) where ] scopeHsLocaLBinds :: forall p. IsPass p => HsLocalBinds (GhcPass p) -> Scope -scopeHsLocaLBinds (HsValBinds _ (ValBinds _ bs sigs)) - = foldr combineScopes NoScope (bsScope ++ sigsScope) +scopeHsLocaLBinds (HsValBinds _ (ValBinds _ bs)) + = foldr combineScopes NoScope bsScope where bsScope :: [Scope] - bsScope = map (mkScope . getLoc) bs - sigsScope :: [Scope] - sigsScope = map (mkScope . getLocA) sigs + bsScope = map (mkScope . getHasLoc) bs scopeHsLocaLBinds (HsValBinds _ (XValBindsLR (HsVBG grps sigs))) = foldr combineScopes NoScope (bsScope ++ sigsScope) where @@ -1491,7 +1489,9 @@ instance HiePass p => ToHie (RScoped (LocatedA (IPBind (GhcPass p)))) where instance HiePass p => ToHie (RScoped (HsValBindsLR (GhcPass p) (GhcPass p))) where toHie (RS sc v) = concatM $ case v of - ValBinds _ binds sigs -> + ValBinds _ binds_and_sigs -> + let (binds, sigs) = val_binds_and_sigs binds_and_sigs + in [ toHie $ fmap (BC RegularBind sc) binds , toHie $ fmap (SC (SI BindSig Nothing)) sigs ] ===================================== compiler/GHC/Parser/Annotation.hs ===================================== @@ -41,7 +41,7 @@ module GHC.Parser.Annotation ( NameAnn(..), NameAdornment(..), NoEpAnns(..), - AnnSortKey(..), DeclTag(..), BindTag(..), + AnnSortKey(..), DeclTag(..), -- ** Trailing annotations in lists TrailingAnn(..), ta_location, @@ -652,13 +652,6 @@ data AnnSortKey tag | AnnSortKey [tag] deriving (Data, Eq) --- | Used to track of interleaving of binds and signatures for ValBind -data BindTag - -- See Note [AnnSortKey] below - = BindTag - | SigDTag - deriving (Eq,Data,Ord,Show) - -- | Used to track interleaving of class methods, class signatures, -- associated types and associate type defaults in `ClassDecl` and -- `ClsInstDecl`. @@ -1179,9 +1172,6 @@ instance Outputable EpAnnComments where instance (NamedThing (Located a)) => NamedThing (LocatedAn an a) where getName (L l a) = getName (L (locA l) a) -instance Outputable BindTag where - ppr tag = text $ show tag - instance Outputable DeclTag where ppr tag = text $ show tag ===================================== compiler/GHC/Parser/PostProcess.hs ===================================== @@ -33,6 +33,7 @@ module GHC.Parser.PostProcess ( addModifiersToDecl, cvBindGroup, + cvBindsAndSigsOnly, wrapValBind, cvBindsAndSigs, cvTopDecls, placeHolderPunRhs, @@ -521,10 +522,28 @@ cvTopDecls decls = getMonoBindAll (fromOL decls) -- Declaration list may only contain value bindings and signatures. cvBindGroup :: OrdList (LHsDecl GhcPs) -> P (HsValBinds GhcPs) cvBindGroup binding - = do { (mbs, sigs, fam_ds, tfam_insts - , dfam_insts, _) <- cvBindsAndSigs binding - ; massert (null fam_ds && null tfam_insts && null dfam_insts) - ; return $ ValBinds NoAnnSortKey mbs sigs } + = do { binds <- cvBindsAndSigsOnly binding + ; return $ ValBinds noExtField binds } + +cvBindsAndSigsOnly :: OrdList (LHsDecl GhcPs) + -> P [ValBind GhcPs GhcPs] +-- Input decls contain just value bindings and signatures +-- and in case of class or instance declarations also +-- associated type declarations. They might also contain Haddock comments. +cvBindsAndSigsOnly fb = do + fb' <- drop_bad_decls (fromOL fb) + return (fmap wrapValBind (getMonoBindAll fb')) + where + drop_bad_decls [] = return [] + drop_bad_decls (L l (SpliceD _ d) : ds) = do + addError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrDeclSpliceNotAtTopLevel d + drop_bad_decls ds + drop_bad_decls (d:ds) = (d:) <$> drop_bad_decls ds + +wrapValBind :: LHsDecl (GhcPass p) -> ValBind (GhcPass p) (GhcPass p) +wrapValBind (L l (ValD _ b)) = VbBind (L l b) +wrapValBind (L l (SigD _ s)) = VbSig (L l s) +wrapValBind _ = panic "wrapValBind: got unexpected decl" cvBindsAndSigs :: OrdList (LHsDecl GhcPs) -> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs] ===================================== compiler/GHC/Rename/Bind.hs ===================================== @@ -195,21 +195,18 @@ it expects the global environment to contain bindings for the binders -- so we have a different entry point than for local bindings rnTopBindsLHS :: MiniFixityEnv -> HsValBinds GhcPs - -> RnM (HsValBindsLR GhcRn GhcPs) + -> RnM ([LHsBindLR GhcRn GhcPs], [LSig GhcPs]) rnTopBindsLHS fix_env binds = rnValBindsLHS (topRecNameMaker fix_env) binds -- Ensure that a hs-boot file has no top-level bindings. rnTopBindsLHSBoot :: MiniFixityEnv -> HsValBinds GhcPs - -> RnM (HsValBindsLR GhcRn GhcPs) + -> RnM ([LHsBindLR GhcRn GhcPs], [LSig GhcPs]) rnTopBindsLHSBoot fix_env binds - = do { topBinds <- rnTopBindsLHS fix_env binds - ; case topBinds of - ValBinds x mbinds sigs -> - do { rejectBootDecls HsBoot BootBindsPs mbinds - ; pure (ValBinds x [] sigs) } - _ -> pprPanic "rnTopBindsLHSBoot" (ppr topBinds) } + = do { (mbinds, sigs) <- rnTopBindsLHS fix_env binds + ; rejectBootDecls HsBoot BootBindsPs mbinds + ; pure ([], sigs) } rejectBootDecls :: HsBootOrSig -> (NonEmpty (LocatedA decl) -> BadBootDecls) @@ -225,8 +222,8 @@ rnTopBindsBoot :: NameSet -> HsValBindsLR GhcRn GhcPs -> RnM (HsValBinds GhcRn, DefUses) -- A hs-boot file has no bindings. -- Return a single HsBindGroup with empty binds and renamed signatures -rnTopBindsBoot bound_names (ValBinds _ _ sigs) - = do { (sigs', fvs) <- renameSigs (HsBootCtxt bound_names) sigs +rnTopBindsBoot bound_names (ValBinds _ val_binds) + = do { (sigs', fvs) <- renameSigs (HsBootCtxt bound_names) (val_sigs val_binds) ; return (XValBindsLR (HsVBG [] sigs'), usesOnly fvs) } rnTopBindsBoot _ b = pprPanic "rnTopBindsBoot" (ppr b) @@ -278,9 +275,9 @@ rnIPBind (IPBind _ n expr) = do -- Does duplicate/shadow check rnLocalValBindsLHS :: MiniFixityEnv -> HsValBinds GhcPs - -> RnM ([Name], HsValBindsLR GhcRn GhcPs) + -> RnM ([Name], ([LHsBindLR GhcRn GhcPs], [LSig GhcPs])) rnLocalValBindsLHS fix_env binds - = do { binds' <- rnValBindsLHS (localRecNameMaker fix_env) binds + = do { (binds',sigs) <- rnValBindsLHS (localRecNameMaker fix_env) binds -- Check for duplicates and shadowing -- Must do this *after* renaming the patterns @@ -300,26 +297,27 @@ rnLocalValBindsLHS fix_env binds -- import A(f) -- g = let f = ... in f -- should. - ; let bound_names = collectHsValBinders CollNoDictBinders binds' + ; let bound_names = collectHsValBinders' CollNoDictBinders binds' -- There should be only Ids, but if there are any bogus -- pattern synonyms, we'll collect them anyway, so that -- we don't generate subsequent out-of-scope messages ; envs <- getRdrEnvs ; checkDupAndShadowedNames envs bound_names - ; return (bound_names, binds') } + ; return (bound_names, (binds', sigs)) } -- renames the left-hand sides -- generic version used both at the top level and for local binds -- does some error checking, but not what gets done elsewhere at the top level rnValBindsLHS :: NameMaker -> HsValBinds GhcPs - -> RnM (HsValBindsLR GhcRn GhcPs) -rnValBindsLHS topP (ValBinds x mbinds sigs) - = do { mbinds' <- mapM (wrapLocMA (rnBindLHS topP doc)) mbinds - ; return $ ValBinds x mbinds' sigs } + -> RnM ([LHsBindLR GhcRn GhcPs], [LSig GhcPs]) +rnValBindsLHS topP (ValBinds _ vbinds) + = do { let (mbinds, sigs) = val_binds_and_sigs vbinds + ; mbinds' <- mapM (wrapLocMA (rnBindLHS topP doc)) mbinds + ; return (mbinds', sigs) } where - bndrs = collectHsBindsBinders CollNoDictBinders mbinds + bndrs = collectHsBindsBinders CollNoDictBinders (val_binds vbinds) doc = text "In the binding group for:" <+> pprWithCommas ppr bndrs rnValBindsLHS _ b = pprPanic "rnValBindsLHSFromDoc" (ppr b) @@ -332,8 +330,9 @@ rnValBindsRHS :: HsSigCtxt -> HsValBindsLR GhcRn GhcPs -> RnM (HsValBinds GhcRn, DefUses) -rnValBindsRHS ctxt (ValBinds _ mbinds sigs) - = do { (sigs', sig_fvs) <- renameSigs ctxt sigs +rnValBindsRHS ctxt (ValBinds _ vbinds) + = do { let (mbinds, sigs) = val_binds_and_sigs vbinds + ; (sigs', sig_fvs) <- renameSigs ctxt sigs -- Update the TcGblEnv with renamed COMPLETE pragmas from the current -- module, for pattern irrefutability checking in do notation. @@ -383,20 +382,22 @@ rnLocalValBindsAndThen :: HsValBinds GhcPs -> (HsValBinds GhcRn -> FreeNames -> RnM (result, FreeNames)) -> RnM (result, FreeNames) -rnLocalValBindsAndThen binds@(ValBinds _ _ sigs) thing_inside - = do { -- (A) Create the local fixity environment - new_fixities <- makeMiniFixityEnv [ L loc sig +rnLocalValBindsAndThen binds@(ValBinds _ vbinds) thing_inside + = do { let sigs = val_sigs vbinds + -- (A) Create the local fixity environment + ; new_fixities <- makeMiniFixityEnv [ L loc sig | L loc (FixSig _ sig) <- sigs] -- (B) Rename the LHSes - ; (bound_names, new_lhs) <- rnLocalValBindsLHS new_fixities binds + ; (bound_names, (binds',sigs')) <- rnLocalValBindsLHS new_fixities binds -- ...and bring them (and their fixities) into scope ; bindLocalNamesFV bound_names $ addLocalFixities new_fixities bound_names $ do { -- (C) Do the RHS and thing inside - (binds', dus) <- rnLocalValBindsRHS (mkNameSet bound_names) new_lhs + let new_lhs :: HsValBindsLR GhcRn GhcPs = ValBinds noExtField (map VbBind binds' ++ map VbSig sigs') + ; (binds', dus) <- rnLocalValBindsRHS (mkNameSet bound_names) new_lhs ; (result, result_fvs) <- thing_inside binds' (allUses dus) -- Report unused bindings based on the (accurate) ===================================== compiler/GHC/Rename/Expr.hs ===================================== @@ -1546,10 +1546,10 @@ rnRecStmtsAndThen ctxt rnBody s cont collectRecStmtsFixities :: [LStmtLR GhcPs GhcPs body] -> [LFixitySig GhcPs] collectRecStmtsFixities l = foldr (\ s -> \acc -> case s of - (L _ (LetStmt _ (HsValBinds _ (ValBinds _ _ sigs)))) -> + (L _ (LetStmt _ (HsValBinds _ (ValBinds _ bs)))) -> foldr (\ sig -> \ acc -> case sig of (L loc (FixSig _ s)) -> (L loc s) : acc - _ -> acc) acc sigs + _ -> acc) acc (val_sigs bs) _ -> acc) [] l -- left-hand sides @@ -1578,8 +1578,8 @@ rn_rec_stmt_lhs _ (L _ (LetStmt _ binds@(HsIPBinds {}))) rn_rec_stmt_lhs fix_env (L loc (LetStmt _ (HsValBinds x binds))) - = do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds - return [(L loc (LetStmt noAnn (HsValBinds x binds')), + = do (_bound_names, (bs',sigs')) <- rnLocalValBindsLHS fix_env binds + return [(L loc (LetStmt noAnn (HsValBinds x (makeRnValBinds noExtField bs' sigs'))), -- Warning: this is bogus; see function invariant emptyFNs )] ===================================== compiler/GHC/Rename/Module.hs ===================================== @@ -32,7 +32,8 @@ import GHC.Rename.Utils ( mapFvRn, bindLocalNames , checkDupRdrNames, bindLocalNamesFV , warnUnusedTypePatterns , noNestedForallsContextsErr - , addNoNestedForallsContextsErr, checkInferredVars ) + , addNoNestedForallsContextsErr, checkInferredVars + , makeRnValBinds) import GHC.Rename.Unbound ( mkUnboundName, notInScopeErr, WhereLooking(WL_Global) ) import GHC.Rename.Names @@ -148,12 +149,12 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls, -- We need to throw an error on such value bindings when in a boot file. is_boot <- tcIsHsBootOrSig ; - new_lhs <- if is_boot + (binds', sigs') <- if is_boot then rnTopBindsLHSBoot local_fix_env val_decls else rnTopBindsLHS local_fix_env val_decls ; -- Bind the LHSes (and their fixities) in the global rdr environment - let { id_bndrs = collectHsIdBinders CollNoDictBinders new_lhs } ; + let { id_bndrs = collectHsIdBinders' CollNoDictBinders binds' } ; -- Excludes pattern-synonym binders -- They are already in scope traceRn "rnSrcDecls" (ppr id_bndrs) ; @@ -178,6 +179,7 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls, -- (F) Rename Value declarations right-hand sides traceRn "Start rnmono" empty ; let { val_bndr_set = mkNameSet id_bndrs `unionNameSet` mkNameSet pat_syn_bndrs } ; + let { new_lhs = makeRnValBinds noExtField binds' sigs' } ; (rn_val_decls@(XValBindsLR (HsVBG _ sigs')), bind_dus) <- if is_boot -- For an hs-boot, use tc_bndrs (which collects how we're renamed -- signatures), since val_bndr_set is empty (there are no x = ... @@ -2723,7 +2725,7 @@ extendPatSynEnv dup_fields_ok has_sel val_decls local_fix_env thing = do { where new_ps :: HsValBinds GhcPs -> TcM [(ConLikeName, ConInfo)] - new_ps (ValBinds _ binds _) = foldrM new_ps' [] binds + new_ps (ValBinds _ binds) = foldrM new_ps' [] (val_binds binds) new_ps _ = panic "new_ps" new_ps' :: LHsBindLR GhcPs GhcPs @@ -2921,9 +2923,9 @@ add_kisig d (tycls@(TyClGroup { group_kisigs = kisigs }) : rest) = tycls { group_kisigs = d : kisigs } : rest add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a -add_bind b (ValBinds x bs sigs) = ValBinds x (bs ++ [b]) sigs +add_bind b (ValBinds x bs) = ValBinds x (bs ++ [VbBind b]) add_bind _ (XValBindsLR {}) = panic "GHC.Rename.Module.add_bind" add_sig :: LSig (GhcPass a) -> HsValBinds (GhcPass a) -> HsValBinds (GhcPass a) -add_sig s (ValBinds x bs sigs) = ValBinds x bs (s:sigs) +add_sig s (ValBinds x bs) = ValBinds x (VbSig s:bs) add_sig _ (XValBindsLR {}) = panic "GHC.Rename.Module.add_sig" ===================================== compiler/GHC/Rename/Names.hs ===================================== @@ -819,11 +819,11 @@ getLocalNonValBinders fixity_env ; is_boot <- tcIsHsBootOrSig ; let val_bndrs | is_boot = case binds of - ValBinds _ _val_binds val_sigs -> + ValBinds _ val_binds -> -- In a hs-boot file, the value binders come from the -- *signatures*, and there should be no foreign binders [ L (l2l decl_loc) (unLoc n) - | L decl_loc (TypeSig _ _ ns _) <- val_sigs, n <- ns] + | L decl_loc (TypeSig _ _ ns _) <- (val_sigs val_binds), n <- ns] _ -> panic "Non-ValBinds in hs-boot group" | otherwise = for_hs_bndrs ; val_gres <- mapM new_simple val_bndrs ===================================== compiler/GHC/Rename/Utils.hs ===================================== @@ -35,7 +35,9 @@ module GHC.Rename.Utils ( addNameClashErrRn, mkNameClashErr, checkInferredVars, - noNestedForallsContextsErr, addNoNestedForallsContextsErr + noNestedForallsContextsErr, addNoNestedForallsContextsErr, + + makeRnValBinds ) where @@ -868,3 +870,9 @@ mkExpandedTc -> LHsExpr GhcTc -- ^ expanded typechecked expression -> HsExpr GhcTc -- ^ suitably wrapped 'XXExprGhcTc' mkExpandedTc o e = XExpr (ExpandedThingTc (HSE o e)) + +makeRnValBinds :: XValBinds idL idR + -> [XRec idL (HsBindLR idL idR)] + -> [XRec idR (Sig idR)] + -> HsValBindsLR idL idR +makeRnValBinds x binds sigs = ValBinds x (map VbBind binds ++ map VbSig sigs) ===================================== compiler/GHC/Runtime/Eval.hs ===================================== @@ -1261,8 +1261,8 @@ compileParsedExprRemote expr@(L loc _) = withSession $ \hsc_env -> do loc' = locA loc expr_name = mkInternalName (getUnique expr_fs) (mkTyVarOccFS expr_fs) loc' let_stmt = L loc . LetStmt noAnn . (HsValBinds noAnn) $ - ValBinds NoAnnSortKey - [mkHsVarBind loc' (getRdrName expr_name) expr] [] + ValBinds noExtField + [VbBind $ mkHsVarBind loc' (getRdrName expr_name) expr] pstmt <- liftIO $ hscParsedStmt hsc_env let_stmt let (hvals_io, fix_env) = case pstmt of ===================================== compiler/GHC/Tc/Deriv.hs ===================================== @@ -296,13 +296,13 @@ renameDeriv inst_infos bagBinds -- before renaming the instances themselves ; traceTc "rnd" (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos)) ; let (aux_binds, aux_sigs) = unzipBag bagBinds - aux_val_binds = ValBinds NoAnnSortKey (bagToList aux_binds) (bagToList aux_sigs) + aux_val_binds = ValBinds noExtField (map VbBind (bagToList aux_binds) ++ map VbSig (bagToList aux_sigs)) -- Importantly, we use rnLocalValBindsLHS, not rnTopBindsLHS, to rename -- auxiliary bindings as if they were defined locally. -- See Note [Auxiliary binders] in GHC.Tc.Deriv.Generate. - ; (bndrs, rn_aux_lhs) <- rnLocalValBindsLHS emptyMiniFixityEnv aux_val_binds + ; (bndrs, (binds', sigs')) <- rnLocalValBindsLHS emptyMiniFixityEnv aux_val_binds ; bindLocalNames bndrs $ - do { (rn_aux, dus_aux) <- rnLocalValBindsRHS (mkNameSet bndrs) rn_aux_lhs + do { (rn_aux, dus_aux) <- rnLocalValBindsRHS (mkNameSet bndrs) (makeRnValBinds noExtField binds' sigs') ; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos ; return (listToBag rn_inst_infos, rn_aux, dus_aux `plusDU` usesOnly (plusFNs fvs_insts)) } } ===================================== compiler/GHC/ThToHs.hs ===================================== @@ -1052,17 +1052,21 @@ cvtLocalDecs declDescr ds ([], []) -> return (EmptyLocalBinds noExtField) ([], _) -> do ds' <- cvtDecs ds - let (binds, prob_sigs) = partitionWith is_bind ds' - let (sigs, bads) = partitionWith is_sig prob_sigs + let (binds, bads) = partitionWith is_valbind ds' for_ (nonEmpty bads) $ \ bad_decls -> failWith (IllegalDeclaration declDescr $ IllegalDecls bad_decls) - return (HsValBinds noAnn (ValBinds NoAnnSortKey binds sigs)) + return (HsValBinds noAnn (ValBinds noExtField binds)) (ip_binds, []) -> do binds <- mapM (uncurry cvtImplicitParamBind) ip_binds return (HsIPBinds noAnn (IPBinds noExtField binds)) ((_:_), (_:_)) -> failWith ImplicitParamsWithOtherBinds +is_valbind :: LHsDecl (GhcPass p) -> Either (ValBind (GhcPass p) (GhcPass p)) (LHsDecl (GhcPass p)) +is_valbind (L l (Hs.ValD _ b)) = Left (VbBind (L l b)) +is_valbind (L l (Hs.SigD _ s)) = Left (VbSig (L l s)) +is_valbind d = Right d + cvtClause :: HsMatchContextPs -> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs)) cvtClause ctxt (Clause ps body wheres) = do { ps' <- cvtPats ps ===================================== compiler/Language/Haskell/Syntax/Binds.hs ===================================== @@ -31,6 +31,7 @@ import Language.Haskell.Syntax.ImpExp (NamespaceSpecifier) import Data.Bool import Data.Maybe +import Data.List {- ************************************************************************ @@ -96,7 +97,7 @@ data HsValBindsLR idL idR -- Recursive by default ValBinds (XValBinds idL idR) - (LHsBindsLR idL idR) [LSig idR] + [ValBind idL idR] -- | Value Bindings Out -- @@ -105,6 +106,10 @@ data HsValBindsLR idL idR | XValBindsLR !(XXValBindsLR idL idR) +data ValBind idL idR + = VbBind (LHsBindLR idL idR) + | VbSig (LSig idR) + -- --------------------------------------------------------------------- -- | Located Haskell Binding @@ -243,6 +248,26 @@ data PatSynBind idL idR } | XPatSynBind !(XXPatSynBind idL idR) + +val_binds :: [ValBind idL idR] -> [LHsBindLR idL idR] +val_binds binds = concatMap get_bind binds + where + get_bind (VbBind b) = [b] + get_bind (VbSig _) = [] + +val_sigs :: [ValBind idL idR] -> [LSig idR] +val_sigs binds = concatMap get_sig binds + where + get_sig (VbBind _) = [] + get_sig (VbSig s) = [s] + +val_binds_and_sigs :: [ValBind idL idR] -> ([LHsBindLR idL idR], [LSig idR]) +val_binds_and_sigs binds = go binds [] [] + where + go [] bs ss = (reverse bs, reverse ss) + go ((VbBind b):ds) bs ss = go ds (b:bs) ss + go ((VbSig s):ds) bs ss = go ds bs (s:ss) + {- ************************************************************************ * * ===================================== compiler/Language/Haskell/Syntax/Extension.hs ===================================== @@ -205,6 +205,7 @@ type family XXHsLocalBindsLR x x' -- HsValBindsLR type families type family XValBinds x x' type family XXValBindsLR x x' +type family XXValBinds x x' -- HsBindLR type families type family XFunBind x x' ===================================== ghc/GHCi/UI.hs ===================================== @@ -1633,7 +1633,7 @@ runStmt input step = do let la = L (noAnnSrcSpan loc) la' = L (noAnnSrcSpan loc) - in la (LetStmt noAnn (HsValBinds noAnn (ValBinds NoAnnSortKey [la' bind] []))) + in la (LetStmt noAnn (HsValBinds noAnn (ValBinds noExtField [VbBind $ la' bind]))) setDumpFilePrefix :: GHC.GhcMonad m => InteractiveContext -> m () -- #17500 setDumpFilePrefix ic = do ===================================== testsuite/tests/parser/should_compile/DumpSemis.stderr ===================================== @@ -1915,220 +1915,221 @@ (EpaComments [])) (ValBinds - (NoAnnSortKey) - [(L - (EpAnn - (EpaSpan { DumpSemis.hs:34:19-21 }) - [(AddSemiAnn - (EpTok - (EpaSpan { DumpSemis.hs:34:22 }))) - ,(AddSemiAnn - (EpTok - (EpaSpan { DumpSemis.hs:34:23 })))] - (EpaComments - [])) - (FunBind - (NoExtField) - (L - (EpAnn - (EpaSpan { DumpSemis.hs:34:19 }) - (NameAnnTrailing - []) - (EpaComments - [])) - (Unqual - {OccName: y})) - (MG - ((,) - (FromSource) - (AnnList - (Nothing) - (ListNone) - [] - (()) - [])) + (NoExtField) + [(VbBind + (L + (EpAnn + (EpaSpan { DumpSemis.hs:34:19-21 }) + [(AddSemiAnn + (EpTok + (EpaSpan { DumpSemis.hs:34:22 }))) + ,(AddSemiAnn + (EpTok + (EpaSpan { DumpSemis.hs:34:23 })))] + (EpaComments + [])) + (FunBind + (NoExtField) (L (EpAnn - (EpaSpan { DumpSemis.hs:34:19-21 }) - [] + (EpaSpan { DumpSemis.hs:34:19 }) + (NameAnnTrailing + []) (EpaComments [])) - [(L - (EpAnn - (EpaSpan { DumpSemis.hs:34:19-21 }) - [] - (EpaComments - [])) - (Match - (NoExtField) - (FunRhs - (L - (EpAnn - (EpaSpan { DumpSemis.hs:34:19 }) - (NameAnnTrailing - []) - (EpaComments - [])) - (Unqual - {OccName: y})) - (Prefix) - (NoSrcStrict) - (AnnFunRhs - (NoEpTok) - [] - [])) - (L - (EpaSpan { <no location info> }) - []) - (GRHSs + (Unqual + {OccName: y})) + (MG + ((,) + (FromSource) + (AnnList + (Nothing) + (ListNone) + [] + (()) + [])) + (L + (EpAnn + (EpaSpan { DumpSemis.hs:34:19-21 }) + [] + (EpaComments + [])) + [(L + (EpAnn + (EpaSpan { DumpSemis.hs:34:19-21 }) + [] (EpaComments - []) - (:| + [])) + (Match + (NoExtField) + (FunRhs (L (EpAnn - (EpaSpan { DumpSemis.hs:34:20-21 }) - (NoEpAnns) + (EpaSpan { DumpSemis.hs:34:19 }) + (NameAnnTrailing + []) (EpaComments [])) - (GRHS + (Unqual + {OccName: y})) + (Prefix) + (NoSrcStrict) + (AnnFunRhs + (NoEpTok) + [] + [])) + (L + (EpaSpan { <no location info> }) + []) + (GRHSs + (EpaComments + []) + (:| + (L (EpAnn (EpaSpan { DumpSemis.hs:34:20-21 }) - (GrhsAnn - (Nothing) - (Left - (EpTok - (EpaSpan { DumpSemis.hs:34:20 })))) + (NoEpAnns) (EpaComments [])) - [] - (L + (GRHS (EpAnn - (EpaSpan { DumpSemis.hs:34:21 }) - [] + (EpaSpan { DumpSemis.hs:34:20-21 }) + (GrhsAnn + (Nothing) + (Left + (EpTok + (EpaSpan { DumpSemis.hs:34:20 })))) (EpaComments [])) - (HsOverLit - (NoExtField) - (OverLit + [] + (L + (EpAnn + (EpaSpan { DumpSemis.hs:34:21 }) + [] + (EpaComments + [])) + (HsOverLit (NoExtField) - (HsIntegral - (IL - (SourceText 2) - (False) - (2)))))))) - []) - (EmptyLocalBinds - (NoExtField)))))])))) - ,(L - (EpAnn - (EpaSpan { DumpSemis.hs:34:24-26 }) - [(AddSemiAnn - (EpTok - (EpaSpan { DumpSemis.hs:34:27 }))) - ,(AddSemiAnn - (EpTok - (EpaSpan { DumpSemis.hs:34:28 }))) - ,(AddSemiAnn - (EpTok - (EpaSpan { DumpSemis.hs:34:29 }))) - ,(AddSemiAnn - (EpTok - (EpaSpan { DumpSemis.hs:34:30 })))] - (EpaComments - [])) - (FunBind - (NoExtField) - (L - (EpAnn - (EpaSpan { DumpSemis.hs:34:24 }) - (NameAnnTrailing - []) - (EpaComments - [])) - (Unqual - {OccName: z})) - (MG - ((,) - (FromSource) - (AnnList - (Nothing) - (ListNone) - [] - (()) - [])) + (OverLit + (NoExtField) + (HsIntegral + (IL + (SourceText 2) + (False) + (2)))))))) + []) + (EmptyLocalBinds + (NoExtField)))))]))))) + ,(VbBind + (L + (EpAnn + (EpaSpan { DumpSemis.hs:34:24-26 }) + [(AddSemiAnn + (EpTok + (EpaSpan { DumpSemis.hs:34:27 }))) + ,(AddSemiAnn + (EpTok + (EpaSpan { DumpSemis.hs:34:28 }))) + ,(AddSemiAnn + (EpTok + (EpaSpan { DumpSemis.hs:34:29 }))) + ,(AddSemiAnn + (EpTok + (EpaSpan { DumpSemis.hs:34:30 })))] + (EpaComments + [])) + (FunBind + (NoExtField) (L (EpAnn - (EpaSpan { DumpSemis.hs:34:24-26 }) - [] + (EpaSpan { DumpSemis.hs:34:24 }) + (NameAnnTrailing + []) (EpaComments [])) - [(L - (EpAnn - (EpaSpan { DumpSemis.hs:34:24-26 }) - [] - (EpaComments - [])) - (Match - (NoExtField) - (FunRhs - (L - (EpAnn - (EpaSpan { DumpSemis.hs:34:24 }) - (NameAnnTrailing - []) - (EpaComments - [])) - (Unqual - {OccName: z})) - (Prefix) - (NoSrcStrict) - (AnnFunRhs - (NoEpTok) - [] - [])) - (L - (EpaSpan { <no location info> }) - []) - (GRHSs + (Unqual + {OccName: z})) + (MG + ((,) + (FromSource) + (AnnList + (Nothing) + (ListNone) + [] + (()) + [])) + (L + (EpAnn + (EpaSpan { DumpSemis.hs:34:24-26 }) + [] + (EpaComments + [])) + [(L + (EpAnn + (EpaSpan { DumpSemis.hs:34:24-26 }) + [] (EpaComments - []) - (:| + [])) + (Match + (NoExtField) + (FunRhs (L (EpAnn - (EpaSpan { DumpSemis.hs:34:25-26 }) - (NoEpAnns) + (EpaSpan { DumpSemis.hs:34:24 }) + (NameAnnTrailing + []) (EpaComments [])) - (GRHS + (Unqual + {OccName: z})) + (Prefix) + (NoSrcStrict) + (AnnFunRhs + (NoEpTok) + [] + [])) + (L + (EpaSpan { <no location info> }) + []) + (GRHSs + (EpaComments + []) + (:| + (L (EpAnn (EpaSpan { DumpSemis.hs:34:25-26 }) - (GrhsAnn - (Nothing) - (Left - (EpTok - (EpaSpan { DumpSemis.hs:34:25 })))) + (NoEpAnns) (EpaComments [])) - [] - (L + (GRHS (EpAnn - (EpaSpan { DumpSemis.hs:34:26 }) - [] + (EpaSpan { DumpSemis.hs:34:25-26 }) + (GrhsAnn + (Nothing) + (Left + (EpTok + (EpaSpan { DumpSemis.hs:34:25 })))) (EpaComments [])) - (HsOverLit - (NoExtField) - (OverLit + [] + (L + (EpAnn + (EpaSpan { DumpSemis.hs:34:26 }) + [] + (EpaComments + [])) + (HsOverLit (NoExtField) - (HsIntegral - (IL - (SourceText 3) - (False) - (3)))))))) - []) - (EmptyLocalBinds - (NoExtField)))))]))))] - [])) + (OverLit + (NoExtField) + (HsIntegral + (IL + (SourceText 3) + (False) + (3)))))))) + []) + (EmptyLocalBinds + (NoExtField)))))])))))])) (L (EpAnn (EpaSpan { DumpSemis.hs:34:35 }) ===================================== testsuite/tests/printer/Test20297.stdout ===================================== @@ -166,8 +166,7 @@ (EpaComments [])) (ValBinds - (NoAnnSortKey) - [] + (NoExtField) [])))))]))))) ,(L (EpAnn @@ -295,142 +294,142 @@ "-- comment2") { Test20297.hs:10:3-7 }))])) (ValBinds - (NoAnnSortKey) - [(L - (EpAnn - (EpaSpan { Test20297.hs:11:9-26 }) - [] - (EpaComments - [])) - (FunBind - (NoExtField) - (L - (EpAnn - (EpaSpan { Test20297.hs:11:9-15 }) - (NameAnnTrailing - []) - (EpaComments - [])) - (Unqual - {OccName: doStuff})) - (MG - ((,) - (FromSource) - (AnnList - (Nothing) - (ListNone) - [] - (()) - [])) + (NoExtField) + [(VbBind + (L + (EpAnn + (EpaSpan { Test20297.hs:11:9-26 }) + [] + (EpaComments + [])) + (FunBind + (NoExtField) (L (EpAnn - (EpaSpan { Test20297.hs:11:9-26 }) - [] + (EpaSpan { Test20297.hs:11:9-15 }) + (NameAnnTrailing + []) (EpaComments [])) - [(L - (EpAnn - (EpaSpan { Test20297.hs:11:9-26 }) - [] - (EpaComments - [])) - (Match - (NoExtField) - (FunRhs - (L - (EpAnn - (EpaSpan { Test20297.hs:11:9-15 }) - (NameAnnTrailing - []) - (EpaComments - [])) - (Unqual - {OccName: doStuff})) - (Prefix) - (NoSrcStrict) - (AnnFunRhs - (NoEpTok) - [] - [])) - (L - (EpaSpan { <no location info> }) - []) - (GRHSs + (Unqual + {OccName: doStuff})) + (MG + ((,) + (FromSource) + (AnnList + (Nothing) + (ListNone) + [] + (()) + [])) + (L + (EpAnn + (EpaSpan { Test20297.hs:11:9-26 }) + [] + (EpaComments + [])) + [(L + (EpAnn + (EpaSpan { Test20297.hs:11:9-26 }) + [] (EpaComments - []) - (:| + [])) + (Match + (NoExtField) + (FunRhs (L (EpAnn - (EpaSpan { Test20297.hs:11:17-26 }) - (NoEpAnns) + (EpaSpan { Test20297.hs:11:9-15 }) + (NameAnnTrailing + []) (EpaComments [])) - (GRHS + (Unqual + {OccName: doStuff})) + (Prefix) + (NoSrcStrict) + (AnnFunRhs + (NoEpTok) + [] + [])) + (L + (EpaSpan { <no location info> }) + []) + (GRHSs + (EpaComments + []) + (:| + (L (EpAnn (EpaSpan { Test20297.hs:11:17-26 }) - (GrhsAnn - (Nothing) - (Left - (EpTok - (EpaSpan { Test20297.hs:11:17 })))) + (NoEpAnns) (EpaComments [])) - [] - (L + (GRHS (EpAnn - (EpaSpan { Test20297.hs:11:19-26 }) - [] + (EpaSpan { Test20297.hs:11:17-26 }) + (GrhsAnn + (Nothing) + (Left + (EpTok + (EpaSpan { Test20297.hs:11:17 })))) (EpaComments [])) - (HsDo - (AnnList - (Just - (EpaSpan { Test20297.hs:11:22-26 })) - (ListBraces - (NoEpTok) - (NoEpTok)) + [] + (L + (EpAnn + (EpaSpan { Test20297.hs:11:19-26 }) [] - (EpaSpan { Test20297.hs:11:19-20 }) - []) - (DoExpr - (Nothing)) - (L - (EpAnn - (EpaSpan { Test20297.hs:11:22-26 }) + (EpaComments + [])) + (HsDo + (AnnList + (Just + (EpaSpan { Test20297.hs:11:22-26 })) + (ListBraces + (NoEpTok) + (NoEpTok)) [] - (EpaComments - [])) - [(L - (EpAnn - (EpaSpan { Test20297.hs:11:22-26 }) - [] - (EpaComments - [])) - (BodyStmt - (NoExtField) - (L - (EpAnn - (EpaSpan { Test20297.hs:11:22-26 }) - [] - (EpaComments - [])) - (HsVar - (NoExtField) - (L - (EpAnn - (EpaSpan { Test20297.hs:11:22-26 }) - (NameAnnTrailing - []) - (EpaComments - [])) - (Unqual - {OccName: stuff})))) - (NoExtField) - (NoExtField)))]))))) - []) - (EmptyLocalBinds - (NoExtField)))))]))))] - [])))))])))))])) + (EpaSpan { Test20297.hs:11:19-20 }) + []) + (DoExpr + (Nothing)) + (L + (EpAnn + (EpaSpan { Test20297.hs:11:22-26 }) + [] + (EpaComments + [])) + [(L + (EpAnn + (EpaSpan { Test20297.hs:11:22-26 }) + [] + (EpaComments + [])) + (BodyStmt + (NoExtField) + (L + (EpAnn + (EpaSpan { Test20297.hs:11:22-26 }) + [] + (EpaComments + [])) + (HsVar + (NoExtField) + (L + (EpAnn + (EpaSpan { Test20297.hs:11:22-26 }) + (NameAnnTrailing + []) + (EpaComments + [])) + (Unqual + {OccName: stuff})))) + (NoExtField) + (NoExtField)))]))))) + []) + (EmptyLocalBinds + (NoExtField)))))])))))])))))])))))])) @@ -595,8 +594,7 @@ (EpaComments [])) (ValBinds - (NoAnnSortKey) - [] + (NoExtField) [])))))]))))) ,(L (EpAnn @@ -712,141 +710,141 @@ (EpaComments [])) (ValBinds - (NoAnnSortKey) - [(L - (EpAnn - (EpaSpan { Test20297.ppr.hs:9:7-24 }) - [] - (EpaComments - [])) - (FunBind - (NoExtField) - (L - (EpAnn - (EpaSpan { Test20297.ppr.hs:9:7-13 }) - (NameAnnTrailing - []) - (EpaComments - [])) - (Unqual - {OccName: doStuff})) - (MG - ((,) - (FromSource) - (AnnList - (Nothing) - (ListNone) - [] - (()) - [])) + (NoExtField) + [(VbBind + (L + (EpAnn + (EpaSpan { Test20297.ppr.hs:9:7-24 }) + [] + (EpaComments + [])) + (FunBind + (NoExtField) (L (EpAnn - (EpaSpan { Test20297.ppr.hs:9:7-24 }) - [] + (EpaSpan { Test20297.ppr.hs:9:7-13 }) + (NameAnnTrailing + []) (EpaComments [])) - [(L - (EpAnn - (EpaSpan { Test20297.ppr.hs:9:7-24 }) - [] - (EpaComments - [])) - (Match - (NoExtField) - (FunRhs - (L - (EpAnn - (EpaSpan { Test20297.ppr.hs:9:7-13 }) - (NameAnnTrailing - []) - (EpaComments - [])) - (Unqual - {OccName: doStuff})) - (Prefix) - (NoSrcStrict) - (AnnFunRhs - (NoEpTok) - [] - [])) - (L - (EpaSpan { <no location info> }) - []) - (GRHSs + (Unqual + {OccName: doStuff})) + (MG + ((,) + (FromSource) + (AnnList + (Nothing) + (ListNone) + [] + (()) + [])) + (L + (EpAnn + (EpaSpan { Test20297.ppr.hs:9:7-24 }) + [] + (EpaComments + [])) + [(L + (EpAnn + (EpaSpan { Test20297.ppr.hs:9:7-24 }) + [] (EpaComments - []) - (:| + [])) + (Match + (NoExtField) + (FunRhs (L (EpAnn - (EpaSpan { Test20297.ppr.hs:9:15-24 }) - (NoEpAnns) + (EpaSpan { Test20297.ppr.hs:9:7-13 }) + (NameAnnTrailing + []) (EpaComments [])) - (GRHS + (Unqual + {OccName: doStuff})) + (Prefix) + (NoSrcStrict) + (AnnFunRhs + (NoEpTok) + [] + [])) + (L + (EpaSpan { <no location info> }) + []) + (GRHSs + (EpaComments + []) + (:| + (L (EpAnn (EpaSpan { Test20297.ppr.hs:9:15-24 }) - (GrhsAnn - (Nothing) - (Left - (EpTok - (EpaSpan { Test20297.ppr.hs:9:15 })))) + (NoEpAnns) (EpaComments [])) - [] - (L + (GRHS (EpAnn - (EpaSpan { Test20297.ppr.hs:9:17-24 }) - [] + (EpaSpan { Test20297.ppr.hs:9:15-24 }) + (GrhsAnn + (Nothing) + (Left + (EpTok + (EpaSpan { Test20297.ppr.hs:9:15 })))) (EpaComments [])) - (HsDo - (AnnList - (Just - (EpaSpan { Test20297.ppr.hs:9:20-24 })) - (ListBraces - (NoEpTok) - (NoEpTok)) + [] + (L + (EpAnn + (EpaSpan { Test20297.ppr.hs:9:17-24 }) [] - (EpaSpan { Test20297.ppr.hs:9:17-18 }) - []) - (DoExpr - (Nothing)) - (L - (EpAnn - (EpaSpan { Test20297.ppr.hs:9:20-24 }) + (EpaComments + [])) + (HsDo + (AnnList + (Just + (EpaSpan { Test20297.ppr.hs:9:20-24 })) + (ListBraces + (NoEpTok) + (NoEpTok)) [] - (EpaComments - [])) - [(L - (EpAnn - (EpaSpan { Test20297.ppr.hs:9:20-24 }) - [] - (EpaComments - [])) - (BodyStmt - (NoExtField) - (L - (EpAnn - (EpaSpan { Test20297.ppr.hs:9:20-24 }) - [] - (EpaComments - [])) - (HsVar - (NoExtField) - (L - (EpAnn - (EpaSpan { Test20297.ppr.hs:9:20-24 }) - (NameAnnTrailing - []) - (EpaComments - [])) - (Unqual - {OccName: stuff})))) - (NoExtField) - (NoExtField)))]))))) - []) - (EmptyLocalBinds - (NoExtField)))))]))))] - [])))))])))))])) + (EpaSpan { Test20297.ppr.hs:9:17-18 }) + []) + (DoExpr + (Nothing)) + (L + (EpAnn + (EpaSpan { Test20297.ppr.hs:9:20-24 }) + [] + (EpaComments + [])) + [(L + (EpAnn + (EpaSpan { Test20297.ppr.hs:9:20-24 }) + [] + (EpaComments + [])) + (BodyStmt + (NoExtField) + (L + (EpAnn + (EpaSpan { Test20297.ppr.hs:9:20-24 }) + [] + (EpaComments + [])) + (HsVar + (NoExtField) + (L + (EpAnn + (EpaSpan { Test20297.ppr.hs:9:20-24 }) + (NameAnnTrailing + []) + (EpaComments + [])) + (Unqual + {OccName: stuff})))) + (NoExtField) + (NoExtField)))]))))) + []) + (EmptyLocalBinds + (NoExtField)))))])))))])))))])))))])) ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -2523,15 +2523,18 @@ instance ExactPrint (HsValBindsLR GhcPs GhcPs) where getAnnotationEntry _ = NoEntryVal setAnnotationAnchor a _ _ _ = a - exact (ValBinds sortKey binds sigs) = do - decls <- setLayoutBoth $ mapM markAnnotated $ hsDeclsValBinds (ValBinds sortKey binds sigs) - let - binds' = concatMap decl2Bind decls - sigs' = concatMap decl2Sig decls - sortKey' = captureOrderBinds decls - return (ValBinds sortKey' binds' sigs') + exact (ValBinds sortKey bs) = do + bs' <- mapM markAnnotated bs + return (ValBinds sortKey bs') exact (XValBindsLR _) = panic "XValBindsLR" +instance ExactPrint (ValBind GhcPs GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (VbBind b) = VbBind <$> markAnnotated b + exact (VbSig s) = VbSig <$> markAnnotated s + undynamic :: Typeable a => [Dynamic] -> [a] undynamic ds = mapMaybe fromDynamic ds ===================================== utils/check-exact/Main.hs ===================================== @@ -11,9 +11,11 @@ import Data.Data import Data.List (intercalate) +-- import Language.Haskell.Syntax.Binds import GHC hiding (moduleName) import GHC.Driver.Ppr import GHC.Hs.Dump +import GHC.Parser.PostProcess ( wrapValBind ) import GHC.Types.Name.Occurrence import GHC.Types.Name.Reader import GHC.Utils.Error @@ -447,15 +449,15 @@ changeLetIn1 _libdir parsed replace :: HsExpr GhcPs -> HsExpr GhcPs replace (HsLet (tkLet, _) localDecls expr) = - let (HsValBinds x (ValBinds xv decls sigs)) = localDecls - [l2,_l1] = map wrapDecl decls - decls' = concatMap decl2Bind [l2] + let (HsValBinds x (ValBinds xv bs)) = localDecls + [l2,_l1] = bs + decls' = [l2] (L _ e) = expr a = EpAnn (EpaDelta noSrcSpan (SameLine 1) []) noAnn emptyComments expr' = L a e tkIn' = EpTok (EpaDelta noSrcSpan (DifferentLine 1 0) []) in (HsLet (tkLet, tkIn') - (HsValBinds x (ValBinds xv decls' sigs)) expr') + (HsValBinds x (ValBinds xv decls')) expr') replace x = x @@ -508,27 +510,24 @@ changeAddDecl3 libdir top = do -- | Add a local declaration with signature to LocalDecl changeLocalDecls :: Changer changeLocalDecls libdir (L l p) = do - Right s@(L ls (SigD _ sig)) <- withDynFlags libdir (\df -> parseDecl df "sig" "nn :: Int") - Right d@(L ld (ValD _ decl)) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") + Right (L ls (SigD _ sig)) <- withDynFlags libdir (\df -> parseDecl df "sig" "nn :: Int") + Right (L ld (ValD _ decl)) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") let decl' = setEntryDP (L ld decl) (DifferentLine 1 0) let sig' = setEntryDP (L ls sig) (SameLine 0) let (p',_,_w) = runTransform doAddLocal doAddLocal = everywhereM (mkM replaceLocalBinds) p replaceLocalBinds :: LMatch GhcPs (LHsExpr GhcPs) -> Transform (LMatch GhcPs (LHsExpr GhcPs)) - replaceLocalBinds (L lm (Match an mln pats (GRHSs _ rhs (HsValBinds van (ValBinds _ binds sigs))))) = do - let oldDecls = sortLocatedA $ map wrapDecl binds ++ map wrapSig sigs - let decls = s:d:oldDecls + replaceLocalBinds (L lm (Match an mln pats (GRHSs _ rhs (HsValBinds van (ValBinds _ bs))))) = do + let (oldDecls) = map unWrapValBind bs + -- let decls = s:d:oldDecls let oldDecls' = captureLineSpacing oldDecls - let oldBinds = concatMap decl2Bind oldDecls' - (os:oldSigs) = concatMap decl2Sig oldDecls' - os' = setEntryDP os (DifferentLine 2 0) - let sortKey = captureOrderBinds decls + let (VbSig o:oldBinds) = map wrapValBind oldDecls' + o' = setEntryDP o (DifferentLine 2 0) let (EpAnn anc (AnnList (Just _) a b c dd) cs) = van let van' = (EpAnn anc (AnnList (Just (EpaDelta noSrcSpan (DifferentLine 1 4) [])) a b c dd) cs) let binds' = (HsValBinds van' - (ValBinds sortKey (decl':oldBinds) - (sig':os':oldSigs))) + (ValBinds noExtField (VbSig sig':VbBind decl':VbSig o':oldBinds))) return (L lm (Match an mln pats (GRHSs emptyComments rhs binds'))) `debug` ("oldDecls=" ++ showAst oldDecls) replaceLocalBinds x = return x @@ -540,8 +539,8 @@ changeLocalDecls libdir (L l p) = do -- prior local decl. So it adds a "where" annotation. changeLocalDecls2 :: Changer changeLocalDecls2 libdir (L l p) = do - Right d@(L ld (ValD _ decl)) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") - Right s@(L ls (SigD _ sig)) <- withDynFlags libdir (\df -> parseDecl df "sig" "nn :: Int") + Right (L ld (ValD _ decl)) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") + Right (L ls (SigD _ sig)) <- withDynFlags libdir (\df -> parseDecl df "sig" "nn :: Int") let decl' = setEntryDP (L ld decl) (DifferentLine 1 0) let sig' = setEntryDP (L ls sig) (SameLine 2) let (p',_,_w) = runTransform doAddLocal @@ -557,10 +556,8 @@ changeLocalDecls2 libdir (L l p) = do (EpTok (EpaDelta noSrcSpan (SameLine 0) [])) []) emptyComments - let decls = [s,d] - let sortKey = captureOrderBinds decls - let binds = (HsValBinds an (ValBinds sortKey [decl'] - [sig'])) + let decls = [VbSig sig', VbBind decl'] + let binds = (HsValBinds an (ValBinds noExtField decls)) return (L lm (Match ma mln pats (GRHSs emptyComments rhs binds))) replaceLocalBinds x = return x return (L l p') ===================================== utils/check-exact/Transform.hs ===================================== @@ -68,7 +68,6 @@ module Transform , addModuleCommentOrigDeltas -- ** Managing lists, pure functions - , captureOrderBinds , captureLineSpacing , captureMatchLineSpacing , captureTypeSigSpacing @@ -92,6 +91,7 @@ import Control.Monad.RWS import qualified Control.Monad.Fail as Fail import GHC hiding (parseModule, parsedSource) +import GHC.Parser.PostProcess ( wrapValBind ) import GHC.Data.FastString import GHC.Types.SrcLoc @@ -507,7 +507,7 @@ pushTrailingComments w cs lb@(HsValBinds an _) = (True, HsValBinds an' vb) (L la d:ds) -> (an, L (addCommentsToEpAnn la cs) d:ds) vb = case replaceDeclsValbinds w lb (reverse decls') of (HsValBinds _ vb') -> vb' - _ -> ValBinds NoAnnSortKey [] [] + _ -> ValBinds noExtField [] balanceCommentsListA :: [LocatedA a] -> [LocatedA a] @@ -1084,18 +1084,11 @@ replaceDeclsValbinds w b@(HsValBinds a _) new = let oldSpan = spanHsLocaLBinds b an = oldWhereAnnotation a w (realSrcSpan oldSpan) - decs = concatMap decl2Bind new - sigs = concatMap decl2Sig new - sortKey = captureOrderBinds new - in (HsValBinds an (ValBinds sortKey decs sigs)) + in (HsValBinds an (ValBinds noExtField (map wrapValBind new))) replaceDeclsValbinds _ (HsIPBinds {}) _new = error "undefined replaceDecls HsIPBinds" replaceDeclsValbinds w (EmptyLocalBinds _) new - = let - an = newWhereAnnotation w - decs = concatMap decl2Bind new - sigs = concatMap decl2Sig new - sortKey = captureOrderBinds new - in (HsValBinds an (ValBinds sortKey decs sigs)) + = let an = newWhereAnnotation w + in (HsValBinds an (ValBinds noExtField (map wrapValBind new))) oldWhereAnnotation :: EpAnn (AnnList (EpToken "where")) -> WithWhere -> RealSrcSpan -> (EpAnn (AnnList (EpToken "where"))) ===================================== utils/check-exact/Utils.hs ===================================== @@ -65,15 +65,6 @@ warn c _ = c -- --------------------------------------------------------------------- -captureOrderBinds :: [LHsDecl GhcPs] -> AnnSortKey BindTag -captureOrderBinds ls = AnnSortKey $ map go ls - where - go (L _ (ValD _ _)) = BindTag - go (L _ (SigD _ _)) = SigDTag - go d = error $ "captureOrderBinds:" ++ showGhc d - --- --------------------------------------------------------------------- - notDocDecl :: LHsDecl GhcPs -> Bool notDocDecl (L _ DocD{}) = False notDocDecl _ = True @@ -655,45 +646,27 @@ partitionWithSortKey = go -- --------------------------------------------------------------------- -orderedDeclsBinds - :: AnnSortKey BindTag - -> [LHsDecl GhcPs] -> [LHsDecl GhcPs] - -> [LHsDecl GhcPs] -orderedDeclsBinds sortKey binds sigs = - case sortKey of - NoAnnSortKey -> - sortBy (\a b -> compare (realSrcSpan $ getLocA a) - (realSrcSpan $ getLocA b)) (binds ++ sigs) - AnnSortKey keys -> - let - go [] _ _ = [] - go (BindTag:ks) (b:bs) ss = b : go ks bs ss - go (SigDTag:ks) bs (s:ss) = s : go ks bs ss - go (_:ks) bs ss = go ks bs ss - in - go keys binds sigs - hsDeclsLocalBinds :: HsLocalBinds GhcPs -> [LHsDecl GhcPs] hsDeclsLocalBinds lb = case lb of - HsValBinds _ (ValBinds sortKey bs sigs) -> - let - bds = map wrapDecl bs - sds = map wrapSig sigs - in - orderedDeclsBinds sortKey bds sds + HsValBinds _ (ValBinds _ bs) -> map unWrapValBind bs HsValBinds _ (XValBindsLR _) -> error $ "hsDecls.XValBindsLR not valid" HsIPBinds {} -> [] EmptyLocalBinds {} -> [] hsDeclsValBinds :: (HsValBindsLR GhcPs GhcPs) -> [LHsDecl GhcPs] -hsDeclsValBinds (ValBinds sortKey bs sigs) = - let - bds = map wrapDecl bs - sds = map wrapSig sigs - in - orderedDeclsBinds sortKey bds sds +hsDeclsValBinds (ValBinds _ bs) = map unWrapValBind bs hsDeclsValBinds XValBindsLR{} = error "hsDeclsValBinds" +unWrapValBind :: ValBind (GhcPass p) (GhcPass p) -> LHsDecl (GhcPass p) +unWrapValBind (VbBind (L l b)) = L l (ValD noExtField b) +unWrapValBind (VbSig (L l s)) = L l (SigD noExtField s) + +sig2Decl :: LSig (GhcPass p) -> LHsDecl (GhcPass p) +sig2Decl (L l s) = L l (SigD noExtField s) + +bind2Decl :: LHsBind (GhcPass p) -> LHsDecl (GhcPass p) +bind2Decl (L l b) = L l (ValD noExtField b) + -- --------------------------------------------------------------------- -- |Pure function to convert a 'LHsDecl' to a 'LHsBind'. This does View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cd00cfa6f8de2b7af756cd12f5f2cb76... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cd00cfa6f8de2b7af756cd12f5f2cb76... You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help