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
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:
| ... | ... | @@ -78,7 +78,7 @@ type instance XEmptyLocalBinds (GhcPass pL) (GhcPass pR) = NoExtField |
| 78 | 78 | type instance XXHsLocalBindsLR (GhcPass pL) (GhcPass pR) = DataConCantHappen
|
| 79 | 79 | |
| 80 | 80 | -- ---------------------------------------------------------------------
|
| 81 | -type instance XValBinds (GhcPass pL) (GhcPass pR) = AnnSortKey BindTag
|
|
| 81 | +type instance XValBinds (GhcPass pL) (GhcPass pR) = NoExtField
|
|
| 82 | 82 | |
| 83 | 83 | type instance XXValBindsLR (GhcPass pL) _ = HsValBindGroups pL
|
| 84 | 84 | |
| ... | ... | @@ -154,6 +154,10 @@ data AnnPSB |
| 154 | 154 | instance NoAnn AnnPSB where
|
| 155 | 155 | noAnn = AnnPSB noAnn noAnn noAnn noAnn
|
| 156 | 156 | |
| 157 | +instance HasLoc (ValBind (GhcPass p) (GhcPass p)) where
|
|
| 158 | + getHasLoc (VbBind b) = getHasLoc b
|
|
| 159 | + getHasLoc (VbSig s) = getHasLoc s
|
|
| 160 | + |
|
| 157 | 161 | -- ---------------------------------------------------------------------
|
| 158 | 162 | |
| 159 | 163 | -- | Typechecked, generalised bindings, used in the output to the type checker.
|
| ... | ... | @@ -442,8 +446,8 @@ instance (OutputableBndrId pl, OutputableBndrId pr) |
| 442 | 446 | |
| 443 | 447 | instance (OutputableBndrId pl, OutputableBndrId pr)
|
| 444 | 448 | => Outputable (HsValBindsLR (GhcPass pl) (GhcPass pr)) where
|
| 445 | - ppr (ValBinds _ binds sigs)
|
|
| 446 | - = pprDeclList (pprLHsBindsForUser binds sigs)
|
|
| 449 | + ppr (ValBinds _ binds)
|
|
| 450 | + = pprDeclList (pprLHsBindsForUser' binds)
|
|
| 447 | 451 | |
| 448 | 452 | ppr (XValBindsLR (HsVBG bs sigs))
|
| 449 | 453 | = getPprDebug $ \case
|
| ... | ... | @@ -487,6 +491,21 @@ pprLHsBindsForUser binds sigs |
| 487 | 491 | |
| 488 | 492 | sort_by_loc decls = sortBy (SrcLoc.leftmost_smallest `on` fst) decls
|
| 489 | 493 | |
| 494 | +pprLHsBindsForUser' :: (OutputableBndrId idL, OutputableBndrId idR)
|
|
| 495 | + => [ValBind (GhcPass idL) (GhcPass idR)] -> [SDoc]
|
|
| 496 | +-- pprLHsBindsForUser is different to pprLHsBinds because
|
|
| 497 | +-- a) No braces: 'let' and 'where' include a list of HsBindGroups
|
|
| 498 | +-- and we don't want several groups of bindings each
|
|
| 499 | +-- with braces around
|
|
| 500 | +-- b) Sort by location before printing
|
|
| 501 | +-- c) Include signatures
|
|
| 502 | +pprLHsBindsForUser' binds
|
|
| 503 | + = map ppr_bind binds
|
|
| 504 | + where
|
|
| 505 | + ppr_bind (VbBind b) = ppr b
|
|
| 506 | + ppr_bind (VbSig s) = ppr s
|
|
| 507 | + |
|
| 508 | + |
|
| 490 | 509 | pprDeclList :: [SDoc] -> SDoc -- Braces with a space
|
| 491 | 510 | -- Print a bunch of declarations
|
| 492 | 511 | -- One could choose { d1; d2; ... }, using 'sep'
|
| ... | ... | @@ -507,11 +526,11 @@ eqEmptyLocalBinds (EmptyLocalBinds _) = True |
| 507 | 526 | eqEmptyLocalBinds _ = False
|
| 508 | 527 | |
| 509 | 528 | isEmptyValBinds :: HsValBindsLR (GhcPass a) (GhcPass b) -> Bool
|
| 510 | -isEmptyValBinds (ValBinds _ ds sigs) = isEmptyLHsBinds ds && null sigs
|
|
| 529 | +isEmptyValBinds (ValBinds _ binds) = null binds
|
|
| 511 | 530 | isEmptyValBinds (XValBindsLR (HsVBG ds sigs)) = null ds && null sigs
|
| 512 | 531 | |
| 513 | 532 | emptyValBindsIn :: HsValBindsLR (GhcPass a) (GhcPass b)
|
| 514 | -emptyValBindsIn = ValBinds NoAnnSortKey [] []
|
|
| 533 | +emptyValBindsIn = ValBinds noExtField []
|
|
| 515 | 534 | emptyValBindsRn :: HsValBindsLR GhcRn GhcRn
|
| 516 | 535 | emptyValBindsRn = XValBindsLR (HsVBG [] [])
|
| 517 | 536 | |
| ... | ... | @@ -532,8 +551,8 @@ hsValBindGroupsBinds binds |
| 532 | 551 | ------------
|
| 533 | 552 | plusHsValBinds :: HsValBinds (GhcPass a) -> HsValBinds (GhcPass a)
|
| 534 | 553 | -> HsValBinds(GhcPass a)
|
| 535 | -plusHsValBinds (ValBinds _ ds1 sigs1) (ValBinds _ ds2 sigs2)
|
|
| 536 | - = ValBinds NoAnnSortKey (ds1 ++ ds2) (sigs1 ++ sigs2)
|
|
| 554 | +plusHsValBinds (ValBinds _ ds1) (ValBinds _ ds2)
|
|
| 555 | + = ValBinds noExtField (ds1 ++ ds2)
|
|
| 537 | 556 | plusHsValBinds (XValBindsLR (HsVBG ds1 ss1)) (XValBindsLR (HsVBG ds2 ss2))
|
| 538 | 557 | = XValBindsLR (HsVBG (ds1++ds2) (ss1++ss2))
|
| 539 | 558 | plusHsValBinds _ _
|
| ... | ... | @@ -73,6 +73,11 @@ deriving instance Data (HsValBindsLR GhcPs GhcRn) |
| 73 | 73 | deriving instance Data (HsValBindsLR GhcRn GhcRn)
|
| 74 | 74 | deriving instance Data (HsValBindsLR GhcTc GhcTc)
|
| 75 | 75 | |
| 76 | +deriving instance Data (ValBind GhcPs GhcPs)
|
|
| 77 | +deriving instance Data (ValBind GhcPs GhcRn)
|
|
| 78 | +deriving instance Data (ValBind GhcRn GhcRn)
|
|
| 79 | +deriving instance Data (ValBind GhcTc GhcTc)
|
|
| 80 | + |
|
| 76 | 81 | -- deriving instance (DataIdLR pL pL) => Data (NHsValBindsLR pL)
|
| 77 | 82 | deriving instance Data (HsValBindGroups 'Parsed)
|
| 78 | 83 | deriving instance Data (HsValBindGroups 'Renamed)
|
| ... | ... | @@ -84,8 +84,8 @@ module GHC.Hs.Utils( |
| 84 | 84 | -- * Collecting binders
|
| 85 | 85 | isUnliftedHsBind, isUnliftedHsBinds, isBangedHsBind,
|
| 86 | 86 | |
| 87 | - collectLocalBinders, collectHsValBinders, collectHsBindListBinders,
|
|
| 88 | - collectHsIdBinders,
|
|
| 87 | + collectLocalBinders, collectHsValBinders, collectHsValBinders', collectHsBindListBinders,
|
|
| 88 | + collectHsIdBinders, collectHsIdBinders',
|
|
| 89 | 89 | collectHsBindsBinders, collectHsBindBinders, collectMethodBinders,
|
| 90 | 90 | |
| 91 | 91 | collectPatBinders, collectPatsBinders,
|
| ... | ... | @@ -885,8 +885,11 @@ spanHsLocaLBinds (EmptyLocalBinds _) |
| 885 | 885 | = noSrcSpan
|
| 886 | 886 | spanHsLocaLBinds (HsIPBinds _ (IPBinds _ bs))
|
| 887 | 887 | = get_bind_spans bs []
|
| 888 | -spanHsLocaLBinds (HsValBinds _ (ValBinds _ bs sigs))
|
|
| 889 | - = get_bind_spans bs sigs
|
|
| 888 | +spanHsLocaLBinds (HsValBinds _ (ValBinds _ binds))
|
|
| 889 | + = get_bind_spans bs ss
|
|
| 890 | + where
|
|
| 891 | + bs :: [LHsBindLR (GhcPass p) (GhcPass p)]
|
|
| 892 | + (bs,ss) = val_binds_and_sigs binds
|
|
| 890 | 893 | spanHsLocaLBinds (HsValBinds _ (XValBindsLR (HsVBG bs ss)))
|
| 891 | 894 | = get_bind_spans (hsValBindGroupsBinds @p bs) ss
|
| 892 | 895 | |
| ... | ... | @@ -1085,12 +1088,25 @@ collectHsIdBinders :: (IsPass idL, CollectPass (GhcPass idL)) |
| 1085 | 1088 | -- ^ Collect 'Id' binders only, or 'Id's + pattern synonyms, respectively
|
| 1086 | 1089 | collectHsIdBinders flag = collect_hs_val_binders True flag
|
| 1087 | 1090 | |
| 1091 | +collectHsIdBinders' :: (IsPass idL, CollectPass (GhcPass idL))
|
|
| 1092 | + => CollectFlag (GhcPass idL)
|
|
| 1093 | + -> [LHsBindLR (GhcPass idL) idR]
|
|
| 1094 | + -> [IdP (GhcPass idL)]
|
|
| 1095 | +-- ^ Collect 'Id' binders only, or 'Id's + pattern synonyms, respectively
|
|
| 1096 | +collectHsIdBinders' flag = collect_hs_val_binders' True flag
|
|
| 1097 | + |
|
| 1088 | 1098 | collectHsValBinders :: (IsPass idL, CollectPass (GhcPass idL))
|
| 1089 | 1099 | => CollectFlag (GhcPass idL)
|
| 1090 | 1100 | -> HsValBindsLR (GhcPass idL) idR
|
| 1091 | 1101 | -> [IdP (GhcPass idL)]
|
| 1092 | 1102 | collectHsValBinders flag = collect_hs_val_binders False flag
|
| 1093 | 1103 | |
| 1104 | +collectHsValBinders' :: (IsPass idL, CollectPass (GhcPass idL))
|
|
| 1105 | + => CollectFlag (GhcPass idL)
|
|
| 1106 | + -> [LHsBindLR (GhcPass idL) idR]
|
|
| 1107 | + -> [IdP (GhcPass idL)]
|
|
| 1108 | +collectHsValBinders' flag = collect_hs_val_binders' False flag
|
|
| 1109 | + |
|
| 1094 | 1110 | collectHsBindBinders :: CollectPass p
|
| 1095 | 1111 | => CollectFlag p
|
| 1096 | 1112 | -> HsBindLR p idR
|
| ... | ... | @@ -1117,9 +1133,17 @@ collect_hs_val_binders :: forall idL idR. (IsPass idL, CollectPass (GhcPass idL) |
| 1117 | 1133 | -> HsValBindsLR (GhcPass idL) idR
|
| 1118 | 1134 | -> [IdP (GhcPass idL)]
|
| 1119 | 1135 | collect_hs_val_binders ps flag = \case
|
| 1120 | - ValBinds _ binds _ -> collect_binds ps flag binds []
|
|
| 1136 | + ValBinds _ binds -> collect_binds ps flag (val_binds binds) []
|
|
| 1121 | 1137 | XValBindsLR (HsVBG grps _) -> collect_binds ps flag (hsValBindGroupsBinds @idL grps) []
|
| 1122 | 1138 | |
| 1139 | +collect_hs_val_binders' :: forall idL idR. (IsPass idL, CollectPass (GhcPass idL))
|
|
| 1140 | + => Bool
|
|
| 1141 | + -> CollectFlag (GhcPass idL)
|
|
| 1142 | + -> [LHsBindLR (GhcPass idL) idR]
|
|
| 1143 | + -> [IdP (GhcPass idL)]
|
|
| 1144 | +collect_hs_val_binders' ps flag binds = collect_binds ps flag binds []
|
|
| 1145 | + |
|
| 1146 | + |
|
| 1123 | 1147 | collect_binds :: forall p idR. CollectPass p
|
| 1124 | 1148 | => Bool
|
| 1125 | 1149 | -> CollectFlag p
|
| ... | ... | @@ -1528,7 +1552,7 @@ hsForeignDeclsBinders foreign_decls |
| 1528 | 1552 | hsPatSynSelectors :: IsPass p => HsValBinds (GhcPass p) -> [FieldOcc (GhcPass p)]
|
| 1529 | 1553 | -- ^ Collects record pattern-synonym selectors only; the pattern synonym
|
| 1530 | 1554 | -- names are collected by 'collectHsValBinders'.
|
| 1531 | -hsPatSynSelectors (ValBinds _ _ _) = panic "hsPatSynSelectors"
|
|
| 1555 | +hsPatSynSelectors (ValBinds _ _) = panic "hsPatSynSelectors"
|
|
| 1532 | 1556 | hsPatSynSelectors (XValBindsLR (HsVBG grps _))
|
| 1533 | 1557 | = foldr addPatSynSelector [] $ hsValBindGroupsBinds grps
|
| 1534 | 1558 | |
| ... | ... | @@ -1814,8 +1838,8 @@ hsValBindsImplicits :: HsValBindsLR GhcRn (GhcPass idR) |
| 1814 | 1838 | -> [(SrcSpan, [ImplicitFieldBinders])]
|
| 1815 | 1839 | hsValBindsImplicits (XValBindsLR (HsVBG grps _))
|
| 1816 | 1840 | = lhsBindsImplicits (hsValBindGroupsBinds grps)
|
| 1817 | -hsValBindsImplicits (ValBinds _ binds _)
|
|
| 1818 | - = lhsBindsImplicits binds
|
|
| 1841 | +hsValBindsImplicits (ValBinds _ binds)
|
|
| 1842 | + = lhsBindsImplicits (val_binds binds)
|
|
| 1819 | 1843 | |
| 1820 | 1844 | lhsBindsImplicits :: LHsBindsLR GhcRn idR -> [(SrcSpan, [ImplicitFieldBinders])]
|
| 1821 | 1845 | lhsBindsImplicits = concatMap (lhs_bind . unLoc)
|
| ... | ... | @@ -338,8 +338,8 @@ hsScopedTvBinders binds |
| 338 | 338 | = concatMap get_scoped_tvs sigs
|
| 339 | 339 | where
|
| 340 | 340 | sigs = case binds of
|
| 341 | - ValBinds _ _ sigs -> sigs
|
|
| 342 | - XValBindsLR (HsVBG _ sigs) -> sigs
|
|
| 341 | + ValBinds _ bs -> val_sigs bs
|
|
| 342 | + XValBindsLR (HsVBG _ sigs) -> sigs
|
|
| 343 | 343 | |
| 344 | 344 | get_scoped_tvs :: LSig GhcRn -> [Name]
|
| 345 | 345 | get_scoped_tvs (L _ signature)
|
| ... | ... | @@ -2004,7 +2004,7 @@ rep_val_binds (XValBindsLR (HsVBG binds sigs)) |
| 2004 | 2004 | = do { core1 <- rep_binds (concatMap snd binds)
|
| 2005 | 2005 | ; core2 <- rep_sigs sigs
|
| 2006 | 2006 | ; return (core1 ++ core2) }
|
| 2007 | -rep_val_binds (ValBinds _ _ _)
|
|
| 2007 | +rep_val_binds (ValBinds _ _)
|
|
| 2008 | 2008 | = panic "rep_val_binds: ValBinds"
|
| 2009 | 2009 | |
| 2010 | 2010 | rep_binds :: LHsBinds GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))]
|
| ... | ... | @@ -1438,7 +1438,7 @@ instance CollectFldBinders (HsLocalBinds GhcTc) where |
| 1438 | 1438 | collectFldBinds HsIPBinds{} = emptyVarEnv
|
| 1439 | 1439 | collectFldBinds EmptyLocalBinds{} = emptyVarEnv
|
| 1440 | 1440 | instance CollectFldBinders (HsValBinds GhcTc) where
|
| 1441 | - collectFldBinds (ValBinds _ bnds _) = collectFldBinds bnds
|
|
| 1441 | + collectFldBinds (ValBinds _ bnds) = collectFldBinds (val_binds bnds)
|
|
| 1442 | 1442 | collectFldBinds (XValBindsLR (HsVBG grps _))
|
| 1443 | 1443 | = collectFldBinds (hsValBindGroupsBinds @'Typechecked grps)
|
| 1444 | 1444 | instance CollectFldBinders (HsBind GhcTc) where
|
| ... | ... | @@ -1462,13 +1462,11 @@ instance HiePass p => ToHie (RScoped (HsLocalBinds (GhcPass p))) where |
| 1462 | 1462 | ]
|
| 1463 | 1463 | |
| 1464 | 1464 | scopeHsLocaLBinds :: forall p. IsPass p => HsLocalBinds (GhcPass p) -> Scope
|
| 1465 | -scopeHsLocaLBinds (HsValBinds _ (ValBinds _ bs sigs))
|
|
| 1466 | - = foldr combineScopes NoScope (bsScope ++ sigsScope)
|
|
| 1465 | +scopeHsLocaLBinds (HsValBinds _ (ValBinds _ bs))
|
|
| 1466 | + = foldr combineScopes NoScope bsScope
|
|
| 1467 | 1467 | where
|
| 1468 | 1468 | bsScope :: [Scope]
|
| 1469 | - bsScope = map (mkScope . getLoc) bs
|
|
| 1470 | - sigsScope :: [Scope]
|
|
| 1471 | - sigsScope = map (mkScope . getLocA) sigs
|
|
| 1469 | + bsScope = map (mkScope . getHasLoc) bs
|
|
| 1472 | 1470 | scopeHsLocaLBinds (HsValBinds _ (XValBindsLR (HsVBG grps sigs)))
|
| 1473 | 1471 | = foldr combineScopes NoScope (bsScope ++ sigsScope)
|
| 1474 | 1472 | where
|
| ... | ... | @@ -1491,7 +1489,9 @@ instance HiePass p => ToHie (RScoped (LocatedA (IPBind (GhcPass p)))) where |
| 1491 | 1489 | |
| 1492 | 1490 | instance HiePass p => ToHie (RScoped (HsValBindsLR (GhcPass p) (GhcPass p))) where
|
| 1493 | 1491 | toHie (RS sc v) = concatM $ case v of
|
| 1494 | - ValBinds _ binds sigs ->
|
|
| 1492 | + ValBinds _ binds_and_sigs ->
|
|
| 1493 | + let (binds, sigs) = val_binds_and_sigs binds_and_sigs
|
|
| 1494 | + in
|
|
| 1495 | 1495 | [ toHie $ fmap (BC RegularBind sc) binds
|
| 1496 | 1496 | , toHie $ fmap (SC (SI BindSig Nothing)) sigs
|
| 1497 | 1497 | ]
|
| ... | ... | @@ -41,7 +41,7 @@ module GHC.Parser.Annotation ( |
| 41 | 41 | NameAnn(..), NameAdornment(..),
|
| 42 | 42 | NoEpAnns(..),
|
| 43 | 43 | |
| 44 | - AnnSortKey(..), DeclTag(..), BindTag(..),
|
|
| 44 | + AnnSortKey(..), DeclTag(..),
|
|
| 45 | 45 | |
| 46 | 46 | -- ** Trailing annotations in lists
|
| 47 | 47 | TrailingAnn(..), ta_location,
|
| ... | ... | @@ -652,13 +652,6 @@ data AnnSortKey tag |
| 652 | 652 | | AnnSortKey [tag]
|
| 653 | 653 | deriving (Data, Eq)
|
| 654 | 654 | |
| 655 | --- | Used to track of interleaving of binds and signatures for ValBind
|
|
| 656 | -data BindTag
|
|
| 657 | - -- See Note [AnnSortKey] below
|
|
| 658 | - = BindTag
|
|
| 659 | - | SigDTag
|
|
| 660 | - deriving (Eq,Data,Ord,Show)
|
|
| 661 | - |
|
| 662 | 655 | -- | Used to track interleaving of class methods, class signatures,
|
| 663 | 656 | -- associated types and associate type defaults in `ClassDecl` and
|
| 664 | 657 | -- `ClsInstDecl`.
|
| ... | ... | @@ -1179,9 +1172,6 @@ instance Outputable EpAnnComments where |
| 1179 | 1172 | instance (NamedThing (Located a)) => NamedThing (LocatedAn an a) where
|
| 1180 | 1173 | getName (L l a) = getName (L (locA l) a)
|
| 1181 | 1174 | |
| 1182 | -instance Outputable BindTag where
|
|
| 1183 | - ppr tag = text $ show tag
|
|
| 1184 | - |
|
| 1185 | 1175 | instance Outputable DeclTag where
|
| 1186 | 1176 | ppr tag = text $ show tag
|
| 1187 | 1177 |
| ... | ... | @@ -33,6 +33,7 @@ module GHC.Parser.PostProcess ( |
| 33 | 33 | addModifiersToDecl,
|
| 34 | 34 | |
| 35 | 35 | cvBindGroup,
|
| 36 | + cvBindsAndSigsOnly, wrapValBind,
|
|
| 36 | 37 | cvBindsAndSigs,
|
| 37 | 38 | cvTopDecls,
|
| 38 | 39 | placeHolderPunRhs,
|
| ... | ... | @@ -521,10 +522,28 @@ cvTopDecls decls = getMonoBindAll (fromOL decls) |
| 521 | 522 | -- Declaration list may only contain value bindings and signatures.
|
| 522 | 523 | cvBindGroup :: OrdList (LHsDecl GhcPs) -> P (HsValBinds GhcPs)
|
| 523 | 524 | cvBindGroup binding
|
| 524 | - = do { (mbs, sigs, fam_ds, tfam_insts
|
|
| 525 | - , dfam_insts, _) <- cvBindsAndSigs binding
|
|
| 526 | - ; massert (null fam_ds && null tfam_insts && null dfam_insts)
|
|
| 527 | - ; return $ ValBinds NoAnnSortKey mbs sigs }
|
|
| 525 | + = do { binds <- cvBindsAndSigsOnly binding
|
|
| 526 | + ; return $ ValBinds noExtField binds }
|
|
| 527 | + |
|
| 528 | +cvBindsAndSigsOnly :: OrdList (LHsDecl GhcPs)
|
|
| 529 | + -> P [ValBind GhcPs GhcPs]
|
|
| 530 | +-- Input decls contain just value bindings and signatures
|
|
| 531 | +-- and in case of class or instance declarations also
|
|
| 532 | +-- associated type declarations. They might also contain Haddock comments.
|
|
| 533 | +cvBindsAndSigsOnly fb = do
|
|
| 534 | + fb' <- drop_bad_decls (fromOL fb)
|
|
| 535 | + return (fmap wrapValBind (getMonoBindAll fb'))
|
|
| 536 | + where
|
|
| 537 | + drop_bad_decls [] = return []
|
|
| 538 | + drop_bad_decls (L l (SpliceD _ d) : ds) = do
|
|
| 539 | + addError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrDeclSpliceNotAtTopLevel d
|
|
| 540 | + drop_bad_decls ds
|
|
| 541 | + drop_bad_decls (d:ds) = (d:) <$> drop_bad_decls ds
|
|
| 542 | + |
|
| 543 | +wrapValBind :: LHsDecl (GhcPass p) -> ValBind (GhcPass p) (GhcPass p)
|
|
| 544 | +wrapValBind (L l (ValD _ b)) = VbBind (L l b)
|
|
| 545 | +wrapValBind (L l (SigD _ s)) = VbSig (L l s)
|
|
| 546 | +wrapValBind _ = panic "wrapValBind: got unexpected decl"
|
|
| 528 | 547 | |
| 529 | 548 | cvBindsAndSigs :: OrdList (LHsDecl GhcPs)
|
| 530 | 549 | -> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs]
|
| ... | ... | @@ -195,21 +195,18 @@ it expects the global environment to contain bindings for the binders |
| 195 | 195 | -- so we have a different entry point than for local bindings
|
| 196 | 196 | rnTopBindsLHS :: MiniFixityEnv
|
| 197 | 197 | -> HsValBinds GhcPs
|
| 198 | - -> RnM (HsValBindsLR GhcRn GhcPs)
|
|
| 198 | + -> RnM ([LHsBindLR GhcRn GhcPs], [LSig GhcPs])
|
|
| 199 | 199 | rnTopBindsLHS fix_env binds
|
| 200 | 200 | = rnValBindsLHS (topRecNameMaker fix_env) binds
|
| 201 | 201 | |
| 202 | 202 | -- Ensure that a hs-boot file has no top-level bindings.
|
| 203 | 203 | rnTopBindsLHSBoot :: MiniFixityEnv
|
| 204 | 204 | -> HsValBinds GhcPs
|
| 205 | - -> RnM (HsValBindsLR GhcRn GhcPs)
|
|
| 205 | + -> RnM ([LHsBindLR GhcRn GhcPs], [LSig GhcPs])
|
|
| 206 | 206 | rnTopBindsLHSBoot fix_env binds
|
| 207 | - = do { topBinds <- rnTopBindsLHS fix_env binds
|
|
| 208 | - ; case topBinds of
|
|
| 209 | - ValBinds x mbinds sigs ->
|
|
| 210 | - do { rejectBootDecls HsBoot BootBindsPs mbinds
|
|
| 211 | - ; pure (ValBinds x [] sigs) }
|
|
| 212 | - _ -> pprPanic "rnTopBindsLHSBoot" (ppr topBinds) }
|
|
| 207 | + = do { (mbinds, sigs) <- rnTopBindsLHS fix_env binds
|
|
| 208 | + ; rejectBootDecls HsBoot BootBindsPs mbinds
|
|
| 209 | + ; pure ([], sigs) }
|
|
| 213 | 210 | |
| 214 | 211 | rejectBootDecls :: HsBootOrSig
|
| 215 | 212 | -> (NonEmpty (LocatedA decl) -> BadBootDecls)
|
| ... | ... | @@ -225,8 +222,8 @@ rnTopBindsBoot :: NameSet -> HsValBindsLR GhcRn GhcPs |
| 225 | 222 | -> RnM (HsValBinds GhcRn, DefUses)
|
| 226 | 223 | -- A hs-boot file has no bindings.
|
| 227 | 224 | -- Return a single HsBindGroup with empty binds and renamed signatures
|
| 228 | -rnTopBindsBoot bound_names (ValBinds _ _ sigs)
|
|
| 229 | - = do { (sigs', fvs) <- renameSigs (HsBootCtxt bound_names) sigs
|
|
| 225 | +rnTopBindsBoot bound_names (ValBinds _ val_binds)
|
|
| 226 | + = do { (sigs', fvs) <- renameSigs (HsBootCtxt bound_names) (val_sigs val_binds)
|
|
| 230 | 227 | ; return (XValBindsLR (HsVBG [] sigs'), usesOnly fvs) }
|
| 231 | 228 | rnTopBindsBoot _ b = pprPanic "rnTopBindsBoot" (ppr b)
|
| 232 | 229 | |
| ... | ... | @@ -278,9 +275,9 @@ rnIPBind (IPBind _ n expr) = do |
| 278 | 275 | -- Does duplicate/shadow check
|
| 279 | 276 | rnLocalValBindsLHS :: MiniFixityEnv
|
| 280 | 277 | -> HsValBinds GhcPs
|
| 281 | - -> RnM ([Name], HsValBindsLR GhcRn GhcPs)
|
|
| 278 | + -> RnM ([Name], ([LHsBindLR GhcRn GhcPs], [LSig GhcPs]))
|
|
| 282 | 279 | rnLocalValBindsLHS fix_env binds
|
| 283 | - = do { binds' <- rnValBindsLHS (localRecNameMaker fix_env) binds
|
|
| 280 | + = do { (binds',sigs) <- rnValBindsLHS (localRecNameMaker fix_env) binds
|
|
| 284 | 281 | |
| 285 | 282 | -- Check for duplicates and shadowing
|
| 286 | 283 | -- Must do this *after* renaming the patterns
|
| ... | ... | @@ -300,26 +297,27 @@ rnLocalValBindsLHS fix_env binds |
| 300 | 297 | -- import A(f)
|
| 301 | 298 | -- g = let f = ... in f
|
| 302 | 299 | -- should.
|
| 303 | - ; let bound_names = collectHsValBinders CollNoDictBinders binds'
|
|
| 300 | + ; let bound_names = collectHsValBinders' CollNoDictBinders binds'
|
|
| 304 | 301 | -- There should be only Ids, but if there are any bogus
|
| 305 | 302 | -- pattern synonyms, we'll collect them anyway, so that
|
| 306 | 303 | -- we don't generate subsequent out-of-scope messages
|
| 307 | 304 | ; envs <- getRdrEnvs
|
| 308 | 305 | ; checkDupAndShadowedNames envs bound_names
|
| 309 | 306 | |
| 310 | - ; return (bound_names, binds') }
|
|
| 307 | + ; return (bound_names, (binds', sigs)) }
|
|
| 311 | 308 | |
| 312 | 309 | -- renames the left-hand sides
|
| 313 | 310 | -- generic version used both at the top level and for local binds
|
| 314 | 311 | -- does some error checking, but not what gets done elsewhere at the top level
|
| 315 | 312 | rnValBindsLHS :: NameMaker
|
| 316 | 313 | -> HsValBinds GhcPs
|
| 317 | - -> RnM (HsValBindsLR GhcRn GhcPs)
|
|
| 318 | -rnValBindsLHS topP (ValBinds x mbinds sigs)
|
|
| 319 | - = do { mbinds' <- mapM (wrapLocMA (rnBindLHS topP doc)) mbinds
|
|
| 320 | - ; return $ ValBinds x mbinds' sigs }
|
|
| 314 | + -> RnM ([LHsBindLR GhcRn GhcPs], [LSig GhcPs])
|
|
| 315 | +rnValBindsLHS topP (ValBinds _ vbinds)
|
|
| 316 | + = do { let (mbinds, sigs) = val_binds_and_sigs vbinds
|
|
| 317 | + ; mbinds' <- mapM (wrapLocMA (rnBindLHS topP doc)) mbinds
|
|
| 318 | + ; return (mbinds', sigs) }
|
|
| 321 | 319 | where
|
| 322 | - bndrs = collectHsBindsBinders CollNoDictBinders mbinds
|
|
| 320 | + bndrs = collectHsBindsBinders CollNoDictBinders (val_binds vbinds)
|
|
| 323 | 321 | doc = text "In the binding group for:" <+> pprWithCommas ppr bndrs
|
| 324 | 322 | |
| 325 | 323 | rnValBindsLHS _ b = pprPanic "rnValBindsLHSFromDoc" (ppr b)
|
| ... | ... | @@ -332,8 +330,9 @@ rnValBindsRHS :: HsSigCtxt |
| 332 | 330 | -> HsValBindsLR GhcRn GhcPs
|
| 333 | 331 | -> RnM (HsValBinds GhcRn, DefUses)
|
| 334 | 332 | |
| 335 | -rnValBindsRHS ctxt (ValBinds _ mbinds sigs)
|
|
| 336 | - = do { (sigs', sig_fvs) <- renameSigs ctxt sigs
|
|
| 333 | +rnValBindsRHS ctxt (ValBinds _ vbinds)
|
|
| 334 | + = do { let (mbinds, sigs) = val_binds_and_sigs vbinds
|
|
| 335 | + ; (sigs', sig_fvs) <- renameSigs ctxt sigs
|
|
| 337 | 336 | |
| 338 | 337 | -- Update the TcGblEnv with renamed COMPLETE pragmas from the current
|
| 339 | 338 | -- module, for pattern irrefutability checking in do notation.
|
| ... | ... | @@ -383,20 +382,22 @@ rnLocalValBindsAndThen |
| 383 | 382 | :: HsValBinds GhcPs
|
| 384 | 383 | -> (HsValBinds GhcRn -> FreeNames -> RnM (result, FreeNames))
|
| 385 | 384 | -> RnM (result, FreeNames)
|
| 386 | -rnLocalValBindsAndThen binds@(ValBinds _ _ sigs) thing_inside
|
|
| 387 | - = do { -- (A) Create the local fixity environment
|
|
| 388 | - new_fixities <- makeMiniFixityEnv [ L loc sig
|
|
| 385 | +rnLocalValBindsAndThen binds@(ValBinds _ vbinds) thing_inside
|
|
| 386 | + = do { let sigs = val_sigs vbinds
|
|
| 387 | + -- (A) Create the local fixity environment
|
|
| 388 | + ; new_fixities <- makeMiniFixityEnv [ L loc sig
|
|
| 389 | 389 | | L loc (FixSig _ sig) <- sigs]
|
| 390 | 390 | |
| 391 | 391 | -- (B) Rename the LHSes
|
| 392 | - ; (bound_names, new_lhs) <- rnLocalValBindsLHS new_fixities binds
|
|
| 392 | + ; (bound_names, (binds',sigs')) <- rnLocalValBindsLHS new_fixities binds
|
|
| 393 | 393 | |
| 394 | 394 | -- ...and bring them (and their fixities) into scope
|
| 395 | 395 | ; bindLocalNamesFV bound_names $
|
| 396 | 396 | addLocalFixities new_fixities bound_names $ do
|
| 397 | 397 | |
| 398 | 398 | { -- (C) Do the RHS and thing inside
|
| 399 | - (binds', dus) <- rnLocalValBindsRHS (mkNameSet bound_names) new_lhs
|
|
| 399 | + let new_lhs :: HsValBindsLR GhcRn GhcPs = ValBinds noExtField (map VbBind binds' ++ map VbSig sigs')
|
|
| 400 | + ; (binds', dus) <- rnLocalValBindsRHS (mkNameSet bound_names) new_lhs
|
|
| 400 | 401 | ; (result, result_fvs) <- thing_inside binds' (allUses dus)
|
| 401 | 402 | |
| 402 | 403 | -- Report unused bindings based on the (accurate)
|
| ... | ... | @@ -1546,10 +1546,10 @@ rnRecStmtsAndThen ctxt rnBody s cont |
| 1546 | 1546 | collectRecStmtsFixities :: [LStmtLR GhcPs GhcPs body] -> [LFixitySig GhcPs]
|
| 1547 | 1547 | collectRecStmtsFixities l =
|
| 1548 | 1548 | foldr (\ s -> \acc -> case s of
|
| 1549 | - (L _ (LetStmt _ (HsValBinds _ (ValBinds _ _ sigs)))) ->
|
|
| 1549 | + (L _ (LetStmt _ (HsValBinds _ (ValBinds _ bs)))) ->
|
|
| 1550 | 1550 | foldr (\ sig -> \ acc -> case sig of
|
| 1551 | 1551 | (L loc (FixSig _ s)) -> (L loc s) : acc
|
| 1552 | - _ -> acc) acc sigs
|
|
| 1552 | + _ -> acc) acc (val_sigs bs)
|
|
| 1553 | 1553 | _ -> acc) [] l
|
| 1554 | 1554 | |
| 1555 | 1555 | -- left-hand sides
|
| ... | ... | @@ -1578,8 +1578,8 @@ rn_rec_stmt_lhs _ (L _ (LetStmt _ binds@(HsIPBinds {}))) |
| 1578 | 1578 | |
| 1579 | 1579 | |
| 1580 | 1580 | rn_rec_stmt_lhs fix_env (L loc (LetStmt _ (HsValBinds x binds)))
|
| 1581 | - = do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds
|
|
| 1582 | - return [(L loc (LetStmt noAnn (HsValBinds x binds')),
|
|
| 1581 | + = do (_bound_names, (bs',sigs')) <- rnLocalValBindsLHS fix_env binds
|
|
| 1582 | + return [(L loc (LetStmt noAnn (HsValBinds x (makeRnValBinds noExtField bs' sigs'))),
|
|
| 1583 | 1583 | -- Warning: this is bogus; see function invariant
|
| 1584 | 1584 | emptyFNs
|
| 1585 | 1585 | )]
|
| ... | ... | @@ -32,7 +32,8 @@ import GHC.Rename.Utils ( mapFvRn, bindLocalNames |
| 32 | 32 | , checkDupRdrNames, bindLocalNamesFV
|
| 33 | 33 | , warnUnusedTypePatterns
|
| 34 | 34 | , noNestedForallsContextsErr
|
| 35 | - , addNoNestedForallsContextsErr, checkInferredVars )
|
|
| 35 | + , addNoNestedForallsContextsErr, checkInferredVars
|
|
| 36 | + , makeRnValBinds)
|
|
| 36 | 37 | import GHC.Rename.Unbound ( mkUnboundName, notInScopeErr, WhereLooking(WL_Global) )
|
| 37 | 38 | import GHC.Rename.Names
|
| 38 | 39 | |
| ... | ... | @@ -148,12 +149,12 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls, |
| 148 | 149 | |
| 149 | 150 | -- We need to throw an error on such value bindings when in a boot file.
|
| 150 | 151 | is_boot <- tcIsHsBootOrSig ;
|
| 151 | - new_lhs <- if is_boot
|
|
| 152 | + (binds', sigs') <- if is_boot
|
|
| 152 | 153 | then rnTopBindsLHSBoot local_fix_env val_decls
|
| 153 | 154 | else rnTopBindsLHS local_fix_env val_decls ;
|
| 154 | 155 | |
| 155 | 156 | -- Bind the LHSes (and their fixities) in the global rdr environment
|
| 156 | - let { id_bndrs = collectHsIdBinders CollNoDictBinders new_lhs } ;
|
|
| 157 | + let { id_bndrs = collectHsIdBinders' CollNoDictBinders binds' } ;
|
|
| 157 | 158 | -- Excludes pattern-synonym binders
|
| 158 | 159 | -- They are already in scope
|
| 159 | 160 | traceRn "rnSrcDecls" (ppr id_bndrs) ;
|
| ... | ... | @@ -178,6 +179,7 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls, |
| 178 | 179 | -- (F) Rename Value declarations right-hand sides
|
| 179 | 180 | traceRn "Start rnmono" empty ;
|
| 180 | 181 | let { val_bndr_set = mkNameSet id_bndrs `unionNameSet` mkNameSet pat_syn_bndrs } ;
|
| 182 | + let { new_lhs = makeRnValBinds noExtField binds' sigs' } ;
|
|
| 181 | 183 | (rn_val_decls@(XValBindsLR (HsVBG _ sigs')), bind_dus) <- if is_boot
|
| 182 | 184 | -- For an hs-boot, use tc_bndrs (which collects how we're renamed
|
| 183 | 185 | -- 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 { |
| 2723 | 2725 | where
|
| 2724 | 2726 | |
| 2725 | 2727 | new_ps :: HsValBinds GhcPs -> TcM [(ConLikeName, ConInfo)]
|
| 2726 | - new_ps (ValBinds _ binds _) = foldrM new_ps' [] binds
|
|
| 2728 | + new_ps (ValBinds _ binds) = foldrM new_ps' [] (val_binds binds)
|
|
| 2727 | 2729 | new_ps _ = panic "new_ps"
|
| 2728 | 2730 | |
| 2729 | 2731 | new_ps' :: LHsBindLR GhcPs GhcPs
|
| ... | ... | @@ -2921,9 +2923,9 @@ add_kisig d (tycls@(TyClGroup { group_kisigs = kisigs }) : rest) |
| 2921 | 2923 | = tycls { group_kisigs = d : kisigs } : rest
|
| 2922 | 2924 | |
| 2923 | 2925 | add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
|
| 2924 | -add_bind b (ValBinds x bs sigs) = ValBinds x (bs ++ [b]) sigs
|
|
| 2926 | +add_bind b (ValBinds x bs) = ValBinds x (bs ++ [VbBind b])
|
|
| 2925 | 2927 | add_bind _ (XValBindsLR {}) = panic "GHC.Rename.Module.add_bind"
|
| 2926 | 2928 | |
| 2927 | 2929 | add_sig :: LSig (GhcPass a) -> HsValBinds (GhcPass a) -> HsValBinds (GhcPass a)
|
| 2928 | -add_sig s (ValBinds x bs sigs) = ValBinds x bs (s:sigs)
|
|
| 2930 | +add_sig s (ValBinds x bs) = ValBinds x (VbSig s:bs)
|
|
| 2929 | 2931 | add_sig _ (XValBindsLR {}) = panic "GHC.Rename.Module.add_sig" |
| ... | ... | @@ -819,11 +819,11 @@ getLocalNonValBinders fixity_env |
| 819 | 819 | ; is_boot <- tcIsHsBootOrSig
|
| 820 | 820 | ; let val_bndrs
|
| 821 | 821 | | is_boot = case binds of
|
| 822 | - ValBinds _ _val_binds val_sigs ->
|
|
| 822 | + ValBinds _ val_binds ->
|
|
| 823 | 823 | -- In a hs-boot file, the value binders come from the
|
| 824 | 824 | -- *signatures*, and there should be no foreign binders
|
| 825 | 825 | [ L (l2l decl_loc) (unLoc n)
|
| 826 | - | L decl_loc (TypeSig _ _ ns _) <- val_sigs, n <- ns]
|
|
| 826 | + | L decl_loc (TypeSig _ _ ns _) <- (val_sigs val_binds), n <- ns]
|
|
| 827 | 827 | _ -> panic "Non-ValBinds in hs-boot group"
|
| 828 | 828 | | otherwise = for_hs_bndrs
|
| 829 | 829 | ; val_gres <- mapM new_simple val_bndrs
|
| ... | ... | @@ -35,7 +35,9 @@ module GHC.Rename.Utils ( |
| 35 | 35 | addNameClashErrRn, mkNameClashErr,
|
| 36 | 36 | |
| 37 | 37 | checkInferredVars,
|
| 38 | - noNestedForallsContextsErr, addNoNestedForallsContextsErr
|
|
| 38 | + noNestedForallsContextsErr, addNoNestedForallsContextsErr,
|
|
| 39 | + |
|
| 40 | + makeRnValBinds
|
|
| 39 | 41 | )
|
| 40 | 42 | |
| 41 | 43 | where
|
| ... | ... | @@ -868,3 +870,9 @@ mkExpandedTc |
| 868 | 870 | -> LHsExpr GhcTc -- ^ expanded typechecked expression
|
| 869 | 871 | -> HsExpr GhcTc -- ^ suitably wrapped 'XXExprGhcTc'
|
| 870 | 872 | mkExpandedTc o e = XExpr (ExpandedThingTc (HSE o e))
|
| 873 | + |
|
| 874 | +makeRnValBinds :: XValBinds idL idR
|
|
| 875 | + -> [XRec idL (HsBindLR idL idR)]
|
|
| 876 | + -> [XRec idR (Sig idR)]
|
|
| 877 | + -> HsValBindsLR idL idR
|
|
| 878 | +makeRnValBinds x binds sigs = ValBinds x (map VbBind binds ++ map VbSig sigs) |
| ... | ... | @@ -1261,8 +1261,8 @@ compileParsedExprRemote expr@(L loc _) = withSession $ \hsc_env -> do |
| 1261 | 1261 | loc' = locA loc
|
| 1262 | 1262 | expr_name = mkInternalName (getUnique expr_fs) (mkTyVarOccFS expr_fs) loc'
|
| 1263 | 1263 | let_stmt = L loc . LetStmt noAnn . (HsValBinds noAnn) $
|
| 1264 | - ValBinds NoAnnSortKey
|
|
| 1265 | - [mkHsVarBind loc' (getRdrName expr_name) expr] []
|
|
| 1264 | + ValBinds noExtField
|
|
| 1265 | + [VbBind $ mkHsVarBind loc' (getRdrName expr_name) expr]
|
|
| 1266 | 1266 | |
| 1267 | 1267 | pstmt <- liftIO $ hscParsedStmt hsc_env let_stmt
|
| 1268 | 1268 | let (hvals_io, fix_env) = case pstmt of
|
| ... | ... | @@ -296,13 +296,13 @@ renameDeriv inst_infos bagBinds |
| 296 | 296 | -- before renaming the instances themselves
|
| 297 | 297 | ; traceTc "rnd" (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos))
|
| 298 | 298 | ; let (aux_binds, aux_sigs) = unzipBag bagBinds
|
| 299 | - aux_val_binds = ValBinds NoAnnSortKey (bagToList aux_binds) (bagToList aux_sigs)
|
|
| 299 | + aux_val_binds = ValBinds noExtField (map VbBind (bagToList aux_binds) ++ map VbSig (bagToList aux_sigs))
|
|
| 300 | 300 | -- Importantly, we use rnLocalValBindsLHS, not rnTopBindsLHS, to rename
|
| 301 | 301 | -- auxiliary bindings as if they were defined locally.
|
| 302 | 302 | -- See Note [Auxiliary binders] in GHC.Tc.Deriv.Generate.
|
| 303 | - ; (bndrs, rn_aux_lhs) <- rnLocalValBindsLHS emptyMiniFixityEnv aux_val_binds
|
|
| 303 | + ; (bndrs, (binds', sigs')) <- rnLocalValBindsLHS emptyMiniFixityEnv aux_val_binds
|
|
| 304 | 304 | ; bindLocalNames bndrs $
|
| 305 | - do { (rn_aux, dus_aux) <- rnLocalValBindsRHS (mkNameSet bndrs) rn_aux_lhs
|
|
| 305 | + do { (rn_aux, dus_aux) <- rnLocalValBindsRHS (mkNameSet bndrs) (makeRnValBinds noExtField binds' sigs')
|
|
| 306 | 306 | ; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos
|
| 307 | 307 | ; return (listToBag rn_inst_infos, rn_aux,
|
| 308 | 308 | dus_aux `plusDU` usesOnly (plusFNs fvs_insts)) } }
|
| ... | ... | @@ -1052,17 +1052,21 @@ cvtLocalDecs declDescr ds |
| 1052 | 1052 | ([], []) -> return (EmptyLocalBinds noExtField)
|
| 1053 | 1053 | ([], _) -> do
|
| 1054 | 1054 | ds' <- cvtDecs ds
|
| 1055 | - let (binds, prob_sigs) = partitionWith is_bind ds'
|
|
| 1056 | - let (sigs, bads) = partitionWith is_sig prob_sigs
|
|
| 1055 | + let (binds, bads) = partitionWith is_valbind ds'
|
|
| 1057 | 1056 | for_ (nonEmpty bads) $ \ bad_decls ->
|
| 1058 | 1057 | failWith (IllegalDeclaration declDescr $ IllegalDecls bad_decls)
|
| 1059 | - return (HsValBinds noAnn (ValBinds NoAnnSortKey binds sigs))
|
|
| 1058 | + return (HsValBinds noAnn (ValBinds noExtField binds))
|
|
| 1060 | 1059 | (ip_binds, []) -> do
|
| 1061 | 1060 | binds <- mapM (uncurry cvtImplicitParamBind) ip_binds
|
| 1062 | 1061 | return (HsIPBinds noAnn (IPBinds noExtField binds))
|
| 1063 | 1062 | ((_:_), (_:_)) ->
|
| 1064 | 1063 | failWith ImplicitParamsWithOtherBinds
|
| 1065 | 1064 | |
| 1065 | +is_valbind :: LHsDecl (GhcPass p) -> Either (ValBind (GhcPass p) (GhcPass p)) (LHsDecl (GhcPass p))
|
|
| 1066 | +is_valbind (L l (Hs.ValD _ b)) = Left (VbBind (L l b))
|
|
| 1067 | +is_valbind (L l (Hs.SigD _ s)) = Left (VbSig (L l s))
|
|
| 1068 | +is_valbind d = Right d
|
|
| 1069 | + |
|
| 1066 | 1070 | cvtClause :: HsMatchContextPs -> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))
|
| 1067 | 1071 | cvtClause ctxt (Clause ps body wheres)
|
| 1068 | 1072 | = do { ps' <- cvtPats ps
|
| ... | ... | @@ -31,6 +31,7 @@ import Language.Haskell.Syntax.ImpExp (NamespaceSpecifier) |
| 31 | 31 | |
| 32 | 32 | import Data.Bool
|
| 33 | 33 | import Data.Maybe
|
| 34 | +import Data.List
|
|
| 34 | 35 | |
| 35 | 36 | {-
|
| 36 | 37 | ************************************************************************
|
| ... | ... | @@ -96,7 +97,7 @@ data HsValBindsLR idL idR |
| 96 | 97 | -- Recursive by default
|
| 97 | 98 | ValBinds
|
| 98 | 99 | (XValBinds idL idR)
|
| 99 | - (LHsBindsLR idL idR) [LSig idR]
|
|
| 100 | + [ValBind idL idR]
|
|
| 100 | 101 | |
| 101 | 102 | -- | Value Bindings Out
|
| 102 | 103 | --
|
| ... | ... | @@ -105,6 +106,10 @@ data HsValBindsLR idL idR |
| 105 | 106 | | XValBindsLR
|
| 106 | 107 | !(XXValBindsLR idL idR)
|
| 107 | 108 | |
| 109 | +data ValBind idL idR
|
|
| 110 | + = VbBind (LHsBindLR idL idR)
|
|
| 111 | + | VbSig (LSig idR)
|
|
| 112 | + |
|
| 108 | 113 | -- ---------------------------------------------------------------------
|
| 109 | 114 | |
| 110 | 115 | -- | Located Haskell Binding
|
| ... | ... | @@ -243,6 +248,26 @@ data PatSynBind idL idR |
| 243 | 248 | }
|
| 244 | 249 | | XPatSynBind !(XXPatSynBind idL idR)
|
| 245 | 250 | |
| 251 | + |
|
| 252 | +val_binds :: [ValBind idL idR] -> [LHsBindLR idL idR]
|
|
| 253 | +val_binds binds = concatMap get_bind binds
|
|
| 254 | + where
|
|
| 255 | + get_bind (VbBind b) = [b]
|
|
| 256 | + get_bind (VbSig _) = []
|
|
| 257 | + |
|
| 258 | +val_sigs :: [ValBind idL idR] -> [LSig idR]
|
|
| 259 | +val_sigs binds = concatMap get_sig binds
|
|
| 260 | + where
|
|
| 261 | + get_sig (VbBind _) = []
|
|
| 262 | + get_sig (VbSig s) = [s]
|
|
| 263 | + |
|
| 264 | +val_binds_and_sigs :: [ValBind idL idR] -> ([LHsBindLR idL idR], [LSig idR])
|
|
| 265 | +val_binds_and_sigs binds = go binds [] []
|
|
| 266 | + where
|
|
| 267 | + go [] bs ss = (reverse bs, reverse ss)
|
|
| 268 | + go ((VbBind b):ds) bs ss = go ds (b:bs) ss
|
|
| 269 | + go ((VbSig s):ds) bs ss = go ds bs (s:ss)
|
|
| 270 | + |
|
| 246 | 271 | {-
|
| 247 | 272 | ************************************************************************
|
| 248 | 273 | * *
|
| ... | ... | @@ -205,6 +205,7 @@ type family XXHsLocalBindsLR x x' |
| 205 | 205 | -- HsValBindsLR type families
|
| 206 | 206 | type family XValBinds x x'
|
| 207 | 207 | type family XXValBindsLR x x'
|
| 208 | +type family XXValBinds x x'
|
|
| 208 | 209 | |
| 209 | 210 | -- HsBindLR type families
|
| 210 | 211 | type family XFunBind x x'
|
| ... | ... | @@ -1633,7 +1633,7 @@ runStmt input step = do |
| 1633 | 1633 | let
|
| 1634 | 1634 | la = L (noAnnSrcSpan loc)
|
| 1635 | 1635 | la' = L (noAnnSrcSpan loc)
|
| 1636 | - in la (LetStmt noAnn (HsValBinds noAnn (ValBinds NoAnnSortKey [la' bind] [])))
|
|
| 1636 | + in la (LetStmt noAnn (HsValBinds noAnn (ValBinds noExtField [VbBind $ la' bind])))
|
|
| 1637 | 1637 | |
| 1638 | 1638 | setDumpFilePrefix :: GHC.GhcMonad m => InteractiveContext -> m () -- #17500
|
| 1639 | 1639 | setDumpFilePrefix ic = do
|
| ... | ... | @@ -1915,220 +1915,221 @@ |
| 1915 | 1915 | (EpaComments
|
| 1916 | 1916 | []))
|
| 1917 | 1917 | (ValBinds
|
| 1918 | - (NoAnnSortKey)
|
|
| 1919 | - [(L
|
|
| 1920 | - (EpAnn
|
|
| 1921 | - (EpaSpan { DumpSemis.hs:34:19-21 })
|
|
| 1922 | - [(AddSemiAnn
|
|
| 1923 | - (EpTok
|
|
| 1924 | - (EpaSpan { DumpSemis.hs:34:22 })))
|
|
| 1925 | - ,(AddSemiAnn
|
|
| 1926 | - (EpTok
|
|
| 1927 | - (EpaSpan { DumpSemis.hs:34:23 })))]
|
|
| 1928 | - (EpaComments
|
|
| 1929 | - []))
|
|
| 1930 | - (FunBind
|
|
| 1931 | - (NoExtField)
|
|
| 1932 | - (L
|
|
| 1933 | - (EpAnn
|
|
| 1934 | - (EpaSpan { DumpSemis.hs:34:19 })
|
|
| 1935 | - (NameAnnTrailing
|
|
| 1936 | - [])
|
|
| 1937 | - (EpaComments
|
|
| 1938 | - []))
|
|
| 1939 | - (Unqual
|
|
| 1940 | - {OccName: y}))
|
|
| 1941 | - (MG
|
|
| 1942 | - ((,)
|
|
| 1943 | - (FromSource)
|
|
| 1944 | - (AnnList
|
|
| 1945 | - (Nothing)
|
|
| 1946 | - (ListNone)
|
|
| 1947 | - []
|
|
| 1948 | - (())
|
|
| 1949 | - []))
|
|
| 1918 | + (NoExtField)
|
|
| 1919 | + [(VbBind
|
|
| 1920 | + (L
|
|
| 1921 | + (EpAnn
|
|
| 1922 | + (EpaSpan { DumpSemis.hs:34:19-21 })
|
|
| 1923 | + [(AddSemiAnn
|
|
| 1924 | + (EpTok
|
|
| 1925 | + (EpaSpan { DumpSemis.hs:34:22 })))
|
|
| 1926 | + ,(AddSemiAnn
|
|
| 1927 | + (EpTok
|
|
| 1928 | + (EpaSpan { DumpSemis.hs:34:23 })))]
|
|
| 1929 | + (EpaComments
|
|
| 1930 | + []))
|
|
| 1931 | + (FunBind
|
|
| 1932 | + (NoExtField)
|
|
| 1950 | 1933 | (L
|
| 1951 | 1934 | (EpAnn
|
| 1952 | - (EpaSpan { DumpSemis.hs:34:19-21 })
|
|
| 1953 | - []
|
|
| 1935 | + (EpaSpan { DumpSemis.hs:34:19 })
|
|
| 1936 | + (NameAnnTrailing
|
|
| 1937 | + [])
|
|
| 1954 | 1938 | (EpaComments
|
| 1955 | 1939 | []))
|
| 1956 | - [(L
|
|
| 1957 | - (EpAnn
|
|
| 1958 | - (EpaSpan { DumpSemis.hs:34:19-21 })
|
|
| 1959 | - []
|
|
| 1960 | - (EpaComments
|
|
| 1961 | - []))
|
|
| 1962 | - (Match
|
|
| 1963 | - (NoExtField)
|
|
| 1964 | - (FunRhs
|
|
| 1965 | - (L
|
|
| 1966 | - (EpAnn
|
|
| 1967 | - (EpaSpan { DumpSemis.hs:34:19 })
|
|
| 1968 | - (NameAnnTrailing
|
|
| 1969 | - [])
|
|
| 1970 | - (EpaComments
|
|
| 1971 | - []))
|
|
| 1972 | - (Unqual
|
|
| 1973 | - {OccName: y}))
|
|
| 1974 | - (Prefix)
|
|
| 1975 | - (NoSrcStrict)
|
|
| 1976 | - (AnnFunRhs
|
|
| 1977 | - (NoEpTok)
|
|
| 1978 | - []
|
|
| 1979 | - []))
|
|
| 1980 | - (L
|
|
| 1981 | - (EpaSpan { <no location info> })
|
|
| 1982 | - [])
|
|
| 1983 | - (GRHSs
|
|
| 1940 | + (Unqual
|
|
| 1941 | + {OccName: y}))
|
|
| 1942 | + (MG
|
|
| 1943 | + ((,)
|
|
| 1944 | + (FromSource)
|
|
| 1945 | + (AnnList
|
|
| 1946 | + (Nothing)
|
|
| 1947 | + (ListNone)
|
|
| 1948 | + []
|
|
| 1949 | + (())
|
|
| 1950 | + []))
|
|
| 1951 | + (L
|
|
| 1952 | + (EpAnn
|
|
| 1953 | + (EpaSpan { DumpSemis.hs:34:19-21 })
|
|
| 1954 | + []
|
|
| 1955 | + (EpaComments
|
|
| 1956 | + []))
|
|
| 1957 | + [(L
|
|
| 1958 | + (EpAnn
|
|
| 1959 | + (EpaSpan { DumpSemis.hs:34:19-21 })
|
|
| 1960 | + []
|
|
| 1984 | 1961 | (EpaComments
|
| 1985 | - [])
|
|
| 1986 | - (:|
|
|
| 1962 | + []))
|
|
| 1963 | + (Match
|
|
| 1964 | + (NoExtField)
|
|
| 1965 | + (FunRhs
|
|
| 1987 | 1966 | (L
|
| 1988 | 1967 | (EpAnn
|
| 1989 | - (EpaSpan { DumpSemis.hs:34:20-21 })
|
|
| 1990 | - (NoEpAnns)
|
|
| 1968 | + (EpaSpan { DumpSemis.hs:34:19 })
|
|
| 1969 | + (NameAnnTrailing
|
|
| 1970 | + [])
|
|
| 1991 | 1971 | (EpaComments
|
| 1992 | 1972 | []))
|
| 1993 | - (GRHS
|
|
| 1973 | + (Unqual
|
|
| 1974 | + {OccName: y}))
|
|
| 1975 | + (Prefix)
|
|
| 1976 | + (NoSrcStrict)
|
|
| 1977 | + (AnnFunRhs
|
|
| 1978 | + (NoEpTok)
|
|
| 1979 | + []
|
|
| 1980 | + []))
|
|
| 1981 | + (L
|
|
| 1982 | + (EpaSpan { <no location info> })
|
|
| 1983 | + [])
|
|
| 1984 | + (GRHSs
|
|
| 1985 | + (EpaComments
|
|
| 1986 | + [])
|
|
| 1987 | + (:|
|
|
| 1988 | + (L
|
|
| 1994 | 1989 | (EpAnn
|
| 1995 | 1990 | (EpaSpan { DumpSemis.hs:34:20-21 })
|
| 1996 | - (GrhsAnn
|
|
| 1997 | - (Nothing)
|
|
| 1998 | - (Left
|
|
| 1999 | - (EpTok
|
|
| 2000 | - (EpaSpan { DumpSemis.hs:34:20 }))))
|
|
| 1991 | + (NoEpAnns)
|
|
| 2001 | 1992 | (EpaComments
|
| 2002 | 1993 | []))
|
| 2003 | - []
|
|
| 2004 | - (L
|
|
| 1994 | + (GRHS
|
|
| 2005 | 1995 | (EpAnn
|
| 2006 | - (EpaSpan { DumpSemis.hs:34:21 })
|
|
| 2007 | - []
|
|
| 1996 | + (EpaSpan { DumpSemis.hs:34:20-21 })
|
|
| 1997 | + (GrhsAnn
|
|
| 1998 | + (Nothing)
|
|
| 1999 | + (Left
|
|
| 2000 | + (EpTok
|
|
| 2001 | + (EpaSpan { DumpSemis.hs:34:20 }))))
|
|
| 2008 | 2002 | (EpaComments
|
| 2009 | 2003 | []))
|
| 2010 | - (HsOverLit
|
|
| 2011 | - (NoExtField)
|
|
| 2012 | - (OverLit
|
|
| 2004 | + []
|
|
| 2005 | + (L
|
|
| 2006 | + (EpAnn
|
|
| 2007 | + (EpaSpan { DumpSemis.hs:34:21 })
|
|
| 2008 | + []
|
|
| 2009 | + (EpaComments
|
|
| 2010 | + []))
|
|
| 2011 | + (HsOverLit
|
|
| 2013 | 2012 | (NoExtField)
|
| 2014 | - (HsIntegral
|
|
| 2015 | - (IL
|
|
| 2016 | - (SourceText 2)
|
|
| 2017 | - (False)
|
|
| 2018 | - (2))))))))
|
|
| 2019 | - [])
|
|
| 2020 | - (EmptyLocalBinds
|
|
| 2021 | - (NoExtField)))))]))))
|
|
| 2022 | - ,(L
|
|
| 2023 | - (EpAnn
|
|
| 2024 | - (EpaSpan { DumpSemis.hs:34:24-26 })
|
|
| 2025 | - [(AddSemiAnn
|
|
| 2026 | - (EpTok
|
|
| 2027 | - (EpaSpan { DumpSemis.hs:34:27 })))
|
|
| 2028 | - ,(AddSemiAnn
|
|
| 2029 | - (EpTok
|
|
| 2030 | - (EpaSpan { DumpSemis.hs:34:28 })))
|
|
| 2031 | - ,(AddSemiAnn
|
|
| 2032 | - (EpTok
|
|
| 2033 | - (EpaSpan { DumpSemis.hs:34:29 })))
|
|
| 2034 | - ,(AddSemiAnn
|
|
| 2035 | - (EpTok
|
|
| 2036 | - (EpaSpan { DumpSemis.hs:34:30 })))]
|
|
| 2037 | - (EpaComments
|
|
| 2038 | - []))
|
|
| 2039 | - (FunBind
|
|
| 2040 | - (NoExtField)
|
|
| 2041 | - (L
|
|
| 2042 | - (EpAnn
|
|
| 2043 | - (EpaSpan { DumpSemis.hs:34:24 })
|
|
| 2044 | - (NameAnnTrailing
|
|
| 2045 | - [])
|
|
| 2046 | - (EpaComments
|
|
| 2047 | - []))
|
|
| 2048 | - (Unqual
|
|
| 2049 | - {OccName: z}))
|
|
| 2050 | - (MG
|
|
| 2051 | - ((,)
|
|
| 2052 | - (FromSource)
|
|
| 2053 | - (AnnList
|
|
| 2054 | - (Nothing)
|
|
| 2055 | - (ListNone)
|
|
| 2056 | - []
|
|
| 2057 | - (())
|
|
| 2058 | - []))
|
|
| 2013 | + (OverLit
|
|
| 2014 | + (NoExtField)
|
|
| 2015 | + (HsIntegral
|
|
| 2016 | + (IL
|
|
| 2017 | + (SourceText 2)
|
|
| 2018 | + (False)
|
|
| 2019 | + (2))))))))
|
|
| 2020 | + [])
|
|
| 2021 | + (EmptyLocalBinds
|
|
| 2022 | + (NoExtField)))))])))))
|
|
| 2023 | + ,(VbBind
|
|
| 2024 | + (L
|
|
| 2025 | + (EpAnn
|
|
| 2026 | + (EpaSpan { DumpSemis.hs:34:24-26 })
|
|
| 2027 | + [(AddSemiAnn
|
|
| 2028 | + (EpTok
|
|
| 2029 | + (EpaSpan { DumpSemis.hs:34:27 })))
|
|
| 2030 | + ,(AddSemiAnn
|
|
| 2031 | + (EpTok
|
|
| 2032 | + (EpaSpan { DumpSemis.hs:34:28 })))
|
|
| 2033 | + ,(AddSemiAnn
|
|
| 2034 | + (EpTok
|
|
| 2035 | + (EpaSpan { DumpSemis.hs:34:29 })))
|
|
| 2036 | + ,(AddSemiAnn
|
|
| 2037 | + (EpTok
|
|
| 2038 | + (EpaSpan { DumpSemis.hs:34:30 })))]
|
|
| 2039 | + (EpaComments
|
|
| 2040 | + []))
|
|
| 2041 | + (FunBind
|
|
| 2042 | + (NoExtField)
|
|
| 2059 | 2043 | (L
|
| 2060 | 2044 | (EpAnn
|
| 2061 | - (EpaSpan { DumpSemis.hs:34:24-26 })
|
|
| 2062 | - []
|
|
| 2045 | + (EpaSpan { DumpSemis.hs:34:24 })
|
|
| 2046 | + (NameAnnTrailing
|
|
| 2047 | + [])
|
|
| 2063 | 2048 | (EpaComments
|
| 2064 | 2049 | []))
|
| 2065 | - [(L
|
|
| 2066 | - (EpAnn
|
|
| 2067 | - (EpaSpan { DumpSemis.hs:34:24-26 })
|
|
| 2068 | - []
|
|
| 2069 | - (EpaComments
|
|
| 2070 | - []))
|
|
| 2071 | - (Match
|
|
| 2072 | - (NoExtField)
|
|
| 2073 | - (FunRhs
|
|
| 2074 | - (L
|
|
| 2075 | - (EpAnn
|
|
| 2076 | - (EpaSpan { DumpSemis.hs:34:24 })
|
|
| 2077 | - (NameAnnTrailing
|
|
| 2078 | - [])
|
|
| 2079 | - (EpaComments
|
|
| 2080 | - []))
|
|
| 2081 | - (Unqual
|
|
| 2082 | - {OccName: z}))
|
|
| 2083 | - (Prefix)
|
|
| 2084 | - (NoSrcStrict)
|
|
| 2085 | - (AnnFunRhs
|
|
| 2086 | - (NoEpTok)
|
|
| 2087 | - []
|
|
| 2088 | - []))
|
|
| 2089 | - (L
|
|
| 2090 | - (EpaSpan { <no location info> })
|
|
| 2091 | - [])
|
|
| 2092 | - (GRHSs
|
|
| 2050 | + (Unqual
|
|
| 2051 | + {OccName: z}))
|
|
| 2052 | + (MG
|
|
| 2053 | + ((,)
|
|
| 2054 | + (FromSource)
|
|
| 2055 | + (AnnList
|
|
| 2056 | + (Nothing)
|
|
| 2057 | + (ListNone)
|
|
| 2058 | + []
|
|
| 2059 | + (())
|
|
| 2060 | + []))
|
|
| 2061 | + (L
|
|
| 2062 | + (EpAnn
|
|
| 2063 | + (EpaSpan { DumpSemis.hs:34:24-26 })
|
|
| 2064 | + []
|
|
| 2065 | + (EpaComments
|
|
| 2066 | + []))
|
|
| 2067 | + [(L
|
|
| 2068 | + (EpAnn
|
|
| 2069 | + (EpaSpan { DumpSemis.hs:34:24-26 })
|
|
| 2070 | + []
|
|
| 2093 | 2071 | (EpaComments
|
| 2094 | - [])
|
|
| 2095 | - (:|
|
|
| 2072 | + []))
|
|
| 2073 | + (Match
|
|
| 2074 | + (NoExtField)
|
|
| 2075 | + (FunRhs
|
|
| 2096 | 2076 | (L
|
| 2097 | 2077 | (EpAnn
|
| 2098 | - (EpaSpan { DumpSemis.hs:34:25-26 })
|
|
| 2099 | - (NoEpAnns)
|
|
| 2078 | + (EpaSpan { DumpSemis.hs:34:24 })
|
|
| 2079 | + (NameAnnTrailing
|
|
| 2080 | + [])
|
|
| 2100 | 2081 | (EpaComments
|
| 2101 | 2082 | []))
|
| 2102 | - (GRHS
|
|
| 2083 | + (Unqual
|
|
| 2084 | + {OccName: z}))
|
|
| 2085 | + (Prefix)
|
|
| 2086 | + (NoSrcStrict)
|
|
| 2087 | + (AnnFunRhs
|
|
| 2088 | + (NoEpTok)
|
|
| 2089 | + []
|
|
| 2090 | + []))
|
|
| 2091 | + (L
|
|
| 2092 | + (EpaSpan { <no location info> })
|
|
| 2093 | + [])
|
|
| 2094 | + (GRHSs
|
|
| 2095 | + (EpaComments
|
|
| 2096 | + [])
|
|
| 2097 | + (:|
|
|
| 2098 | + (L
|
|
| 2103 | 2099 | (EpAnn
|
| 2104 | 2100 | (EpaSpan { DumpSemis.hs:34:25-26 })
|
| 2105 | - (GrhsAnn
|
|
| 2106 | - (Nothing)
|
|
| 2107 | - (Left
|
|
| 2108 | - (EpTok
|
|
| 2109 | - (EpaSpan { DumpSemis.hs:34:25 }))))
|
|
| 2101 | + (NoEpAnns)
|
|
| 2110 | 2102 | (EpaComments
|
| 2111 | 2103 | []))
|
| 2112 | - []
|
|
| 2113 | - (L
|
|
| 2104 | + (GRHS
|
|
| 2114 | 2105 | (EpAnn
|
| 2115 | - (EpaSpan { DumpSemis.hs:34:26 })
|
|
| 2116 | - []
|
|
| 2106 | + (EpaSpan { DumpSemis.hs:34:25-26 })
|
|
| 2107 | + (GrhsAnn
|
|
| 2108 | + (Nothing)
|
|
| 2109 | + (Left
|
|
| 2110 | + (EpTok
|
|
| 2111 | + (EpaSpan { DumpSemis.hs:34:25 }))))
|
|
| 2117 | 2112 | (EpaComments
|
| 2118 | 2113 | []))
|
| 2119 | - (HsOverLit
|
|
| 2120 | - (NoExtField)
|
|
| 2121 | - (OverLit
|
|
| 2114 | + []
|
|
| 2115 | + (L
|
|
| 2116 | + (EpAnn
|
|
| 2117 | + (EpaSpan { DumpSemis.hs:34:26 })
|
|
| 2118 | + []
|
|
| 2119 | + (EpaComments
|
|
| 2120 | + []))
|
|
| 2121 | + (HsOverLit
|
|
| 2122 | 2122 | (NoExtField)
|
| 2123 | - (HsIntegral
|
|
| 2124 | - (IL
|
|
| 2125 | - (SourceText 3)
|
|
| 2126 | - (False)
|
|
| 2127 | - (3))))))))
|
|
| 2128 | - [])
|
|
| 2129 | - (EmptyLocalBinds
|
|
| 2130 | - (NoExtField)))))]))))]
|
|
| 2131 | - []))
|
|
| 2123 | + (OverLit
|
|
| 2124 | + (NoExtField)
|
|
| 2125 | + (HsIntegral
|
|
| 2126 | + (IL
|
|
| 2127 | + (SourceText 3)
|
|
| 2128 | + (False)
|
|
| 2129 | + (3))))))))
|
|
| 2130 | + [])
|
|
| 2131 | + (EmptyLocalBinds
|
|
| 2132 | + (NoExtField)))))])))))]))
|
|
| 2132 | 2133 | (L
|
| 2133 | 2134 | (EpAnn
|
| 2134 | 2135 | (EpaSpan { DumpSemis.hs:34:35 })
|
| ... | ... | @@ -166,8 +166,7 @@ |
| 166 | 166 | (EpaComments
|
| 167 | 167 | []))
|
| 168 | 168 | (ValBinds
|
| 169 | - (NoAnnSortKey)
|
|
| 170 | - []
|
|
| 169 | + (NoExtField)
|
|
| 171 | 170 | [])))))])))))
|
| 172 | 171 | ,(L
|
| 173 | 172 | (EpAnn
|
| ... | ... | @@ -295,142 +294,142 @@ |
| 295 | 294 | "-- comment2")
|
| 296 | 295 | { Test20297.hs:10:3-7 }))]))
|
| 297 | 296 | (ValBinds
|
| 298 | - (NoAnnSortKey)
|
|
| 299 | - [(L
|
|
| 300 | - (EpAnn
|
|
| 301 | - (EpaSpan { Test20297.hs:11:9-26 })
|
|
| 302 | - []
|
|
| 303 | - (EpaComments
|
|
| 304 | - []))
|
|
| 305 | - (FunBind
|
|
| 306 | - (NoExtField)
|
|
| 307 | - (L
|
|
| 308 | - (EpAnn
|
|
| 309 | - (EpaSpan { Test20297.hs:11:9-15 })
|
|
| 310 | - (NameAnnTrailing
|
|
| 311 | - [])
|
|
| 312 | - (EpaComments
|
|
| 313 | - []))
|
|
| 314 | - (Unqual
|
|
| 315 | - {OccName: doStuff}))
|
|
| 316 | - (MG
|
|
| 317 | - ((,)
|
|
| 318 | - (FromSource)
|
|
| 319 | - (AnnList
|
|
| 320 | - (Nothing)
|
|
| 321 | - (ListNone)
|
|
| 322 | - []
|
|
| 323 | - (())
|
|
| 324 | - []))
|
|
| 297 | + (NoExtField)
|
|
| 298 | + [(VbBind
|
|
| 299 | + (L
|
|
| 300 | + (EpAnn
|
|
| 301 | + (EpaSpan { Test20297.hs:11:9-26 })
|
|
| 302 | + []
|
|
| 303 | + (EpaComments
|
|
| 304 | + []))
|
|
| 305 | + (FunBind
|
|
| 306 | + (NoExtField)
|
|
| 325 | 307 | (L
|
| 326 | 308 | (EpAnn
|
| 327 | - (EpaSpan { Test20297.hs:11:9-26 })
|
|
| 328 | - []
|
|
| 309 | + (EpaSpan { Test20297.hs:11:9-15 })
|
|
| 310 | + (NameAnnTrailing
|
|
| 311 | + [])
|
|
| 329 | 312 | (EpaComments
|
| 330 | 313 | []))
|
| 331 | - [(L
|
|
| 332 | - (EpAnn
|
|
| 333 | - (EpaSpan { Test20297.hs:11:9-26 })
|
|
| 334 | - []
|
|
| 335 | - (EpaComments
|
|
| 336 | - []))
|
|
| 337 | - (Match
|
|
| 338 | - (NoExtField)
|
|
| 339 | - (FunRhs
|
|
| 340 | - (L
|
|
| 341 | - (EpAnn
|
|
| 342 | - (EpaSpan { Test20297.hs:11:9-15 })
|
|
| 343 | - (NameAnnTrailing
|
|
| 344 | - [])
|
|
| 345 | - (EpaComments
|
|
| 346 | - []))
|
|
| 347 | - (Unqual
|
|
| 348 | - {OccName: doStuff}))
|
|
| 349 | - (Prefix)
|
|
| 350 | - (NoSrcStrict)
|
|
| 351 | - (AnnFunRhs
|
|
| 352 | - (NoEpTok)
|
|
| 353 | - []
|
|
| 354 | - []))
|
|
| 355 | - (L
|
|
| 356 | - (EpaSpan { <no location info> })
|
|
| 357 | - [])
|
|
| 358 | - (GRHSs
|
|
| 314 | + (Unqual
|
|
| 315 | + {OccName: doStuff}))
|
|
| 316 | + (MG
|
|
| 317 | + ((,)
|
|
| 318 | + (FromSource)
|
|
| 319 | + (AnnList
|
|
| 320 | + (Nothing)
|
|
| 321 | + (ListNone)
|
|
| 322 | + []
|
|
| 323 | + (())
|
|
| 324 | + []))
|
|
| 325 | + (L
|
|
| 326 | + (EpAnn
|
|
| 327 | + (EpaSpan { Test20297.hs:11:9-26 })
|
|
| 328 | + []
|
|
| 329 | + (EpaComments
|
|
| 330 | + []))
|
|
| 331 | + [(L
|
|
| 332 | + (EpAnn
|
|
| 333 | + (EpaSpan { Test20297.hs:11:9-26 })
|
|
| 334 | + []
|
|
| 359 | 335 | (EpaComments
|
| 360 | - [])
|
|
| 361 | - (:|
|
|
| 336 | + []))
|
|
| 337 | + (Match
|
|
| 338 | + (NoExtField)
|
|
| 339 | + (FunRhs
|
|
| 362 | 340 | (L
|
| 363 | 341 | (EpAnn
|
| 364 | - (EpaSpan { Test20297.hs:11:17-26 })
|
|
| 365 | - (NoEpAnns)
|
|
| 342 | + (EpaSpan { Test20297.hs:11:9-15 })
|
|
| 343 | + (NameAnnTrailing
|
|
| 344 | + [])
|
|
| 366 | 345 | (EpaComments
|
| 367 | 346 | []))
|
| 368 | - (GRHS
|
|
| 347 | + (Unqual
|
|
| 348 | + {OccName: doStuff}))
|
|
| 349 | + (Prefix)
|
|
| 350 | + (NoSrcStrict)
|
|
| 351 | + (AnnFunRhs
|
|
| 352 | + (NoEpTok)
|
|
| 353 | + []
|
|
| 354 | + []))
|
|
| 355 | + (L
|
|
| 356 | + (EpaSpan { <no location info> })
|
|
| 357 | + [])
|
|
| 358 | + (GRHSs
|
|
| 359 | + (EpaComments
|
|
| 360 | + [])
|
|
| 361 | + (:|
|
|
| 362 | + (L
|
|
| 369 | 363 | (EpAnn
|
| 370 | 364 | (EpaSpan { Test20297.hs:11:17-26 })
|
| 371 | - (GrhsAnn
|
|
| 372 | - (Nothing)
|
|
| 373 | - (Left
|
|
| 374 | - (EpTok
|
|
| 375 | - (EpaSpan { Test20297.hs:11:17 }))))
|
|
| 365 | + (NoEpAnns)
|
|
| 376 | 366 | (EpaComments
|
| 377 | 367 | []))
|
| 378 | - []
|
|
| 379 | - (L
|
|
| 368 | + (GRHS
|
|
| 380 | 369 | (EpAnn
|
| 381 | - (EpaSpan { Test20297.hs:11:19-26 })
|
|
| 382 | - []
|
|
| 370 | + (EpaSpan { Test20297.hs:11:17-26 })
|
|
| 371 | + (GrhsAnn
|
|
| 372 | + (Nothing)
|
|
| 373 | + (Left
|
|
| 374 | + (EpTok
|
|
| 375 | + (EpaSpan { Test20297.hs:11:17 }))))
|
|
| 383 | 376 | (EpaComments
|
| 384 | 377 | []))
|
| 385 | - (HsDo
|
|
| 386 | - (AnnList
|
|
| 387 | - (Just
|
|
| 388 | - (EpaSpan { Test20297.hs:11:22-26 }))
|
|
| 389 | - (ListBraces
|
|
| 390 | - (NoEpTok)
|
|
| 391 | - (NoEpTok))
|
|
| 378 | + []
|
|
| 379 | + (L
|
|
| 380 | + (EpAnn
|
|
| 381 | + (EpaSpan { Test20297.hs:11:19-26 })
|
|
| 392 | 382 | []
|
| 393 | - (EpaSpan { Test20297.hs:11:19-20 })
|
|
| 394 | - [])
|
|
| 395 | - (DoExpr
|
|
| 396 | - (Nothing))
|
|
| 397 | - (L
|
|
| 398 | - (EpAnn
|
|
| 399 | - (EpaSpan { Test20297.hs:11:22-26 })
|
|
| 383 | + (EpaComments
|
|
| 384 | + []))
|
|
| 385 | + (HsDo
|
|
| 386 | + (AnnList
|
|
| 387 | + (Just
|
|
| 388 | + (EpaSpan { Test20297.hs:11:22-26 }))
|
|
| 389 | + (ListBraces
|
|
| 390 | + (NoEpTok)
|
|
| 391 | + (NoEpTok))
|
|
| 400 | 392 | []
|
| 401 | - (EpaComments
|
|
| 402 | - []))
|
|
| 403 | - [(L
|
|
| 404 | - (EpAnn
|
|
| 405 | - (EpaSpan { Test20297.hs:11:22-26 })
|
|
| 406 | - []
|
|
| 407 | - (EpaComments
|
|
| 408 | - []))
|
|
| 409 | - (BodyStmt
|
|
| 410 | - (NoExtField)
|
|
| 411 | - (L
|
|
| 412 | - (EpAnn
|
|
| 413 | - (EpaSpan { Test20297.hs:11:22-26 })
|
|
| 414 | - []
|
|
| 415 | - (EpaComments
|
|
| 416 | - []))
|
|
| 417 | - (HsVar
|
|
| 418 | - (NoExtField)
|
|
| 419 | - (L
|
|
| 420 | - (EpAnn
|
|
| 421 | - (EpaSpan { Test20297.hs:11:22-26 })
|
|
| 422 | - (NameAnnTrailing
|
|
| 423 | - [])
|
|
| 424 | - (EpaComments
|
|
| 425 | - []))
|
|
| 426 | - (Unqual
|
|
| 427 | - {OccName: stuff}))))
|
|
| 428 | - (NoExtField)
|
|
| 429 | - (NoExtField)))])))))
|
|
| 430 | - [])
|
|
| 431 | - (EmptyLocalBinds
|
|
| 432 | - (NoExtField)))))]))))]
|
|
| 433 | - [])))))])))))]))
|
|
| 393 | + (EpaSpan { Test20297.hs:11:19-20 })
|
|
| 394 | + [])
|
|
| 395 | + (DoExpr
|
|
| 396 | + (Nothing))
|
|
| 397 | + (L
|
|
| 398 | + (EpAnn
|
|
| 399 | + (EpaSpan { Test20297.hs:11:22-26 })
|
|
| 400 | + []
|
|
| 401 | + (EpaComments
|
|
| 402 | + []))
|
|
| 403 | + [(L
|
|
| 404 | + (EpAnn
|
|
| 405 | + (EpaSpan { Test20297.hs:11:22-26 })
|
|
| 406 | + []
|
|
| 407 | + (EpaComments
|
|
| 408 | + []))
|
|
| 409 | + (BodyStmt
|
|
| 410 | + (NoExtField)
|
|
| 411 | + (L
|
|
| 412 | + (EpAnn
|
|
| 413 | + (EpaSpan { Test20297.hs:11:22-26 })
|
|
| 414 | + []
|
|
| 415 | + (EpaComments
|
|
| 416 | + []))
|
|
| 417 | + (HsVar
|
|
| 418 | + (NoExtField)
|
|
| 419 | + (L
|
|
| 420 | + (EpAnn
|
|
| 421 | + (EpaSpan { Test20297.hs:11:22-26 })
|
|
| 422 | + (NameAnnTrailing
|
|
| 423 | + [])
|
|
| 424 | + (EpaComments
|
|
| 425 | + []))
|
|
| 426 | + (Unqual
|
|
| 427 | + {OccName: stuff}))))
|
|
| 428 | + (NoExtField)
|
|
| 429 | + (NoExtField)))])))))
|
|
| 430 | + [])
|
|
| 431 | + (EmptyLocalBinds
|
|
| 432 | + (NoExtField)))))])))))])))))])))))]))
|
|
| 434 | 433 | |
| 435 | 434 | |
| 436 | 435 | |
| ... | ... | @@ -595,8 +594,7 @@ |
| 595 | 594 | (EpaComments
|
| 596 | 595 | []))
|
| 597 | 596 | (ValBinds
|
| 598 | - (NoAnnSortKey)
|
|
| 599 | - []
|
|
| 597 | + (NoExtField)
|
|
| 600 | 598 | [])))))])))))
|
| 601 | 599 | ,(L
|
| 602 | 600 | (EpAnn
|
| ... | ... | @@ -712,141 +710,141 @@ |
| 712 | 710 | (EpaComments
|
| 713 | 711 | []))
|
| 714 | 712 | (ValBinds
|
| 715 | - (NoAnnSortKey)
|
|
| 716 | - [(L
|
|
| 717 | - (EpAnn
|
|
| 718 | - (EpaSpan { Test20297.ppr.hs:9:7-24 })
|
|
| 719 | - []
|
|
| 720 | - (EpaComments
|
|
| 721 | - []))
|
|
| 722 | - (FunBind
|
|
| 723 | - (NoExtField)
|
|
| 724 | - (L
|
|
| 725 | - (EpAnn
|
|
| 726 | - (EpaSpan { Test20297.ppr.hs:9:7-13 })
|
|
| 727 | - (NameAnnTrailing
|
|
| 728 | - [])
|
|
| 729 | - (EpaComments
|
|
| 730 | - []))
|
|
| 731 | - (Unqual
|
|
| 732 | - {OccName: doStuff}))
|
|
| 733 | - (MG
|
|
| 734 | - ((,)
|
|
| 735 | - (FromSource)
|
|
| 736 | - (AnnList
|
|
| 737 | - (Nothing)
|
|
| 738 | - (ListNone)
|
|
| 739 | - []
|
|
| 740 | - (())
|
|
| 741 | - []))
|
|
| 713 | + (NoExtField)
|
|
| 714 | + [(VbBind
|
|
| 715 | + (L
|
|
| 716 | + (EpAnn
|
|
| 717 | + (EpaSpan { Test20297.ppr.hs:9:7-24 })
|
|
| 718 | + []
|
|
| 719 | + (EpaComments
|
|
| 720 | + []))
|
|
| 721 | + (FunBind
|
|
| 722 | + (NoExtField)
|
|
| 742 | 723 | (L
|
| 743 | 724 | (EpAnn
|
| 744 | - (EpaSpan { Test20297.ppr.hs:9:7-24 })
|
|
| 745 | - []
|
|
| 725 | + (EpaSpan { Test20297.ppr.hs:9:7-13 })
|
|
| 726 | + (NameAnnTrailing
|
|
| 727 | + [])
|
|
| 746 | 728 | (EpaComments
|
| 747 | 729 | []))
|
| 748 | - [(L
|
|
| 749 | - (EpAnn
|
|
| 750 | - (EpaSpan { Test20297.ppr.hs:9:7-24 })
|
|
| 751 | - []
|
|
| 752 | - (EpaComments
|
|
| 753 | - []))
|
|
| 754 | - (Match
|
|
| 755 | - (NoExtField)
|
|
| 756 | - (FunRhs
|
|
| 757 | - (L
|
|
| 758 | - (EpAnn
|
|
| 759 | - (EpaSpan { Test20297.ppr.hs:9:7-13 })
|
|
| 760 | - (NameAnnTrailing
|
|
| 761 | - [])
|
|
| 762 | - (EpaComments
|
|
| 763 | - []))
|
|
| 764 | - (Unqual
|
|
| 765 | - {OccName: doStuff}))
|
|
| 766 | - (Prefix)
|
|
| 767 | - (NoSrcStrict)
|
|
| 768 | - (AnnFunRhs
|
|
| 769 | - (NoEpTok)
|
|
| 770 | - []
|
|
| 771 | - []))
|
|
| 772 | - (L
|
|
| 773 | - (EpaSpan { <no location info> })
|
|
| 774 | - [])
|
|
| 775 | - (GRHSs
|
|
| 730 | + (Unqual
|
|
| 731 | + {OccName: doStuff}))
|
|
| 732 | + (MG
|
|
| 733 | + ((,)
|
|
| 734 | + (FromSource)
|
|
| 735 | + (AnnList
|
|
| 736 | + (Nothing)
|
|
| 737 | + (ListNone)
|
|
| 738 | + []
|
|
| 739 | + (())
|
|
| 740 | + []))
|
|
| 741 | + (L
|
|
| 742 | + (EpAnn
|
|
| 743 | + (EpaSpan { Test20297.ppr.hs:9:7-24 })
|
|
| 744 | + []
|
|
| 745 | + (EpaComments
|
|
| 746 | + []))
|
|
| 747 | + [(L
|
|
| 748 | + (EpAnn
|
|
| 749 | + (EpaSpan { Test20297.ppr.hs:9:7-24 })
|
|
| 750 | + []
|
|
| 776 | 751 | (EpaComments
|
| 777 | - [])
|
|
| 778 | - (:|
|
|
| 752 | + []))
|
|
| 753 | + (Match
|
|
| 754 | + (NoExtField)
|
|
| 755 | + (FunRhs
|
|
| 779 | 756 | (L
|
| 780 | 757 | (EpAnn
|
| 781 | - (EpaSpan { Test20297.ppr.hs:9:15-24 })
|
|
| 782 | - (NoEpAnns)
|
|
| 758 | + (EpaSpan { Test20297.ppr.hs:9:7-13 })
|
|
| 759 | + (NameAnnTrailing
|
|
| 760 | + [])
|
|
| 783 | 761 | (EpaComments
|
| 784 | 762 | []))
|
| 785 | - (GRHS
|
|
| 763 | + (Unqual
|
|
| 764 | + {OccName: doStuff}))
|
|
| 765 | + (Prefix)
|
|
| 766 | + (NoSrcStrict)
|
|
| 767 | + (AnnFunRhs
|
|
| 768 | + (NoEpTok)
|
|
| 769 | + []
|
|
| 770 | + []))
|
|
| 771 | + (L
|
|
| 772 | + (EpaSpan { <no location info> })
|
|
| 773 | + [])
|
|
| 774 | + (GRHSs
|
|
| 775 | + (EpaComments
|
|
| 776 | + [])
|
|
| 777 | + (:|
|
|
| 778 | + (L
|
|
| 786 | 779 | (EpAnn
|
| 787 | 780 | (EpaSpan { Test20297.ppr.hs:9:15-24 })
|
| 788 | - (GrhsAnn
|
|
| 789 | - (Nothing)
|
|
| 790 | - (Left
|
|
| 791 | - (EpTok
|
|
| 792 | - (EpaSpan { Test20297.ppr.hs:9:15 }))))
|
|
| 781 | + (NoEpAnns)
|
|
| 793 | 782 | (EpaComments
|
| 794 | 783 | []))
|
| 795 | - []
|
|
| 796 | - (L
|
|
| 784 | + (GRHS
|
|
| 797 | 785 | (EpAnn
|
| 798 | - (EpaSpan { Test20297.ppr.hs:9:17-24 })
|
|
| 799 | - []
|
|
| 786 | + (EpaSpan { Test20297.ppr.hs:9:15-24 })
|
|
| 787 | + (GrhsAnn
|
|
| 788 | + (Nothing)
|
|
| 789 | + (Left
|
|
| 790 | + (EpTok
|
|
| 791 | + (EpaSpan { Test20297.ppr.hs:9:15 }))))
|
|
| 800 | 792 | (EpaComments
|
| 801 | 793 | []))
|
| 802 | - (HsDo
|
|
| 803 | - (AnnList
|
|
| 804 | - (Just
|
|
| 805 | - (EpaSpan { Test20297.ppr.hs:9:20-24 }))
|
|
| 806 | - (ListBraces
|
|
| 807 | - (NoEpTok)
|
|
| 808 | - (NoEpTok))
|
|
| 794 | + []
|
|
| 795 | + (L
|
|
| 796 | + (EpAnn
|
|
| 797 | + (EpaSpan { Test20297.ppr.hs:9:17-24 })
|
|
| 809 | 798 | []
|
| 810 | - (EpaSpan { Test20297.ppr.hs:9:17-18 })
|
|
| 811 | - [])
|
|
| 812 | - (DoExpr
|
|
| 813 | - (Nothing))
|
|
| 814 | - (L
|
|
| 815 | - (EpAnn
|
|
| 816 | - (EpaSpan { Test20297.ppr.hs:9:20-24 })
|
|
| 799 | + (EpaComments
|
|
| 800 | + []))
|
|
| 801 | + (HsDo
|
|
| 802 | + (AnnList
|
|
| 803 | + (Just
|
|
| 804 | + (EpaSpan { Test20297.ppr.hs:9:20-24 }))
|
|
| 805 | + (ListBraces
|
|
| 806 | + (NoEpTok)
|
|
| 807 | + (NoEpTok))
|
|
| 817 | 808 | []
|
| 818 | - (EpaComments
|
|
| 819 | - []))
|
|
| 820 | - [(L
|
|
| 821 | - (EpAnn
|
|
| 822 | - (EpaSpan { Test20297.ppr.hs:9:20-24 })
|
|
| 823 | - []
|
|
| 824 | - (EpaComments
|
|
| 825 | - []))
|
|
| 826 | - (BodyStmt
|
|
| 827 | - (NoExtField)
|
|
| 828 | - (L
|
|
| 829 | - (EpAnn
|
|
| 830 | - (EpaSpan { Test20297.ppr.hs:9:20-24 })
|
|
| 831 | - []
|
|
| 832 | - (EpaComments
|
|
| 833 | - []))
|
|
| 834 | - (HsVar
|
|
| 835 | - (NoExtField)
|
|
| 836 | - (L
|
|
| 837 | - (EpAnn
|
|
| 838 | - (EpaSpan { Test20297.ppr.hs:9:20-24 })
|
|
| 839 | - (NameAnnTrailing
|
|
| 840 | - [])
|
|
| 841 | - (EpaComments
|
|
| 842 | - []))
|
|
| 843 | - (Unqual
|
|
| 844 | - {OccName: stuff}))))
|
|
| 845 | - (NoExtField)
|
|
| 846 | - (NoExtField)))])))))
|
|
| 847 | - [])
|
|
| 848 | - (EmptyLocalBinds
|
|
| 849 | - (NoExtField)))))]))))]
|
|
| 850 | - [])))))])))))]))
|
|
| 809 | + (EpaSpan { Test20297.ppr.hs:9:17-18 })
|
|
| 810 | + [])
|
|
| 811 | + (DoExpr
|
|
| 812 | + (Nothing))
|
|
| 813 | + (L
|
|
| 814 | + (EpAnn
|
|
| 815 | + (EpaSpan { Test20297.ppr.hs:9:20-24 })
|
|
| 816 | + []
|
|
| 817 | + (EpaComments
|
|
| 818 | + []))
|
|
| 819 | + [(L
|
|
| 820 | + (EpAnn
|
|
| 821 | + (EpaSpan { Test20297.ppr.hs:9:20-24 })
|
|
| 822 | + []
|
|
| 823 | + (EpaComments
|
|
| 824 | + []))
|
|
| 825 | + (BodyStmt
|
|
| 826 | + (NoExtField)
|
|
| 827 | + (L
|
|
| 828 | + (EpAnn
|
|
| 829 | + (EpaSpan { Test20297.ppr.hs:9:20-24 })
|
|
| 830 | + []
|
|
| 831 | + (EpaComments
|
|
| 832 | + []))
|
|
| 833 | + (HsVar
|
|
| 834 | + (NoExtField)
|
|
| 835 | + (L
|
|
| 836 | + (EpAnn
|
|
| 837 | + (EpaSpan { Test20297.ppr.hs:9:20-24 })
|
|
| 838 | + (NameAnnTrailing
|
|
| 839 | + [])
|
|
| 840 | + (EpaComments
|
|
| 841 | + []))
|
|
| 842 | + (Unqual
|
|
| 843 | + {OccName: stuff}))))
|
|
| 844 | + (NoExtField)
|
|
| 845 | + (NoExtField)))])))))
|
|
| 846 | + [])
|
|
| 847 | + (EmptyLocalBinds
|
|
| 848 | + (NoExtField)))))])))))])))))])))))]))
|
|
| 851 | 849 | |
| 852 | 850 |
| ... | ... | @@ -2523,15 +2523,18 @@ instance ExactPrint (HsValBindsLR GhcPs GhcPs) where |
| 2523 | 2523 | getAnnotationEntry _ = NoEntryVal
|
| 2524 | 2524 | setAnnotationAnchor a _ _ _ = a
|
| 2525 | 2525 | |
| 2526 | - exact (ValBinds sortKey binds sigs) = do
|
|
| 2527 | - decls <- setLayoutBoth $ mapM markAnnotated $ hsDeclsValBinds (ValBinds sortKey binds sigs)
|
|
| 2528 | - let
|
|
| 2529 | - binds' = concatMap decl2Bind decls
|
|
| 2530 | - sigs' = concatMap decl2Sig decls
|
|
| 2531 | - sortKey' = captureOrderBinds decls
|
|
| 2532 | - return (ValBinds sortKey' binds' sigs')
|
|
| 2526 | + exact (ValBinds sortKey bs) = do
|
|
| 2527 | + bs' <- mapM markAnnotated bs
|
|
| 2528 | + return (ValBinds sortKey bs')
|
|
| 2533 | 2529 | exact (XValBindsLR _) = panic "XValBindsLR"
|
| 2534 | 2530 | |
| 2531 | +instance ExactPrint (ValBind GhcPs GhcPs) where
|
|
| 2532 | + getAnnotationEntry _ = NoEntryVal
|
|
| 2533 | + setAnnotationAnchor a _ _ _ = a
|
|
| 2534 | + |
|
| 2535 | + exact (VbBind b) = VbBind <$> markAnnotated b
|
|
| 2536 | + exact (VbSig s) = VbSig <$> markAnnotated s
|
|
| 2537 | + |
|
| 2535 | 2538 | undynamic :: Typeable a => [Dynamic] -> [a]
|
| 2536 | 2539 | undynamic ds = mapMaybe fromDynamic ds
|
| 2537 | 2540 |
| ... | ... | @@ -11,9 +11,11 @@ |
| 11 | 11 | |
| 12 | 12 | import Data.Data
|
| 13 | 13 | import Data.List (intercalate)
|
| 14 | +-- import Language.Haskell.Syntax.Binds
|
|
| 14 | 15 | import GHC hiding (moduleName)
|
| 15 | 16 | import GHC.Driver.Ppr
|
| 16 | 17 | import GHC.Hs.Dump
|
| 18 | +import GHC.Parser.PostProcess ( wrapValBind )
|
|
| 17 | 19 | import GHC.Types.Name.Occurrence
|
| 18 | 20 | import GHC.Types.Name.Reader
|
| 19 | 21 | import GHC.Utils.Error
|
| ... | ... | @@ -447,15 +449,15 @@ changeLetIn1 _libdir parsed |
| 447 | 449 | replace :: HsExpr GhcPs -> HsExpr GhcPs
|
| 448 | 450 | replace (HsLet (tkLet, _) localDecls expr)
|
| 449 | 451 | =
|
| 450 | - let (HsValBinds x (ValBinds xv decls sigs)) = localDecls
|
|
| 451 | - [l2,_l1] = map wrapDecl decls
|
|
| 452 | - decls' = concatMap decl2Bind [l2]
|
|
| 452 | + let (HsValBinds x (ValBinds xv bs)) = localDecls
|
|
| 453 | + [l2,_l1] = bs
|
|
| 454 | + decls' = [l2]
|
|
| 453 | 455 | (L _ e) = expr
|
| 454 | 456 | a = EpAnn (EpaDelta noSrcSpan (SameLine 1) []) noAnn emptyComments
|
| 455 | 457 | expr' = L a e
|
| 456 | 458 | tkIn' = EpTok (EpaDelta noSrcSpan (DifferentLine 1 0) [])
|
| 457 | 459 | in (HsLet (tkLet, tkIn')
|
| 458 | - (HsValBinds x (ValBinds xv decls' sigs)) expr')
|
|
| 460 | + (HsValBinds x (ValBinds xv decls')) expr')
|
|
| 459 | 461 | |
| 460 | 462 | replace x = x
|
| 461 | 463 | |
| ... | ... | @@ -508,27 +510,24 @@ changeAddDecl3 libdir top = do |
| 508 | 510 | -- | Add a local declaration with signature to LocalDecl
|
| 509 | 511 | changeLocalDecls :: Changer
|
| 510 | 512 | changeLocalDecls libdir (L l p) = do
|
| 511 | - Right s@(L ls (SigD _ sig)) <- withDynFlags libdir (\df -> parseDecl df "sig" "nn :: Int")
|
|
| 512 | - Right d@(L ld (ValD _ decl)) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2")
|
|
| 513 | + Right (L ls (SigD _ sig)) <- withDynFlags libdir (\df -> parseDecl df "sig" "nn :: Int")
|
|
| 514 | + Right (L ld (ValD _ decl)) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2")
|
|
| 513 | 515 | let decl' = setEntryDP (L ld decl) (DifferentLine 1 0)
|
| 514 | 516 | let sig' = setEntryDP (L ls sig) (SameLine 0)
|
| 515 | 517 | let (p',_,_w) = runTransform doAddLocal
|
| 516 | 518 | doAddLocal = everywhereM (mkM replaceLocalBinds) p
|
| 517 | 519 | replaceLocalBinds :: LMatch GhcPs (LHsExpr GhcPs)
|
| 518 | 520 | -> Transform (LMatch GhcPs (LHsExpr GhcPs))
|
| 519 | - replaceLocalBinds (L lm (Match an mln pats (GRHSs _ rhs (HsValBinds van (ValBinds _ binds sigs))))) = do
|
|
| 520 | - let oldDecls = sortLocatedA $ map wrapDecl binds ++ map wrapSig sigs
|
|
| 521 | - let decls = s:d:oldDecls
|
|
| 521 | + replaceLocalBinds (L lm (Match an mln pats (GRHSs _ rhs (HsValBinds van (ValBinds _ bs))))) = do
|
|
| 522 | + let (oldDecls) = map unWrapValBind bs
|
|
| 523 | + -- let decls = s:d:oldDecls
|
|
| 522 | 524 | let oldDecls' = captureLineSpacing oldDecls
|
| 523 | - let oldBinds = concatMap decl2Bind oldDecls'
|
|
| 524 | - (os:oldSigs) = concatMap decl2Sig oldDecls'
|
|
| 525 | - os' = setEntryDP os (DifferentLine 2 0)
|
|
| 526 | - let sortKey = captureOrderBinds decls
|
|
| 525 | + let (VbSig o:oldBinds) = map wrapValBind oldDecls'
|
|
| 526 | + o' = setEntryDP o (DifferentLine 2 0)
|
|
| 527 | 527 | let (EpAnn anc (AnnList (Just _) a b c dd) cs) = van
|
| 528 | 528 | let van' = (EpAnn anc (AnnList (Just (EpaDelta noSrcSpan (DifferentLine 1 4) [])) a b c dd) cs)
|
| 529 | 529 | let binds' = (HsValBinds van'
|
| 530 | - (ValBinds sortKey (decl':oldBinds)
|
|
| 531 | - (sig':os':oldSigs)))
|
|
| 530 | + (ValBinds noExtField (VbSig sig':VbBind decl':VbSig o':oldBinds)))
|
|
| 532 | 531 | return (L lm (Match an mln pats (GRHSs emptyComments rhs binds')))
|
| 533 | 532 | `debug` ("oldDecls=" ++ showAst oldDecls)
|
| 534 | 533 | replaceLocalBinds x = return x
|
| ... | ... | @@ -540,8 +539,8 @@ changeLocalDecls libdir (L l p) = do |
| 540 | 539 | -- prior local decl. So it adds a "where" annotation.
|
| 541 | 540 | changeLocalDecls2 :: Changer
|
| 542 | 541 | changeLocalDecls2 libdir (L l p) = do
|
| 543 | - Right d@(L ld (ValD _ decl)) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2")
|
|
| 544 | - Right s@(L ls (SigD _ sig)) <- withDynFlags libdir (\df -> parseDecl df "sig" "nn :: Int")
|
|
| 542 | + Right (L ld (ValD _ decl)) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2")
|
|
| 543 | + Right (L ls (SigD _ sig)) <- withDynFlags libdir (\df -> parseDecl df "sig" "nn :: Int")
|
|
| 545 | 544 | let decl' = setEntryDP (L ld decl) (DifferentLine 1 0)
|
| 546 | 545 | let sig' = setEntryDP (L ls sig) (SameLine 2)
|
| 547 | 546 | let (p',_,_w) = runTransform doAddLocal
|
| ... | ... | @@ -557,10 +556,8 @@ changeLocalDecls2 libdir (L l p) = do |
| 557 | 556 | (EpTok (EpaDelta noSrcSpan (SameLine 0) []))
|
| 558 | 557 | [])
|
| 559 | 558 | emptyComments
|
| 560 | - let decls = [s,d]
|
|
| 561 | - let sortKey = captureOrderBinds decls
|
|
| 562 | - let binds = (HsValBinds an (ValBinds sortKey [decl']
|
|
| 563 | - [sig']))
|
|
| 559 | + let decls = [VbSig sig', VbBind decl']
|
|
| 560 | + let binds = (HsValBinds an (ValBinds noExtField decls))
|
|
| 564 | 561 | return (L lm (Match ma mln pats (GRHSs emptyComments rhs binds)))
|
| 565 | 562 | replaceLocalBinds x = return x
|
| 566 | 563 | return (L l p')
|
| ... | ... | @@ -68,7 +68,6 @@ module Transform |
| 68 | 68 | , addModuleCommentOrigDeltas
|
| 69 | 69 | |
| 70 | 70 | -- ** Managing lists, pure functions
|
| 71 | - , captureOrderBinds
|
|
| 72 | 71 | , captureLineSpacing
|
| 73 | 72 | , captureMatchLineSpacing
|
| 74 | 73 | , captureTypeSigSpacing
|
| ... | ... | @@ -92,6 +91,7 @@ import Control.Monad.RWS |
| 92 | 91 | import qualified Control.Monad.Fail as Fail
|
| 93 | 92 | |
| 94 | 93 | import GHC hiding (parseModule, parsedSource)
|
| 94 | +import GHC.Parser.PostProcess ( wrapValBind )
|
|
| 95 | 95 | import GHC.Data.FastString
|
| 96 | 96 | import GHC.Types.SrcLoc
|
| 97 | 97 | |
| ... | ... | @@ -507,7 +507,7 @@ pushTrailingComments w cs lb@(HsValBinds an _) = (True, HsValBinds an' vb) |
| 507 | 507 | (L la d:ds) -> (an, L (addCommentsToEpAnn la cs) d:ds)
|
| 508 | 508 | vb = case replaceDeclsValbinds w lb (reverse decls') of
|
| 509 | 509 | (HsValBinds _ vb') -> vb'
|
| 510 | - _ -> ValBinds NoAnnSortKey [] []
|
|
| 510 | + _ -> ValBinds noExtField []
|
|
| 511 | 511 | |
| 512 | 512 | |
| 513 | 513 | balanceCommentsListA :: [LocatedA a] -> [LocatedA a]
|
| ... | ... | @@ -1084,18 +1084,11 @@ replaceDeclsValbinds w b@(HsValBinds a _) new |
| 1084 | 1084 | = let
|
| 1085 | 1085 | oldSpan = spanHsLocaLBinds b
|
| 1086 | 1086 | an = oldWhereAnnotation a w (realSrcSpan oldSpan)
|
| 1087 | - decs = concatMap decl2Bind new
|
|
| 1088 | - sigs = concatMap decl2Sig new
|
|
| 1089 | - sortKey = captureOrderBinds new
|
|
| 1090 | - in (HsValBinds an (ValBinds sortKey decs sigs))
|
|
| 1087 | + in (HsValBinds an (ValBinds noExtField (map wrapValBind new)))
|
|
| 1091 | 1088 | replaceDeclsValbinds _ (HsIPBinds {}) _new = error "undefined replaceDecls HsIPBinds"
|
| 1092 | 1089 | replaceDeclsValbinds w (EmptyLocalBinds _) new
|
| 1093 | - = let
|
|
| 1094 | - an = newWhereAnnotation w
|
|
| 1095 | - decs = concatMap decl2Bind new
|
|
| 1096 | - sigs = concatMap decl2Sig new
|
|
| 1097 | - sortKey = captureOrderBinds new
|
|
| 1098 | - in (HsValBinds an (ValBinds sortKey decs sigs))
|
|
| 1090 | + = let an = newWhereAnnotation w
|
|
| 1091 | + in (HsValBinds an (ValBinds noExtField (map wrapValBind new)))
|
|
| 1099 | 1092 | |
| 1100 | 1093 | oldWhereAnnotation :: EpAnn (AnnList (EpToken "where"))
|
| 1101 | 1094 | -> WithWhere -> RealSrcSpan -> (EpAnn (AnnList (EpToken "where")))
|
| ... | ... | @@ -65,15 +65,6 @@ warn c _ = c |
| 65 | 65 | |
| 66 | 66 | -- ---------------------------------------------------------------------
|
| 67 | 67 | |
| 68 | -captureOrderBinds :: [LHsDecl GhcPs] -> AnnSortKey BindTag
|
|
| 69 | -captureOrderBinds ls = AnnSortKey $ map go ls
|
|
| 70 | - where
|
|
| 71 | - go (L _ (ValD _ _)) = BindTag
|
|
| 72 | - go (L _ (SigD _ _)) = SigDTag
|
|
| 73 | - go d = error $ "captureOrderBinds:" ++ showGhc d
|
|
| 74 | - |
|
| 75 | --- ---------------------------------------------------------------------
|
|
| 76 | - |
|
| 77 | 68 | notDocDecl :: LHsDecl GhcPs -> Bool
|
| 78 | 69 | notDocDecl (L _ DocD{}) = False
|
| 79 | 70 | notDocDecl _ = True
|
| ... | ... | @@ -655,45 +646,27 @@ partitionWithSortKey = go |
| 655 | 646 | |
| 656 | 647 | -- ---------------------------------------------------------------------
|
| 657 | 648 | |
| 658 | -orderedDeclsBinds
|
|
| 659 | - :: AnnSortKey BindTag
|
|
| 660 | - -> [LHsDecl GhcPs] -> [LHsDecl GhcPs]
|
|
| 661 | - -> [LHsDecl GhcPs]
|
|
| 662 | -orderedDeclsBinds sortKey binds sigs =
|
|
| 663 | - case sortKey of
|
|
| 664 | - NoAnnSortKey ->
|
|
| 665 | - sortBy (\a b -> compare (realSrcSpan $ getLocA a)
|
|
| 666 | - (realSrcSpan $ getLocA b)) (binds ++ sigs)
|
|
| 667 | - AnnSortKey keys ->
|
|
| 668 | - let
|
|
| 669 | - go [] _ _ = []
|
|
| 670 | - go (BindTag:ks) (b:bs) ss = b : go ks bs ss
|
|
| 671 | - go (SigDTag:ks) bs (s:ss) = s : go ks bs ss
|
|
| 672 | - go (_:ks) bs ss = go ks bs ss
|
|
| 673 | - in
|
|
| 674 | - go keys binds sigs
|
|
| 675 | - |
|
| 676 | 649 | hsDeclsLocalBinds :: HsLocalBinds GhcPs -> [LHsDecl GhcPs]
|
| 677 | 650 | hsDeclsLocalBinds lb = case lb of
|
| 678 | - HsValBinds _ (ValBinds sortKey bs sigs) ->
|
|
| 679 | - let
|
|
| 680 | - bds = map wrapDecl bs
|
|
| 681 | - sds = map wrapSig sigs
|
|
| 682 | - in
|
|
| 683 | - orderedDeclsBinds sortKey bds sds
|
|
| 651 | + HsValBinds _ (ValBinds _ bs) -> map unWrapValBind bs
|
|
| 684 | 652 | HsValBinds _ (XValBindsLR _) -> error $ "hsDecls.XValBindsLR not valid"
|
| 685 | 653 | HsIPBinds {} -> []
|
| 686 | 654 | EmptyLocalBinds {} -> []
|
| 687 | 655 | |
| 688 | 656 | hsDeclsValBinds :: (HsValBindsLR GhcPs GhcPs) -> [LHsDecl GhcPs]
|
| 689 | -hsDeclsValBinds (ValBinds sortKey bs sigs) =
|
|
| 690 | - let
|
|
| 691 | - bds = map wrapDecl bs
|
|
| 692 | - sds = map wrapSig sigs
|
|
| 693 | - in
|
|
| 694 | - orderedDeclsBinds sortKey bds sds
|
|
| 657 | +hsDeclsValBinds (ValBinds _ bs) = map unWrapValBind bs
|
|
| 695 | 658 | hsDeclsValBinds XValBindsLR{} = error "hsDeclsValBinds"
|
| 696 | 659 | |
| 660 | +unWrapValBind :: ValBind (GhcPass p) (GhcPass p) -> LHsDecl (GhcPass p)
|
|
| 661 | +unWrapValBind (VbBind (L l b)) = L l (ValD noExtField b)
|
|
| 662 | +unWrapValBind (VbSig (L l s)) = L l (SigD noExtField s)
|
|
| 663 | + |
|
| 664 | +sig2Decl :: LSig (GhcPass p) -> LHsDecl (GhcPass p)
|
|
| 665 | +sig2Decl (L l s) = L l (SigD noExtField s)
|
|
| 666 | + |
|
| 667 | +bind2Decl :: LHsBind (GhcPass p) -> LHsDecl (GhcPass p)
|
|
| 668 | +bind2Decl (L l b) = L l (ValD noExtField b)
|
|
| 669 | + |
|
| 697 | 670 | -- ---------------------------------------------------------------------
|
| 698 | 671 | |
| 699 | 672 | -- |Pure function to convert a 'LHsDecl' to a 'LHsBind'. This does
|