diff options
| author | romes <rodrigo.m.mesquita@gmail.com> | 2022-05-22 21:05:32 +0200 |
|---|---|---|
| committer | romes <rodrigo.m.mesquita@gmail.com> | 2022-05-26 16:27:57 +0000 |
| commit | 44bb71115bcf1edaee82fc75cbe07a3e242e9476 (patch) | |
| tree | c850a97d6279f5a94b9ffab97bca24df9df5e142 | |
| parent | d0e4355af8c936a3ba831ecf6afa62b06475069f (diff) | |
| download | haskell-wip/romes/ttg-matchgroup-origin.tar.gz | |
TTG: Move MatchGroup Origin field and MatchGroupTc to GHC.Hswip/romes/ttg-matchgroup-origin
28 files changed, 130 insertions, 151 deletions
diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs index 76699dc4f3..6f57eb5304 100644 --- a/compiler/GHC/Hs/Expr.hs +++ b/compiler/GHC/Hs/Expr.hs @@ -1292,10 +1292,17 @@ instance (OutputableBndrId p) => Outputable (HsCmdTop (GhcPass p)) where ************************************************************************ -} -type instance XMG GhcPs b = NoExtField -type instance XMG GhcRn b = NoExtField +type instance XMG GhcPs b = Origin +type instance XMG GhcRn b = Origin type instance XMG GhcTc b = MatchGroupTc +data MatchGroupTc + = MatchGroupTc + { mg_arg_tys :: [Scaled Type] -- Types of the arguments, t1..tn + , mg_res_ty :: Type -- Type of the result, tr + , mg_origin :: Origin -- Origin (Generated vs FromSource) + } deriving Data + type instance XXMatchGroup (GhcPass _) b = DataConCantHappen type instance XCMatch (GhcPass _) b = EpAnn [AddEpAnn] diff --git a/compiler/GHC/Hs/Syn/Type.hs b/compiler/GHC/Hs/Syn/Type.hs index b93d87a9b3..30009ef400 100644 --- a/compiler/GHC/Hs/Syn/Type.hs +++ b/compiler/GHC/Hs/Syn/Type.hs @@ -192,7 +192,7 @@ lhsCmdTopType :: LHsCmdTop GhcTc -> Type lhsCmdTopType (L _ (HsCmdTop (CmdTopTc _ ret_ty _) _)) = ret_ty matchGroupTcType :: MatchGroupTc -> Type -matchGroupTcType (MatchGroupTc args res) = mkVisFunTys args res +matchGroupTcType (MatchGroupTc args res _) = mkVisFunTys args res syntaxExprType :: SyntaxExpr GhcTc -> Type syntaxExprType (SyntaxExprTc e _ _) = hsExprType e diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs index e5bcd5959f..9d4e733375 100644 --- a/compiler/GHC/Hs/Utils.hs +++ b/compiler/GHC/Hs/Utils.hs @@ -200,7 +200,7 @@ unguardedRHS :: Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) unguardedRHS an loc rhs = [L (noAnnSrcSpan loc) (GRHS an [] rhs)] type AnnoBody p body - = ( XMG (GhcPass p) (LocatedA (body (GhcPass p))) ~ NoExtField + = ( XMG (GhcPass p) (LocatedA (body (GhcPass p))) ~ Origin , Anno [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))] ~ SrcSpanAnnL , Anno (Match (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpanAnnA ) @@ -209,9 +209,8 @@ mkMatchGroup :: AnnoBody p body => Origin -> LocatedL [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))] -> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p))) -mkMatchGroup origin matches = MG { mg_ext = noExtField - , mg_alts = matches - , mg_origin = origin } +mkMatchGroup origin matches = MG { mg_ext = origin + , mg_alts = matches } mkLamCaseMatchGroup :: AnnoBody p body => Origin @@ -257,7 +256,7 @@ mkHsAppType e t = addCLocAA t_body e (HsAppType noExtField e paren_wct) mkHsAppTypes :: LHsExpr GhcRn -> [LHsWcType GhcRn] -> LHsExpr GhcRn mkHsAppTypes = foldl' mkHsAppType -mkHsLam :: (IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExtField) +mkHsLam :: (IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ Origin) => [LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) @@ -880,7 +879,7 @@ mkPatSynBind name details lpat dir anns = PatSynBind noExtField psb -- |If any of the matches in the 'FunBind' are infix, the 'FunBind' is -- considered infix. isInfixFunBind :: forall id1 id2. UnXRec id2 => HsBindLR id1 id2 -> Bool -isInfixFunBind (FunBind { fun_matches = MG _ matches _ }) +isInfixFunBind (FunBind { fun_matches = MG _ matches }) = any (isInfixMatch . unXRec @id2) (unXRec @id2 matches) isInfixFunBind _ = False diff --git a/compiler/GHC/HsToCore/Arrows.hs b/compiler/GHC/HsToCore/Arrows.hs index 253bd1b60d..e7dbebb5f9 100644 --- a/compiler/GHC/HsToCore/Arrows.hs +++ b/compiler/GHC/HsToCore/Arrows.hs @@ -501,7 +501,7 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdCase _ exp match) env_ids = do stack_id <- newSysLocalDs Many stack_ty (match', core_choices) <- dsCases ids local_vars stack_id stack_ty res_ty match - let MG{ mg_ext = MatchGroupTc _ sum_ty } = match' + let MG{ mg_ext = MatchGroupTc _ sum_ty _ } = match' in_ty = envStackType env_ids stack_ty core_body <- dsExpr (HsCase noExtField exp match') @@ -544,7 +544,7 @@ dsCmd ids local_vars stack_ty res_ty (match', core_choices) <- dsCases ids local_vars' stack_id stack_ty' res_ty match - let MG{ mg_ext = MatchGroupTc _ sum_ty } = match' + let MG{ mg_ext = MatchGroupTc _ sum_ty _ } = match' in_ty = envStackType env_ids stack_ty' discrims = map nlHsVar arg_ids (discrim_vars, matching_code) @@ -756,8 +756,8 @@ dsCases :: DsCmdEnv -- arrow combinators CoreExpr) -- desugared choices dsCases ids local_vars stack_id stack_ty res_ty (MG { mg_alts = L l matches - , mg_ext = MatchGroupTc arg_tys _ - , mg_origin = origin }) = do + , mg_ext = MatchGroupTc arg_tys _ origin + }) = do -- Extract and desugar the leaf commands in the case, building tuple -- expressions that will (after tagging) replace these leaves @@ -805,8 +805,8 @@ dsCases ids local_vars stack_id stack_ty res_ty Nothing -> ([], void_ty,) . do_arr ids void_ty res_ty <$> dsExpr (HsLamCase EpAnnNotUsed LamCase (MG { mg_alts = noLocA [] - , mg_ext = MatchGroupTc [Scaled Many void_ty] res_ty - , mg_origin = Generated })) + , mg_ext = MatchGroupTc [Scaled Many void_ty] res_ty Generated + })) -- Replace the commands in the case with these tagged tuples, -- yielding a HsExpr Id we can feed to dsExpr. @@ -816,8 +816,8 @@ dsCases ids local_vars stack_id stack_ty res_ty -- Note that we replace the MatchGroup result type by sum_ty, -- which is the type of matches' return (MG { mg_alts = L l matches' - , mg_ext = MatchGroupTc arg_tys sum_ty - , mg_origin = origin }, + , mg_ext = MatchGroupTc arg_tys sum_ty origin + }, core_choices) {- diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs index 9d87eec5e0..bc287f433c 100644 --- a/compiler/GHC/HsToCore/Expr.hs +++ b/compiler/GHC/HsToCore/Expr.hs @@ -732,8 +732,8 @@ dsDo ctx stmts (MG { mg_alts = noLocA [mkSimpleMatch LambdaExpr [mfix_pat] body] - , mg_ext = MatchGroupTc [unrestricted tup_ty] body_ty - , mg_origin = Generated }) + , mg_ext = MatchGroupTc [unrestricted tup_ty] body_ty Generated + }) mfix_pat = noLocA $ LazyPat noExtField $ mkBigLHsPatTupId rec_tup_pats body = noLocA $ HsDo body_ty ctx (noLocA (rec_stmts ++ [ret_stmt])) diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs index 5c45d9b705..1780c30755 100644 --- a/compiler/GHC/HsToCore/Match.hs +++ b/compiler/GHC/HsToCore/Match.hs @@ -762,8 +762,8 @@ JJQC 30-Nov-1997 -} matchWrapper ctxt scrs (MG { mg_alts = L _ matches - , mg_ext = MatchGroupTc arg_tys rhs_ty - , mg_origin = origin }) + , mg_ext = MatchGroupTc arg_tys rhs_ty origin + }) = do { dflags <- getDynFlags ; locn <- getSrcSpanDs diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs index d3b7978856..b6604a9d76 100644 --- a/compiler/GHC/Iface/Ext/Ast.hs +++ b/compiler/GHC/Iface/Ext/Ast.hs @@ -879,11 +879,14 @@ instance ( HiePass p , ToHie (LocatedA (body (GhcPass p))) ) => ToHie (MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))) where toHie mg = case mg of - MG{ mg_alts = (L span alts) , mg_origin = origin} -> + MG{ mg_alts = (L span alts) } -> local (setOrigin origin) $ concatM [ locOnly (locA span) , toHie alts ] + where origin = case hiePass @p of + HieRn -> mg_ext mg + HieTc -> mg_origin $ mg_ext mg setOrigin :: Origin -> NodeOrigin -> NodeOrigin setOrigin FromSource _ = SourceInfo diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs index 0239bf759b..70489c0048 100644 --- a/compiler/GHC/Rename/Bind.hs +++ b/compiler/GHC/Rename/Bind.hs @@ -1216,7 +1216,7 @@ rnMatchGroup :: (Outputable (body GhcPs), AnnoBody body) => HsMatchContext GhcRn -> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars)) -> MatchGroup GhcPs (LocatedA (body GhcPs)) -> RnM (MatchGroup GhcRn (LocatedA (body GhcRn)), FreeVars) -rnMatchGroup ctxt rnBody (MG { mg_alts = L lm ms, mg_origin = origin }) +rnMatchGroup ctxt rnBody (MG { mg_alts = L lm ms, mg_ext = origin }) -- see Note [Empty MatchGroups] = do { whenM ((null ms &&) <$> mustn't_be_empty) (addErr (emptyCaseErr ctxt)) ; (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms diff --git a/compiler/GHC/Tc/Gen/Arrow.hs b/compiler/GHC/Tc/Gen/Arrow.hs index a4eff74ea4..6e4166d36d 100644 --- a/compiler/GHC/Tc/Gen/Arrow.hs +++ b/compiler/GHC/Tc/Gen/Arrow.hs @@ -339,7 +339,7 @@ tcCmdMatchLambda :: CmdEnv -> TcM (HsWrapper, MatchGroup GhcTc (LHsCmd GhcTc)) tcCmdMatchLambda env ctxt - mg@MG { mg_alts = L l matches } + mg@MG { mg_alts = L l matches, mg_ext = origin } (cmd_stk, res_ty) = do { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs n_pats cmd_stk @@ -349,7 +349,7 @@ tcCmdMatchLambda env ; let arg_tys' = map unrestricted arg_tys mg' = mg { mg_alts = L l matches' - , mg_ext = MatchGroupTc arg_tys' res_ty } + , mg_ext = MatchGroupTc arg_tys' res_ty origin } ; return (mkWpCastN co, mg') } where diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs index 9c838785ac..9646cfeace 100644 --- a/compiler/GHC/Tc/Gen/Match.hs +++ b/compiler/GHC/Tc/Gen/Match.hs @@ -223,7 +223,7 @@ tcMatches :: (AnnoBody body ) => TcMatchCtxt body -> TcM (MatchGroup GhcTc (LocatedA (body GhcTc))) tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = L l matches - , mg_origin = origin }) + , mg_ext = origin }) | null matches -- Deal with case e of {} -- Since there are no branches, no one else will fill in rhs_ty -- when in inference mode, so we must do it ourselves, @@ -232,8 +232,8 @@ tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = L l matches ; pat_tys <- mapM scaledExpTypeToType pat_tys ; rhs_ty <- expTypeToType rhs_ty ; return (MG { mg_alts = L l [] - , mg_ext = MatchGroupTc pat_tys rhs_ty - , mg_origin = origin }) } + , mg_ext = MatchGroupTc pat_tys rhs_ty origin + }) } | otherwise = do { umatches <- mapM (tcCollectingUsage . tcMatch ctxt pat_tys rhs_ty) matches @@ -242,8 +242,8 @@ tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = L l matches ; pat_tys <- mapM readScaledExpType pat_tys ; rhs_ty <- readExpType rhs_ty ; return (MG { mg_alts = L l matches' - , mg_ext = MatchGroupTc pat_tys rhs_ty - , mg_origin = origin }) } + , mg_ext = MatchGroupTc pat_tys rhs_ty origin + }) } ------------- tcMatch :: (AnnoBody body) => TcMatchCtxt body diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs index a306a3967e..7a3ca9e42a 100644 --- a/compiler/GHC/Tc/TyCl/PatSyn.hs +++ b/compiler/GHC/Tc/TyCl/PatSyn.hs @@ -830,15 +830,13 @@ tcPatSynMatcher (L loc ps_name) lpat prag_fn L (getLoc lpat) $ HsCase noExtField (nlHsVar scrutinee) $ MG{ mg_alts = L (l2l $ getLoc lpat) cases - , mg_ext = MatchGroupTc [unrestricted pat_ty] res_ty - , mg_origin = Generated + , mg_ext = MatchGroupTc [unrestricted pat_ty] res_ty Generated } body' = noLocA $ HsLam noExtField $ MG{ mg_alts = noLocA [mkSimpleMatch LambdaExpr args body] - , mg_ext = MatchGroupTc (map unrestricted [pat_ty, cont_ty, fail_ty]) res_ty - , mg_origin = Generated + , mg_ext = MatchGroupTc (map unrestricted [pat_ty, cont_ty, fail_ty]) res_ty Generated } match = mkMatch (mkPrefixFunRhs (L loc patsyn_id)) [] (mkHsLams (rr_tv:res_tv:univ_tvs) @@ -846,8 +844,7 @@ tcPatSynMatcher (L loc ps_name) lpat prag_fn (EmptyLocalBinds noExtField) mg :: MatchGroup GhcTc (LHsExpr GhcTc) mg = MG{ mg_alts = L (l2l $ getLoc match) [match] - , mg_ext = MatchGroupTc [] res_ty - , mg_origin = Generated + , mg_ext = MatchGroupTc [] res_ty Generated } matcher_arity = length req_theta + 3 -- See Note [Pragmas for pattern synonyms] diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs index 6fa47f8b64..b5fbea49ed 100644 --- a/compiler/GHC/Tc/Utils/Zonk.hs +++ b/compiler/GHC/Tc/Utils/Zonk.hs @@ -674,14 +674,14 @@ zonkMatchGroup :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcAnn NoEpAnns -> MatchGroup GhcTc (LocatedA (body GhcTc)) -> TcM (MatchGroup GhcTc (LocatedA (body GhcTc))) zonkMatchGroup env zBody (MG { mg_alts = L l ms - , mg_ext = MatchGroupTc arg_tys res_ty - , mg_origin = origin }) + , mg_ext = MatchGroupTc arg_tys res_ty origin + }) = do { ms' <- mapM (zonkMatch env zBody) ms ; arg_tys' <- zonkScaledTcTypesToTypesX env arg_tys ; res_ty' <- zonkTcTypeToTypeX env res_ty ; return (MG { mg_alts = L l ms' - , mg_ext = MatchGroupTc arg_tys' res_ty' - , mg_origin = origin }) } + , mg_ext = MatchGroupTc arg_tys' res_ty' origin + }) } zonkMatch :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcAnn NoEpAnns => ZonkEnv diff --git a/compiler/Language/Haskell/Syntax/Expr.hs b/compiler/Language/Haskell/Syntax/Expr.hs index 69cb0b6dd0..6491f525fa 100644 --- a/compiler/Language/Haskell/Syntax/Expr.hs +++ b/compiler/Language/Haskell/Syntax/Expr.hs @@ -43,7 +43,6 @@ import GHC.Unit.Module (ModuleName) import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Data.FastString -import GHC.Core.Type -- libraries: import Data.Data hiding (Fixity(..)) @@ -1039,20 +1038,13 @@ patterns in each equation. -} data MatchGroup p body - = MG { mg_ext :: XMG p body -- Post-typechecker, types of args and result - , mg_alts :: XRec p [LMatch p body] -- The alternatives - , mg_origin :: Origin } + = MG { mg_ext :: XMG p body -- Post-typechecker, types of args and result, and origin + , mg_alts :: XRec p [LMatch p body] } -- The alternatives -- The type is the type of the entire group -- t1 -> ... -> tn -> tr -- where there are n patterns | XMatchGroup !(XXMatchGroup p body) -data MatchGroupTc - = MatchGroupTc - { mg_arg_tys :: [Scaled Type] -- Types of the arguments, t1..tn - , mg_res_ty :: Type -- Type of the result, tr - } deriving Data - -- | Located Match type LMatch id body = XRec id (Match id body) -- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi' when in a diff --git a/ghc/GHCi/UI/Info.hs b/ghc/GHCi/UI/Info.hs index 7fb13316e9..39cf7d8860 100644 --- a/ghc/GHCi/UI/Info.hs +++ b/ghc/GHCi/UI/Info.hs @@ -330,7 +330,7 @@ processAllTypeCheckedModule tcm -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LHsBind's getTypeLHsBind :: LHsBind GhcTc -> Maybe (Maybe Id,SrcSpan,Type) - getTypeLHsBind (L _spn FunBind{fun_id = pid,fun_matches = MG _ _ _}) + getTypeLHsBind (L _spn FunBind{fun_id = pid,fun_matches = MG _ _}) = Just (Just (unLoc pid), getLocA pid,varType (unLoc pid)) getTypeLHsBind _ = Nothing diff --git a/testsuite/tests/ghc-api/T6145.hs b/testsuite/tests/ghc-api/T6145.hs index f9dbfff86c..2b55c1267d 100644 --- a/testsuite/tests/ghc-api/T6145.hs +++ b/testsuite/tests/ghc-api/T6145.hs @@ -40,7 +40,7 @@ main = do isDataCon (L _ (XHsBindsLR (AbsBinds { abs_binds = bs }))) = not (isEmptyBag (filterBag isDataCon bs)) isDataCon (L l (f@FunBind {})) - | (MG _ (L _ (m:_)) _) <- fun_matches f, + | (MG _ (L _ (m:_))) <- fun_matches f, ((L _ (c@ConPat{})):_)<-hsLMatchPats m, (L l _)<-pat_con c = isGoodSrcSpan (locA l) -- Check that the source location is a good one diff --git a/testsuite/tests/module/mod185.stderr b/testsuite/tests/module/mod185.stderr index 04dc4758b1..678557c52f 100644 --- a/testsuite/tests/module/mod185.stderr +++ b/testsuite/tests/module/mod185.stderr @@ -75,7 +75,7 @@ (Unqual {OccName: main})) (MG - (NoExtField) + (FromSource) (L (SrcSpanAnn (EpAnnNotUsed) { mod185.hs:5:1-24 }) [(L @@ -124,8 +124,7 @@ {ModuleName: Prelude} {OccName: undefined}))))))] (EmptyLocalBinds - (NoExtField)))))]) - (FromSource)) + (NoExtField)))))])) [])))] (Nothing) (Nothing))) diff --git a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr index 089fe770c8..c91d8cdc70 100644 --- a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr @@ -1457,7 +1457,7 @@ (Unqual {OccName: main})) (MG - (NoExtField) + (FromSource) (L (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAst.hs:24:1-23 }) [(L @@ -1528,8 +1528,7 @@ (SourceText "hello") {FastString: "hello"})))))))] (EmptyLocalBinds - (NoExtField)))))]) - (FromSource)) + (NoExtField)))))])) [])))] (Nothing) (Nothing))) diff --git a/testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr b/testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr index f25f99cd32..6673dff801 100644 --- a/testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr +++ b/testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr @@ -33,7 +33,7 @@ (UnchangedAnchor)) (EpaComment (EpaBlockComment - "{-/n Block comment at the beginning/n -}") + "{-\n Block comment at the beginning\n -}") { DumpParsedAstComments.hs:1:1-28 }))] [(L (Anchor @@ -76,7 +76,7 @@ (Unqual {OccName: foo})) (MG - (NoExtField) + (FromSource) (L (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:(7,1)-(9,3) }) @@ -185,8 +185,7 @@ (NoExtField) (NoExtField)))])))))] (EmptyLocalBinds - (NoExtField)))))]) - (FromSource)) + (NoExtField)))))])) []))) ,(L (SrcSpanAnn (EpAnn @@ -206,7 +205,7 @@ (Unqual {OccName: main})) (MG - (NoExtField) + (FromSource) (L (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:12:1-23 }) [(L @@ -277,8 +276,9 @@ (SourceText "hello") {FastString: "hello"})))))))] (EmptyLocalBinds - (NoExtField)))))]) - (FromSource)) + (NoExtField)))))])) [])))] (Nothing) - (Nothing)))
\ No newline at end of file + (Nothing))) + + diff --git a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr index c89f054ce4..f5fc2e9d00 100644 --- a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr @@ -26,7 +26,7 @@ (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:34:1-4 }) {Name: DumpRenamedAst.main}) (MG - (NoExtField) + (FromSource) (L (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:34:1-23 }) [(L @@ -81,8 +81,7 @@ (SourceText "hello") {FastString: "hello"})))))))] (EmptyLocalBinds - (NoExtField)))))]) - (FromSource)) + (NoExtField)))))])) []))]})] [])) [] diff --git a/testsuite/tests/parser/should_compile/DumpSemis.stderr b/testsuite/tests/parser/should_compile/DumpSemis.stderr index 8f7b2252d8..45a3d7acda 100644 --- a/testsuite/tests/parser/should_compile/DumpSemis.stderr +++ b/testsuite/tests/parser/should_compile/DumpSemis.stderr @@ -230,7 +230,7 @@ (Unqual {OccName: foo})) (MG - (NoExtField) + (FromSource) (L (SrcSpanAnn (EpAnnNotUsed) { DumpSemis.hs:(10,1)-(12,3) }) [(L @@ -381,8 +381,7 @@ (NoExtField) (NoExtField)))])))))] (EmptyLocalBinds - (NoExtField)))))]) - (FromSource)) + (NoExtField)))))])) []))) ,(L (SrcSpanAnn (EpAnn @@ -476,7 +475,7 @@ (Unqual {OccName: bar})) (MG - (NoExtField) + (FromSource) (L (SrcSpanAnn (EpAnnNotUsed) { DumpSemis.hs:(15,1)-(19,3) }) [(L @@ -593,8 +592,7 @@ (NoExtField) (NoExtField)))])))))] (EmptyLocalBinds - (NoExtField)))))]) - (FromSource)) + (NoExtField)))))])) []))) ,(L (SrcSpanAnn (EpAnn @@ -682,7 +680,7 @@ (Unqual {OccName: baz})) (MG - (NoExtField) + (FromSource) (L (SrcSpanAnn (EpAnnNotUsed) { DumpSemis.hs:22:1-30 }) [(L @@ -831,8 +829,7 @@ (NoExtField) (NoExtField)))])))))] (EmptyLocalBinds - (NoExtField)))))]) - (FromSource)) + (NoExtField)))))])) []))) ,(L (SrcSpanAnn (EpAnn @@ -852,7 +849,7 @@ (Unqual {OccName: a})) (MG - (NoExtField) + (FromSource) (L (SrcSpanAnn (EpAnnNotUsed) { DumpSemis.hs:24:1-13 }) [(L @@ -900,8 +897,7 @@ (Unqual {OccName: undefined}))))))] (EmptyLocalBinds - (NoExtField)))))]) - (FromSource)) + (NoExtField)))))])) []))) ,(L (SrcSpanAnn (EpAnn @@ -921,7 +917,7 @@ (Unqual {OccName: b})) (MG - (NoExtField) + (FromSource) (L (SrcSpanAnn (EpAnnNotUsed) { DumpSemis.hs:25:1-13 }) [(L @@ -969,8 +965,7 @@ (Unqual {OccName: undefined}))))))] (EmptyLocalBinds - (NoExtField)))))]) - (FromSource)) + (NoExtField)))))])) []))) ,(L (SrcSpanAnn (EpAnn @@ -991,7 +986,7 @@ (Unqual {OccName: s})) (MG - (NoExtField) + (FromSource) (L (SrcSpanAnn (EpAnnNotUsed) { DumpSemis.hs:26:1-13 }) [(L @@ -1039,8 +1034,7 @@ (Unqual {OccName: undefined}))))))] (EmptyLocalBinds - (NoExtField)))))]) - (FromSource)) + (NoExtField)))))])) []))) ,(L (SrcSpanAnn (EpAnn @@ -1375,7 +1369,7 @@ (Unqual {OccName: f})) (MG - (NoExtField) + (FromSource) (L (SrcSpanAnn (EpAnnNotUsed) { DumpSemis.hs:32:1-7 }) [(L @@ -1442,8 +1436,7 @@ (Unqual {OccName: x}))))))] (EmptyLocalBinds - (NoExtField)))))]) - (FromSource)) + (NoExtField)))))])) []))) ,(L (SrcSpanAnn (EpAnn @@ -1466,7 +1459,7 @@ (Unqual {OccName: x})) (MG - (NoExtField) + (FromSource) (L (SrcSpanAnn (EpAnnNotUsed) { DumpSemis.hs:34:8-35 }) [(L @@ -1568,7 +1561,7 @@ (Unqual {OccName: y})) (MG - (NoExtField) + (FromSource) (L (SrcSpanAnn (EpAnnNotUsed) { DumpSemis.hs:34:19-21 }) [(L @@ -1625,8 +1618,7 @@ (False) (2))))))))] (EmptyLocalBinds - (NoExtField)))))]) - (FromSource)) + (NoExtField)))))])) [])) ,(L (SrcSpanAnn (EpAnn @@ -1651,7 +1643,7 @@ (Unqual {OccName: z})) (MG - (NoExtField) + (FromSource) (L (SrcSpanAnn (EpAnnNotUsed) { DumpSemis.hs:34:24-26 }) [(L @@ -1708,8 +1700,7 @@ (False) (3))))))))] (EmptyLocalBinds - (NoExtField)))))]) - (FromSource)) + (NoExtField)))))])) []))]} [])) (L @@ -1725,8 +1716,7 @@ (Unqual {OccName: y}))))))))] (EmptyLocalBinds - (NoExtField)))))]) - (FromSource)) + (NoExtField)))))])) []))) ,(L (SrcSpanAnn (EpAnn @@ -1746,7 +1736,7 @@ (Unqual {OccName: fot})) (MG - (NoExtField) + (FromSource) (L (SrcSpanAnn (EpAnnNotUsed) { DumpSemis.hs:(36,1)-(44,4) }) [(L @@ -1822,7 +1812,7 @@ (Unqual {OccName: x})))) (MG - (NoExtField) + (FromSource) (L (SrcSpanAnn (EpAnn (Anchor @@ -2124,11 +2114,9 @@ (SourceText 'd') ('d'))))))] (EmptyLocalBinds - (NoExtField)))))]) - (FromSource))))))] + (NoExtField)))))]))))))] (EmptyLocalBinds - (NoExtField)))))]) - (FromSource)) + (NoExtField)))))])) [])))] (Nothing) (Nothing))) diff --git a/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr b/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr index 59b4113c1b..8cc15cc04c 100644 --- a/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr @@ -1547,7 +1547,8 @@ ({abstract:TyCon}) [(TyConApp ({abstract:TyCon}) - [])])) + [])]) + (FromSource)) (L (SrcSpanAnn (EpAnnNotUsed) { DumpTypecheckedAst.hs:19:1-23 }) [(L @@ -1596,8 +1597,7 @@ (SourceText "hello") {FastString: "hello"})))))))] (EmptyLocalBinds - (NoExtField)))))]) - (FromSource)) + (NoExtField)))))])) []))]} (False))))]} diff --git a/testsuite/tests/parser/should_compile/KindSigs.stderr b/testsuite/tests/parser/should_compile/KindSigs.stderr index 634d488cf7..b3107c18c6 100644 --- a/testsuite/tests/parser/should_compile/KindSigs.stderr +++ b/testsuite/tests/parser/should_compile/KindSigs.stderr @@ -843,7 +843,7 @@ (Unqual {OccName: qux})) (MG - (NoExtField) + (FromSource) (L (SrcSpanAnn (EpAnnNotUsed) { KindSigs.hs:23:1-12 }) [(L @@ -915,8 +915,7 @@ (Exact {Name: ()}))))))] (EmptyLocalBinds - (NoExtField)))))]) - (FromSource)) + (NoExtField)))))])) []))) ,(L (SrcSpanAnn (EpAnn @@ -1464,7 +1463,7 @@ (Unqual {OccName: true})) (MG - (NoExtField) + (FromSource) (L (SrcSpanAnn (EpAnnNotUsed) { KindSigs.hs:35:1-11 }) [(L @@ -1512,8 +1511,7 @@ (Unqual {OccName: True}))))))] (EmptyLocalBinds - (NoExtField)))))]) - (FromSource)) + (NoExtField)))))])) [])))] (Nothing) (Nothing))) diff --git a/testsuite/tests/parser/should_compile/T20718.stderr b/testsuite/tests/parser/should_compile/T20718.stderr index c041db260a..77563d8631 100644 --- a/testsuite/tests/parser/should_compile/T20718.stderr +++ b/testsuite/tests/parser/should_compile/T20718.stderr @@ -98,7 +98,7 @@ (Unqual {OccName: x})) (MG - (NoExtField) + (FromSource) (L (SrcSpanAnn (EpAnnNotUsed) { T20718.hs:8:1-5 }) [(L @@ -155,8 +155,9 @@ (False) (1))))))))] (EmptyLocalBinds - (NoExtField)))))]) - (FromSource)) + (NoExtField)))))])) [])))] (Nothing) (Nothing))) + + diff --git a/testsuite/tests/parser/should_compile/T20846.stderr b/testsuite/tests/parser/should_compile/T20846.stderr index f68526360d..775531c619 100644 --- a/testsuite/tests/parser/should_compile/T20846.stderr +++ b/testsuite/tests/parser/should_compile/T20846.stderr @@ -89,7 +89,7 @@ (Unqual {OccName: ++++})) (MG - (NoExtField) + (FromSource) (L (SrcSpanAnn (EpAnnNotUsed) { T20846.hs:4:1-18 }) [(L @@ -148,8 +148,9 @@ (Unqual {OccName: undefined}))))))] (EmptyLocalBinds - (NoExtField)))))]) - (FromSource)) + (NoExtField)))))])) [])))] (Nothing) (Nothing))) + + diff --git a/testsuite/tests/printer/Test20297.stdout b/testsuite/tests/printer/Test20297.stdout index 6d7212f250..2328e8201c 100644 --- a/testsuite/tests/printer/Test20297.stdout +++ b/testsuite/tests/printer/Test20297.stdout @@ -66,7 +66,7 @@ (Unqual {OccName: bar})) (MG - (NoExtField) + (FromSource) (L (SrcSpanAnn (EpAnnNotUsed) { Test20297.hs:(5,1)-(7,7) }) [(L @@ -140,8 +140,7 @@ (NoAnnSortKey) {Bag(LocatedA (HsBind GhcPs)): []} - [])))))]) - (FromSource)) + [])))))])) []))) ,(L (SrcSpanAnn (EpAnn @@ -161,7 +160,7 @@ (Unqual {OccName: foo})) (MG - (NoExtField) + (FromSource) (L (SrcSpanAnn (EpAnnNotUsed) { Test20297.hs:(9,1)-(11,26) }) [(L @@ -250,7 +249,7 @@ (Unqual {OccName: doStuff})) (MG - (NoExtField) + (FromSource) (L (SrcSpanAnn (EpAnnNotUsed) { Test20297.hs:11:9-26 }) [(L @@ -340,11 +339,9 @@ (NoExtField) (NoExtField)))])))))] (EmptyLocalBinds - (NoExtField)))))]) - (FromSource)) + (NoExtField)))))])) []))]} - [])))))]) - (FromSource)) + [])))))])) [])))] (Nothing) (Nothing))) @@ -411,7 +408,7 @@ (Unqual {OccName: bar})) (MG - (NoExtField) + (FromSource) (L (SrcSpanAnn (EpAnnNotUsed) { Test20297.ppr.hs:(3,1)-(5,7) }) [(L @@ -478,8 +475,7 @@ (NoAnnSortKey) {Bag(LocatedA (HsBind GhcPs)): []} - [])))))]) - (FromSource)) + [])))))])) []))) ,(L (SrcSpanAnn (EpAnn @@ -499,7 +495,7 @@ (Unqual {OccName: foo})) (MG - (NoExtField) + (FromSource) (L (SrcSpanAnn (EpAnnNotUsed) { Test20297.ppr.hs:(6,1)-(9,24) }) [(L @@ -581,7 +577,7 @@ (Unqual {OccName: doStuff})) (MG - (NoExtField) + (FromSource) (L (SrcSpanAnn (EpAnnNotUsed) { Test20297.ppr.hs:9:7-24 }) [(L @@ -671,11 +667,11 @@ (NoExtField) (NoExtField)))])))))] (EmptyLocalBinds - (NoExtField)))))]) - (FromSource)) + (NoExtField)))))])) []))]} - [])))))]) - (FromSource)) + [])))))])) [])))] (Nothing) (Nothing))) + + diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs index bda1647ccd..b52aa18de9 100644 --- a/utils/check-exact/ExactPrint.hs +++ b/utils/check-exact/ExactPrint.hs @@ -1890,7 +1890,7 @@ instance ExactPrint (HsExpr GhcPs) where NoSourceText -> withPpr x exact (HsLit _an lit) = withPpr lit - exact (HsLam _ (MG _ (L _ [match]) _)) = do + exact (HsLam _ (MG _ (L _ [match]))) = do markAnnotated match -- markExpr _ (HsLam _ (MG _ (L _ [match]) _)) = do -- setContext (Set.singleton LambdaExpr) $ do @@ -2205,13 +2205,13 @@ instance ExactPrint (HsSplice GhcPs) where -- TODO:AZ: combine these instances instance ExactPrint (MatchGroup GhcPs (LocatedA (HsExpr GhcPs))) where getAnnotationEntry = const NoEntryVal - exact (MG _ matches _) = do + exact (MG _ matches) = do -- TODO:AZ use SortKey, in MG ann. markAnnotated matches instance ExactPrint (MatchGroup GhcPs (LocatedA (HsCmd GhcPs))) where getAnnotationEntry = const NoEntryVal - exact (MG _ matches _) = do + exact (MG _ matches) = do -- TODO:AZ use SortKey, in MG ann. markAnnotated matches diff --git a/utils/check-exact/Main.hs b/utils/check-exact/Main.hs index 46e68d638a..f017233da5 100644 --- a/utils/check-exact/Main.hs +++ b/utils/check-exact/Main.hs @@ -692,7 +692,7 @@ addLocaLDecl6 libdir lp = do [de1'',d2] <- balanceCommentsList decls0 let de1 = captureMatchLineSpacing de1'' - let L _ (ValD _ (FunBind _ _ (MG _ (L _ ms) _) _)) = de1 + let L _ (ValD _ (FunBind _ _ (MG _ (L _ ms)) _)) = de1 let [ma1,_ma2] = ms (de1',_) <- modifyValD (getLocA ma1) de1 $ \_m decls -> do diff --git a/utils/check-exact/Transform.hs b/utils/check-exact/Transform.hs index d6ea9a627d..fec7a32068 100644 --- a/utils/check-exact/Transform.hs +++ b/utils/check-exact/Transform.hs @@ -263,8 +263,8 @@ captureOrder ls = AnnSortKey $ map (rs . getLocA) ls -- --------------------------------------------------------------------- captureMatchLineSpacing :: LHsDecl GhcPs -> LHsDecl GhcPs -captureMatchLineSpacing (L l (ValD x (FunBind a b (MG c (L d ms ) e) f))) - = L l (ValD x (FunBind a b (MG c (L d ms') e) f)) +captureMatchLineSpacing (L l (ValD x (FunBind a b (MG c (L d ms )) f))) + = L l (ValD x (FunBind a b (MG c (L d ms')) f)) where ms' :: [LMatch GhcPs (LHsExpr GhcPs)] ms' = captureLineSpacing ms @@ -447,8 +447,8 @@ getEntryDP anns ast = -- --------------------------------------------------------------------- setEntryDPDecl :: LHsDecl GhcPs -> DeltaPos -> LHsDecl GhcPs -setEntryDPDecl decl@(L _ (ValD x (FunBind a b (MG c (L d ms ) e) f))) dp - = L l' (ValD x (FunBind a b (MG c (L d ms') e) f)) +setEntryDPDecl decl@(L _ (ValD x (FunBind a b (MG c (L d ms )) f))) dp + = L l' (ValD x (FunBind a b (MG c (L d ms')) f)) where L l' _ = setEntryDP' decl dp ms' :: [LMatch GhcPs (LHsExpr GhcPs)] @@ -552,8 +552,8 @@ transferEntryDP' la lb = do pushDeclDP :: HsDecl GhcPs -> DeltaPos -> HsDecl GhcPs -pushDeclDP (ValD x (FunBind a b (MG c (L d ms ) e) f)) dp - = ValD x (FunBind a b (MG c (L d' ms') e) f) +pushDeclDP (ValD x (FunBind a b (MG c (L d ms )) f)) dp + = ValD x (FunBind a b (MG c (L d' ms')) f) where L d' _ = setEntryDP' (L d ms) dp ms' :: [LMatch GhcPs (LHsExpr GhcPs)] @@ -623,7 +623,7 @@ balanceComments first second = do -- 'Match' if that 'Match' needs to be manipulated. balanceCommentsFB :: (Monad m) => LHsBind GhcPs -> LocatedA b -> TransformT m (LHsBind GhcPs, LocatedA b) -balanceCommentsFB (L lf (FunBind x n (MG mx (L lm matches) o) t)) second = do +balanceCommentsFB (L lf (FunBind x n (MG o (L lm matches)) t)) second = do logTr $ "balanceCommentsFB entered: " ++ showGhc (ss2range $ locA lf) -- There are comments on lf. We need to -- + Keep the prior ones here @@ -655,7 +655,7 @@ balanceCommentsFB (L lf (FunBind x n (MG mx (L lm matches) o) t)) second = do _ -> (m'',lf') logTr $ "balanceCommentsMatch done" -- return (L lf'' (FunBind x n (MG mx (L lm (reverse (m''':ms))) o) t), second') - balanceComments' (L lf'' (FunBind x n (MG mx (L lm (reverse (m''':ms))) o) t)) second' + balanceComments' (L lf'' (FunBind x n (MG o (L lm (reverse (m''':ms)))) t)) second' balanceCommentsFB f s = balanceComments' f s -- | Move comments on the same line as the end of the match into the @@ -1372,7 +1372,7 @@ hsDeclsGeneric t = q t -- --------------------------------- lhsbind :: (Monad m) => LHsBind GhcPs -> TransformT m [LHsDecl GhcPs] - lhsbind (L _ (FunBind _ _ (MG _ (L _ matches) _) _)) = do + lhsbind (L _ (FunBind _ _ (MG _ (L _ matches)) _)) = do dss <- mapM hsDecls matches return (concat dss) lhsbind p@(L _ (PatBind{})) = do |