From ab40aa52726e586f4a2a38360663563f748df79e Mon Sep 17 00:00:00 2001
From: Alan Zimmerman <alan.zimm@gmail.com>
Date: Sun, 23 Jul 2023 09:41:22 +0100
Subject: [PATCH] EPA: Use Introduce [DeclTag] in AnnSortKey
The AnnSortKey is used to keep track of the order of declarations for
printing when the container has split them apart.
This applies to HsValBinds and ClassDecl, ClsInstDecl.
When making modifications to the list of declarations, the new order
must be captured for when it must be printed. For each list of
declarations (binds and sigs for a HsValBind) we can just store the
list in order.
To recreate the list when printing, we must merge them, and this is
what the AnnSortKey records. It used to be indexed by SrcSpan, we now
simply index by a marker as to which list to take the next item from.
---
compiler/GHC/Hs/Binds.hs | 2 +-
compiler/GHC/Hs/Decls.hs | 4 +-
compiler/GHC/Parser/Annotation.hs | 133 +++++++++++++--
.../exactprint/AddClassMethod.expected.hs | 10 ++
.../ghc-api/exactprint/AddClassMethod.hs | 7 +
testsuite/tests/ghc-api/exactprint/Makefile | 4 +
testsuite/tests/ghc-api/exactprint/all.T | 1 +
utils/check-exact/ExactPrint.hs | 44 ++---
utils/check-exact/Main.hs | 25 ++-
utils/check-exact/Transform.hs | 103 ++++--------
utils/check-exact/Utils.hs | 158 +++++++++++++++++-
11 files changed, 369 insertions(+), 122 deletions(-)
create mode 100644 testsuite/tests/ghc-api/exactprint/AddClassMethod.expected.hs
create mode 100644 testsuite/tests/ghc-api/exactprint/AddClassMethod.hs
diff --git a/compiler/GHC/Hs/Binds.hs b/compiler/GHC/Hs/Binds.hs
index 2d67d7de2758..41977c86886e 100644
--- a/compiler/GHC/Hs/Binds.hs
+++ b/compiler/GHC/Hs/Binds.hs
@@ -85,7 +85,7 @@ data NHsValBindsLR idL
[(RecFlag, LHsBinds idL)]
[LSig GhcRn]
-type instance XValBinds (GhcPass pL) (GhcPass pR) = AnnSortKey
+type instance XValBinds (GhcPass pL) (GhcPass pR) = AnnSortKey BindTag
type instance XXValBindsLR (GhcPass pL) pR
= NHsValBindsLR (GhcPass pL)
diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs
index 5aa28c240f10..9185f785f2ca 100644
--- a/compiler/GHC/Hs/Decls.hs
+++ b/compiler/GHC/Hs/Decls.hs
@@ -351,7 +351,7 @@ data DataDeclRn = DataDeclRn
, tcdFVs :: NameSet }
deriving Data
-type instance XClassDecl GhcPs = (EpAnn [AddEpAnn], AnnSortKey)
+type instance XClassDecl GhcPs = (EpAnn [AddEpAnn], AnnSortKey DeclTag)
-- TODO:AZ:tidy up AnnSortKey above
type instance XClassDecl GhcRn = NameSet -- FVs
@@ -803,7 +803,7 @@ type instance XCClsInstDecl GhcPs = ( Maybe (LWarningTxt GhcPs)
-- See Note [Implementation of deprecated instances]
-- in GHC.Tc.Solver.Dict
, EpAnn [AddEpAnn]
- , AnnSortKey) -- For sorting the additional annotations
+ , AnnSortKey DeclTag) -- For sorting the additional annotations
-- TODO:AZ:tidy up
type instance XCClsInstDecl GhcRn = Maybe (LWarningTxt GhcRn)
-- The warning of the deprecated instance
diff --git a/compiler/GHC/Parser/Annotation.hs b/compiler/GHC/Parser/Annotation.hs
index 1cd22a919031..d14a6a2070cf 100644
--- a/compiler/GHC/Parser/Annotation.hs
+++ b/compiler/GHC/Parser/Annotation.hs
@@ -41,7 +41,7 @@ module GHC.Parser.Annotation (
AnnContext(..),
NameAnn(..), NameAdornment(..),
NoEpAnns(..),
- AnnSortKey(..),
+ AnnSortKey(..), DeclTag(..), BindTag(..),
-- ** Trailing annotations in lists
TrailingAnn(..), trailingAnnToAddEpAnn,
@@ -798,18 +798,119 @@ data AnnPragma
} deriving (Data,Eq)
-- ---------------------------------------------------------------------
--- | Captures the sort order of sub elements. This is needed when the
--- sub-elements have been split (as in a HsLocalBind which holds separate
--- binds and sigs) or for infix patterns where the order has been
--- re-arranged. It is captured explicitly so that after the Delta phase a
--- SrcSpan is used purely as an index into the annotations, allowing
--- transformations of the AST including the introduction of new Located
--- items or re-arranging existing ones.
-data AnnSortKey
+
+-- | Captures the sort order of sub elements for `ValBinds`,
+-- `ClassDecl`, `ClsInstDecl`
+data AnnSortKey tag
+ -- See Note [AnnSortKey] below
= NoAnnSortKey
- | AnnSortKey [RealSrcSpan]
+ | AnnSortKey [tag]
deriving (Data, Eq)
+-- | Used to track of interleaving of binds and signatures for ValBind
+data BindTag
+ -- See Note [AnnSortKey] below
+ = BindTag
+ | SigDTag
+ deriving (Eq,Data,Ord,Show)
+
+-- | Used to track interleaving of class methods, class signatures,
+-- associated types and associate type defaults in `ClassDecl` and
+-- `ClsInstDecl`.
+data DeclTag
+ -- See Note [AnnSortKey] below
+ = ClsMethodTag
+ | ClsSigTag
+ | ClsAtTag
+ | ClsAtdTag
+ deriving (Eq,Data,Ord,Show)
+
+{-
+Note [AnnSortKey]
+~~~~~~~~~~~~~~~~~
+
+For some constructs in the ParsedSource we have mixed lists of items
+that can be freely intermingled.
+
+An example is the binds in a where clause, captured in
+
+ ValBinds
+ (XValBinds idL idR)
+ (LHsBindsLR idL idR) [LSig idR]
+
+This keeps separate ordered collections of LHsBind GhcPs and LSig GhcPs.
+
+But there is no constraint on the original source code as to how these
+should appear, so they can have all the signatures first, then their
+binds, or grouped with a signature preceding each bind.
+
+ fa :: Int
+ fa = 1
+
+ fb :: Char
+ fb = 'c'
+
+Or
+
+ fa :: Int
+ fb :: Char
+
+ fb = 'c'
+ fa = 1
+
+When exact printing these, we need to restore the original order. As
+initially parsed we have the SrcSpan, and can sort on those. But if we
+have modified the AST prior to printing, we cannot rely on the
+SrcSpans for order any more.
+
+The bag of LHsBind GhcPs is physically ordered, as is the list of LSig
+GhcPs. So in effect we have a list of binds in the order we care
+about, and a list of sigs in the order we care about. The only problem
+is to know how to merge the lists.
+
+This is where AnnSortKey comes in, which we store in the TTG extension
+point for ValBinds.
+
+ data AnnSortKey tag
+ = NoAnnSortKey
+ | AnnSortKey [tag]
+
+When originally parsed, with SrcSpans we can rely on, we do not need
+any extra information, so we tag it with NoAnnSortKey.
+
+If the binds and signatures are updated in any way, such that we can
+no longer rely on their SrcSpans (e.g. they are copied from elsewhere,
+parsed from scratch for insertion, have a fake SrcSpan), we use
+`AnnSortKey [BindTag]` to keep track.
+
+ data BindTag
+ = BindTag
+ | SigDTag
+
+We use it as a merge selector, and have one entry for each bind and
+signature.
+
+So for the first example we have
+
+ binds: fa = 1 , fb = 'c'
+ sigs: fa :: Int, fb :: Char
+ tags: SigTag, BindTag, SigTag, BindTag
+
+so we draw first from the signatures, then the binds, and same again.
+
+For the second example we have
+
+ binds: fb = 'c', fa = 1
+ sigs: fa :: Int, fb :: Char
+ tags: SigTag, SigTag, BindTag, BindTag
+
+so we draw two signatures, then two binds.
+
+We do similar for ClassDecl and ClsInstDecl, but we have four
+different lists we must manage. For this we use DeclTag.
+
+-}
+
-- ---------------------------------------------------------------------
-- | Convert a 'TrailingAnn' to an 'AddEpAnn'
@@ -1249,12 +1350,12 @@ instance Monoid NameAnn where
mempty = NameAnnTrailing []
-instance Semigroup AnnSortKey where
+instance Semigroup (AnnSortKey tag) where
NoAnnSortKey <> x = x
x <> NoAnnSortKey = x
AnnSortKey ls1 <> AnnSortKey ls2 = AnnSortKey (ls1 <> ls2)
-instance Monoid AnnSortKey where
+instance Monoid (AnnSortKey tag) where
mempty = NoAnnSortKey
instance (Outputable a) => Outputable (EpAnn a) where
@@ -1288,7 +1389,13 @@ instance (NamedThing (Located a)) => NamedThing (LocatedAn an a) where
instance Outputable AnnContext where
ppr (AnnContext a o c) = text "AnnContext" <+> ppr a <+> ppr o <+> ppr c
-instance Outputable AnnSortKey where
+instance Outputable BindTag where
+ ppr tag = text $ show tag
+
+instance Outputable DeclTag where
+ ppr tag = text $ show tag
+
+instance Outputable tag => Outputable (AnnSortKey tag) where
ppr NoAnnSortKey = text "NoAnnSortKey"
ppr (AnnSortKey ls) = text "AnnSortKey" <+> ppr ls
diff --git a/testsuite/tests/ghc-api/exactprint/AddClassMethod.expected.hs b/testsuite/tests/ghc-api/exactprint/AddClassMethod.expected.hs
new file mode 100644
index 000000000000..1943008778ca
--- /dev/null
+++ b/testsuite/tests/ghc-api/exactprint/AddClassMethod.expected.hs
@@ -0,0 +1,10 @@
+module AddClassMethod where
+
+class Foo where
+ f1 :: Int
+
+ nn :: Int
+ nn = 2
+
+ f2 :: Int
+ f2 = 1
diff --git a/testsuite/tests/ghc-api/exactprint/AddClassMethod.hs b/testsuite/tests/ghc-api/exactprint/AddClassMethod.hs
new file mode 100644
index 000000000000..09fde257abc1
--- /dev/null
+++ b/testsuite/tests/ghc-api/exactprint/AddClassMethod.hs
@@ -0,0 +1,7 @@
+module AddClassMethod where
+
+class Foo where
+ f1 :: Int
+
+ f2 :: Int
+ f2 = 1
diff --git a/testsuite/tests/ghc-api/exactprint/Makefile b/testsuite/tests/ghc-api/exactprint/Makefile
index 8d3b71ac9bf2..05f9b098971d 100644
--- a/testsuite/tests/ghc-api/exactprint/Makefile
+++ b/testsuite/tests/ghc-api/exactprint/Makefile
@@ -158,3 +158,7 @@ AddHiding1:
.PHONY: AddHiding2
AddHiding2:
$(CHECK_EXACT) $(LIBDIR) AddHiding2.hs addHiding2
+
+.PHONY: AddClassMethod
+AddClassMethod:
+ $(CHECK_EXACT) $(LIBDIR) AddClassMethod.hs addClassMethod
diff --git a/testsuite/tests/ghc-api/exactprint/all.T b/testsuite/tests/ghc-api/exactprint/all.T
index 6bbb5807c21c..8ba046ce4238 100644
--- a/testsuite/tests/ghc-api/exactprint/all.T
+++ b/testsuite/tests/ghc-api/exactprint/all.T
@@ -36,6 +36,7 @@ test('RmTypeSig1', ignore_stderr, makefile_test, ['RmTypeSig1'])
test('RmTypeSig2', ignore_stderr, makefile_test, ['RmTypeSig2'])
test('AddHiding1', ignore_stderr, makefile_test, ['AddHiding1'])
test('AddHiding2', ignore_stderr, makefile_test, ['AddHiding2'])
+test('AddClassMethod',ignore_stderr, makefile_test, ['AddClassMethod'])
test('Test20239', normal, compile_fail, ['-dsuppress-uniques -ddump-parsed-ast -dkeep-comments'])
test('ZeroWidthSemi', normal, compile, ['-dsuppress-uniques -ddump-parsed-ast -dkeep-comments'])
test('T22919', normal, compile, ['-dsuppress-uniques -ddump-parsed-ast -dkeep-comments'])
diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs
index 215a19dd2492..ff0671611c66 100644
--- a/utils/check-exact/ExactPrint.hs
+++ b/utils/check-exact/ExactPrint.hs
@@ -63,6 +63,7 @@ import Data.Functor.Const
import qualified Data.Set as Set
import Data.Typeable
import Data.List ( partition, sort, sortBy)
+import qualified Data.Map.Strict as Map
import Data.Maybe ( isJust, mapMaybe )
import Data.Void
@@ -2009,11 +2010,11 @@ instance ExactPrint (ClsInstDecl GhcPs) where
an1 <- markEpAnnL an0 lidl AnnOpenC
an2 <- markEpAnnAllL an1 lid AnnSemi
ds <- withSortKey sortKey
- (prepareListAnnotationA ats
- ++ prepareListAnnotationF an adts
- ++ prepareListAnnotationA (bagToList binds)
- ++ prepareListAnnotationA sigs
- )
+ [(ClsAtdTag, prepareListAnnotationA ats),
+ (ClsAtdTag, prepareListAnnotationF an adts),
+ (ClsMethodTag, prepareListAnnotationA (bagToList binds)),
+ (ClsSigTag, prepareListAnnotationA sigs)
+ ]
an3 <- markEpAnnL an2 lidl AnnCloseC -- '}'
let
ats' = undynamic ds
@@ -2320,13 +2321,10 @@ instance ExactPrint (HsValBindsLR GhcPs GhcPs) where
setAnnotationAnchor a _ _ = a
exact (ValBinds sortKey binds sigs) = do
- ds <- setLayoutBoth $ withSortKey sortKey
- (prepareListAnnotationA (bagToList binds)
- ++ prepareListAnnotationA sigs
- )
+ decls <- setLayoutBoth $ mapM markAnnotated $ hsDeclsValBinds (ValBinds sortKey binds sigs)
let
- binds' = listToBag $ undynamic ds
- sigs' = undynamic ds
+ binds' = listToBag $ concatMap decl2Bind decls
+ sigs' = concatMap decl2Sig decls
return (ValBinds sortKey binds' sigs')
exact (XValBindsLR _) = panic "XValBindsLR"
@@ -2381,20 +2379,14 @@ prepareListAnnotationA ls = map (\b -> (realSrcSpan $ getLocA b,go b)) ls
b' <- markAnnotated b
return (toDyn b')
-withSortKey :: (Monad m, Monoid w) => AnnSortKey -> [(RealSrcSpan, EP w m Dynamic)] -> EP w m [Dynamic]
+withSortKey :: (Monad m, Monoid w)
+ => AnnSortKey DeclTag -> [(DeclTag, [(RealSrcSpan, EP w m Dynamic)])] -> EP w m [Dynamic]
withSortKey annSortKey xs = do
debugM $ "withSortKey:annSortKey=" ++ showAst annSortKey
let ordered = case annSortKey of
- NoAnnSortKey -> sortBy orderByFst xs
- -- Just keys -> error $ "withSortKey: keys" ++ show keys
- AnnSortKey keys -> orderByKey xs keys
- -- `debug` ("withSortKey:" ++
- -- showPprUnsafe (map fst (sortBy (comparing (flip elemIndex keys . fst)) xs),
- -- map fst xs,
- -- keys)
- -- )
+ NoAnnSortKey -> sortBy orderByFst $ concatMap snd xs
+ AnnSortKey _keys -> orderedDecls annSortKey (Map.fromList xs)
mapM snd ordered
-
orderByFst :: Ord a => (a, b1) -> (a, b2) -> Ordering
orderByFst (a,_) (b,_) = compare a b
@@ -3497,12 +3489,12 @@ instance ExactPrint (TyClDecl GhcPs) where
an1 <- markEpAnnL an0 lidl AnnOpenC
an2 <- markEpAnnAllL an1 lidl AnnSemi
ds <- withSortKey sortKey
- (prepareListAnnotationA sigs
- ++ prepareListAnnotationA (bagToList methods)
- ++ prepareListAnnotationA ats
- ++ prepareListAnnotationA at_defs
+ [(ClsSigTag, prepareListAnnotationA sigs),
+ (ClsMethodTag, prepareListAnnotationA (bagToList methods)),
+ (ClsAtTag, prepareListAnnotationA ats),
+ (ClsAtdTag, prepareListAnnotationA at_defs)
-- ++ prepareListAnnotation docs
- )
+ ]
an3 <- markEpAnnL an2 lidl AnnCloseC
let
sigs' = undynamic ds
diff --git a/utils/check-exact/Main.hs b/utils/check-exact/Main.hs
index b498f6cc48af..e1a5a2f7cc39 100644
--- a/utils/check-exact/Main.hs
+++ b/utils/check-exact/Main.hs
@@ -251,6 +251,7 @@ changers =
,("rmTypeSig2", rmTypeSig2)
,("addHiding1", addHiding1)
,("addHiding2", addHiding2)
+ ,("addClassMethod", addClassMethod)
]
-- ---------------------------------------------------------------------
@@ -520,7 +521,7 @@ changeLocalDecls libdir (L l p) = do
let oldBinds = concatMap decl2Bind oldDecls'
(os:oldSigs) = concatMap decl2Sig oldDecls'
os' = setEntryDP os (DifferentLine 2 0)
- let sortKey = captureOrder decls
+ let sortKey = captureOrderBinds decls
let (EpAnn anc (AnnList (Just (Anchor anc2 _)) a b c dd) cs) = van
let van' = (EpAnn anc (AnnList (Just (Anchor anc2 (MovedAnchor (DifferentLine 1 4)))) a b c dd) cs)
let binds' = (HsValBinds van'
@@ -553,7 +554,7 @@ changeLocalDecls2 libdir (L l p) = do
[AddEpAnn AnnWhere (EpaDelta (SameLine 0) [])] [])
emptyComments
let decls = [s,d]
- let sortKey = captureOrder decls
+ let sortKey = captureOrderBinds decls
let binds = (HsValBinds an (ValBinds sortKey (listToBag $ [decl'])
[sig']))
return (L lm (Match ma mln pats (GRHSs emptyComments rhs binds)))
@@ -798,7 +799,7 @@ rmDecl5 _libdir lp = do
let
go :: HsExpr GhcPs -> Transform (HsExpr GhcPs)
go (HsLet a tkLet lb tkIn expr) = do
- decs <- hsDeclsValBinds lb
+ let decs = hsDeclsLocalBinds lb
let hdecs : _ = decs
let dec = last decs
_ <- transferEntryDP hdecs dec
@@ -945,6 +946,24 @@ addHiding2 _libdir top = do
debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
return lp'
+-- ---------------------------------------------------------------------
+
+addClassMethod :: Changer
+addClassMethod libdir lp = do
+ Right sig <- withDynFlags libdir (\df -> parseDecl df "sig" "nn :: Int")
+ Right decl <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2")
+ let decl' = setEntryDP decl (DifferentLine 1 2)
+ let sig' = setEntryDP sig (DifferentLine 2 2)
+ let doAddMethod = do
+ [cd] <- hsDecls lp
+ (f1:f2s:f2d:_) <- hsDecls cd
+ let f2s' = setEntryDP f2s (DifferentLine 2 2)
+ cd' <- replaceDecls cd [f1, sig', decl', f2s', f2d]
+ replaceDecls lp [cd']
+
+ (lp',_,w) <- runTransformT doAddMethod
+ debugM $ "addClassMethod:" ++ intercalate "\n" w
+ return lp'
-- ---------------------------------------------------------------------
-- From SYB
diff --git a/utils/check-exact/Transform.hs b/utils/check-exact/Transform.hs
index 45f3612a768c..340fa43cfafa 100644
--- a/utils/check-exact/Transform.hs
+++ b/utils/check-exact/Transform.hs
@@ -68,7 +68,7 @@ module Transform
, anchorEof
-- ** Managing lists, pure functions
- , captureOrder
+ , captureOrderBinds
, captureLineSpacing
, captureMatchLineSpacing
, captureTypeSigSpacing
@@ -97,7 +97,6 @@ import GHC.Data.Bag
import GHC.Data.FastString
import Data.Data
-import Data.List ( sortBy )
import Data.Maybe
import Data.Functor.Identity
@@ -175,10 +174,12 @@ srcSpanStartLine' _ = 0
-- ---------------------------------------------------------------------
--- |If a list has been re-ordered or had items added, capture the new order in
--- the appropriate 'AnnSortKey' attached to the 'Annotation' for the list.
-captureOrder :: [LocatedA b] -> AnnSortKey
-captureOrder ls = AnnSortKey $ map (rs . getLocA) ls
+captureOrderBinds :: [LHsDecl GhcPs] -> AnnSortKey BindTag
+captureOrderBinds ls = AnnSortKey $ map go ls
+ where
+ go (L _ (ValD _ _)) = BindTag
+ go (L _ (SigD _ _)) = SigDTag
+ go d = error $ "captureOrderBinds:" ++ showGhc d
-- ---------------------------------------------------------------------
@@ -239,34 +240,6 @@ captureTypeSigSpacing s = s
-- ---------------------------------------------------------------------
--- |Pure function to convert a 'LHsDecl' to a 'LHsBind'. This does
--- nothing to any annotations that may be attached to either of the elements.
--- It is used as a utility function in 'replaceDecls'
-decl2Bind :: LHsDecl GhcPs -> [LHsBind GhcPs]
-decl2Bind (L l (ValD _ s)) = [L l s]
-decl2Bind _ = []
-
--- |Pure function to convert a 'LSig' to a 'LHsBind'. This does
--- nothing to any annotations that may be attached to either of the elements.
--- It is used as a utility function in 'replaceDecls'
-decl2Sig :: LHsDecl GhcPs -> [LSig GhcPs]
-decl2Sig (L l (SigD _ s)) = [L l s]
-decl2Sig _ = []
-
--- ---------------------------------------------------------------------
-
--- |Convert a 'LSig' into a 'LHsDecl'
-wrapSig :: LSig GhcPs -> LHsDecl GhcPs
-wrapSig (L l s) = L l (SigD NoExtField s)
-
--- ---------------------------------------------------------------------
-
--- |Convert a 'LHsBind' into a 'LHsDecl'
-wrapDecl :: LHsBind GhcPs -> LHsDecl GhcPs
-wrapDecl (L l s) = L l (ValD NoExtField s)
-
--- ---------------------------------------------------------------------
-
setEntryDPDecl :: LHsDecl GhcPs -> DeltaPos -> LHsDecl GhcPs
setEntryDPDecl decl@(L _ (ValD x (FunBind a b (MG c (L d ms ))))) dp
= L l' (ValD x (FunBind a b (MG c (L d ms'))))
@@ -520,7 +493,7 @@ pushTrailingComments _ _cs (HsIPBinds _ _) = error "TODO: pushTrailingComments:H
pushTrailingComments w cs lb@(HsValBinds an _)
= (True, HsValBinds an' vb)
where
- (decls, _, _ws1) = runTransform (hsDeclsValBinds lb)
+ decls = hsDeclsLocalBinds lb
(an', decls') = case reverse decls of
[] -> (addCommentsToEpAnn (spanHsLocaLBinds lb) an cs, decls)
(L la d:ds) -> (an, L (addCommentsToSrcAnn la cs) d:ds)
@@ -888,13 +861,24 @@ instance HasDecls ParsedSource where
replaceDecls (L l (HsModule (XModulePs a lo deps haddocks) mname exps imps _decls)) decls
= do
logTr "replaceDecls LHsModule"
- -- modifyAnnsT (captureOrder m decls)
return (L l (HsModule (XModulePs a lo deps haddocks) mname exps imps decls))
-- ---------------------------------------------------------------------
+instance HasDecls (LocatedA (HsDecl GhcPs)) where
+ hsDecls (L _ (TyClD _ c@ClassDecl{})) = return $ hsDeclsClassDecl c
+ hsDecls decl = do
+ error $ "hsDecls:decl=" ++ showAst decl
+ replaceDecls (L l (TyClD e dec@ClassDecl{})) decls = do
+ let decl' = replaceDeclsClassDecl dec decls
+ return (L l (TyClD e decl'))
+ replaceDecls decl _decls = do
+ error $ "replaceDecls:decl=" ++ showAst decl
+
+-- ---------------------------------------------------------------------
+
instance HasDecls (LocatedA (Match GhcPs (LocatedA (HsExpr GhcPs)))) where
- hsDecls (L _ (Match _ _ _ (GRHSs _ _ lb))) = hsDeclsValBinds lb
+ hsDecls (L _ (Match _ _ _ (GRHSs _ _ lb))) = return $ hsDeclsLocalBinds lb
replaceDecls (L l (Match xm c p (GRHSs xr rhs binds))) []
= do
@@ -923,7 +907,7 @@ instance HasDecls (LocatedA (Match GhcPs (LocatedA (HsExpr GhcPs)))) where
-- ---------------------------------------------------------------------
instance HasDecls (LocatedA (HsExpr GhcPs)) where
- hsDecls (L _ (HsLet _ _ decls _ _ex)) = hsDeclsValBinds decls
+ hsDecls (L _ (HsLet _ _ decls _ _ex)) = return $ hsDeclsLocalBinds decls
hsDecls _ = return []
replaceDecls (L ll (HsLet x tkLet binds tkIn ex)) newDecls
@@ -965,7 +949,7 @@ instance HasDecls (LocatedA (HsExpr GhcPs)) where
-- cannot be a member of 'HasDecls' because a 'FunBind' is not idempotent
-- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBindD' \/ 'replaceDeclsPatBindD' is
-- idempotent.
-hsDeclsPatBindD :: (Monad m) => LHsDecl GhcPs -> TransformT m [LHsDecl GhcPs]
+hsDeclsPatBindD :: LHsDecl GhcPs -> [LHsDecl GhcPs]
hsDeclsPatBindD (L l (ValD _ d)) = hsDeclsPatBind (L l d)
hsDeclsPatBindD x = error $ "hsDeclsPatBindD called for:" ++ showGhc x
@@ -973,8 +957,8 @@ hsDeclsPatBindD x = error $ "hsDeclsPatBindD called for:" ++ showGhc x
-- cannot be a member of 'HasDecls' because a 'FunBind' is not idempotent
-- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBind' \/ 'replaceDeclsPatBind' is
-- idempotent.
-hsDeclsPatBind :: (Monad m) => LHsBind GhcPs -> TransformT m [LHsDecl GhcPs]
-hsDeclsPatBind (L _ (PatBind _ _ (GRHSs _ _grhs lb))) = hsDeclsValBinds lb
+hsDeclsPatBind :: LHsBind GhcPs -> [LHsDecl GhcPs]
+hsDeclsPatBind (L _ (PatBind _ _ (GRHSs _ _grhs lb))) = hsDeclsLocalBinds lb
hsDeclsPatBind x = error $ "hsDeclsPatBind called for:" ++ showGhc x
-- -------------------------------------
@@ -1006,7 +990,7 @@ replaceDeclsPatBind x _ = error $ "replaceDeclsPatBind called for:" ++ showGhc x
-- ---------------------------------------------------------------------
instance HasDecls (LocatedA (Stmt GhcPs (LocatedA (HsExpr GhcPs)))) where
- hsDecls (L _ (LetStmt _ lb)) = hsDeclsValBinds lb
+ hsDecls (L _ (LetStmt _ lb)) = return $ hsDeclsLocalBinds lb
hsDecls (L _ (LastStmt _ e _ _)) = hsDecls e
hsDecls (L _ (BindStmt _ _pat e)) = hsDecls e
hsDecls (L _ (BodyStmt _ e _ _)) = hsDecls e
@@ -1035,35 +1019,6 @@ instance HasDecls (LocatedA (Stmt GhcPs (LocatedA (HsExpr GhcPs)))) where
-- end of HasDecls instances
-- =====================================================================
--- ---------------------------------------------------------------------
-
--- |Look up the annotated order and sort the decls accordingly
--- TODO:AZ: this should be pure
-orderedDecls :: (Monad m)
- => AnnSortKey -> [LHsDecl GhcPs] -> TransformT m [LHsDecl GhcPs]
-orderedDecls sortKey decls = do
- case sortKey of
- NoAnnSortKey -> do
- -- return decls
- return $ sortBy (\a b -> compare (realSrcSpan $ getLocA a) (realSrcSpan $ getLocA b)) decls
- AnnSortKey keys -> do
- let ds = map (\s -> (rs $ getLocA s,s)) decls
- ordered = map snd $ orderByKey ds keys
- return ordered
-
--- ---------------------------------------------------------------------
-
-hsDeclsValBinds :: (Monad m) => HsLocalBinds GhcPs -> TransformT m [LHsDecl GhcPs]
-hsDeclsValBinds lb = case lb of
- HsValBinds _ (ValBinds sortKey bs sigs) -> do
- let
- bds = map wrapDecl (bagToList bs)
- sds = map wrapSig sigs
- orderedDecls sortKey (bds ++ sds)
- HsValBinds _ (XValBindsLR _) -> error $ "hsDecls.XValBindsLR not valid"
- HsIPBinds {} -> return []
- EmptyLocalBinds {} -> return []
-
data WithWhere = WithWhere
| WithoutWhere
deriving (Eq,Show)
@@ -1085,7 +1040,7 @@ replaceDeclsValbinds w b@(HsValBinds a _) new
an <- oldWhereAnnotation a w (realSrcSpan oldSpan)
let decs = listToBag $ concatMap decl2Bind new
let sigs = concatMap decl2Sig new
- let sortKey = captureOrder new
+ let sortKey = captureOrderBinds new
return (HsValBinds an (ValBinds sortKey decs sigs))
replaceDeclsValbinds _ (HsIPBinds {}) _new = error "undefined replaceDecls HsIPBinds"
replaceDeclsValbinds w (EmptyLocalBinds _) new
@@ -1096,7 +1051,7 @@ replaceDeclsValbinds w (EmptyLocalBinds _) new
newSigs = concatMap decl2Sig new
let decs = listToBag $ newBinds
let sigs = newSigs
- let sortKey = captureOrder new
+ let sortKey = captureOrderBinds new
return (HsValBinds an (ValBinds sortKey decs sigs))
oldWhereAnnotation :: (Monad m)
@@ -1160,7 +1115,7 @@ modifyValD :: forall m t. (HasTransform m)
modifyValD p pb@(L ss (ValD _ (PatBind {} ))) f =
if (locA ss) == p
then do
- ds <- liftT $ hsDeclsPatBindD pb
+ let ds = hsDeclsPatBindD pb
(ds',r) <- f (error "modifyValD.PatBind should not touch Match") ds
pb' <- liftT $ replaceDeclsPatBindD pb ds'
return (pb',r)
diff --git a/utils/check-exact/Utils.hs b/utils/check-exact/Utils.hs
index 14a05a233786..59353df8245a 100644
--- a/utils/check-exact/Utils.hs
+++ b/utils/check-exact/Utils.hs
@@ -31,6 +31,7 @@ import qualified Orphans as Orphans
import GHC hiding (EpaComment)
import qualified GHC
+import GHC.Data.Bag
import GHC.Types.Name
import GHC.Types.Name.Reader
import GHC.Types.SrcLoc
@@ -40,6 +41,7 @@ import qualified GHC.Data.Strict as Strict
import Data.Data hiding ( Fixity )
import Data.List (sortBy, elemIndex)
+import qualified Data.Map.Strict as Map
import Debug.Trace
import Types
@@ -193,7 +195,7 @@ tweakDelta (DifferentLine l d) = DifferentLine l (d-1)
-- |Given a list of items and a list of keys, returns a list of items
-- ordered by their position in the list of keys.
-orderByKey :: [(RealSrcSpan,a)] -> [RealSrcSpan] -> [(RealSrcSpan,a)]
+orderByKey :: [(DeclTag,a)] -> [DeclTag] -> [(DeclTag,a)]
orderByKey keys order
-- AZ:TODO: if performance becomes a problem, consider a Map of the order
-- SrcSpan to an index, and do a lookup instead of elemIndex.
@@ -439,12 +441,162 @@ hackAnchorToSrcSpan (Anchor r (MovedAnchor dp))
s = - (getDeltaLine dp)
e = - (deltaColumn dp)
- -- ---------------------------------------------------------------------
+-- ---------------------------------------------------------------------
+
+type DeclsByTag a = Map.Map DeclTag [(RealSrcSpan, a)]
+
+orderedDecls
+ :: AnnSortKey DeclTag
+ -> DeclsByTag a
+ -> [(RealSrcSpan, a)]
+orderedDecls sortKey declGroup =
+ case sortKey of
+ NoAnnSortKey ->
+ sortBy (\a b -> compare (fst a) (fst b)) (concat $ Map.elems declGroup)
+ AnnSortKey keys ->
+ let
+ go :: [DeclTag] -> DeclsByTag a -> [(RealSrcSpan, a)]
+ go [] _ = []
+ go (tag:ks) dbt = d : go ks dbt'
+ where
+ dbt' = Map.adjust (\ds -> drop 1 ds) tag dbt
+ d = case Map.lookup tag dbt of
+ Just (d':_) -> d'
+ _ -> error $ "orderedDecls: could not look up "
+ ++ show tag ++ " in " ++ show (Map.keys dbt)
+ in
+ go keys declGroup
+
+hsDeclsClassDecl :: TyClDecl GhcPs -> [LHsDecl GhcPs]
+hsDeclsClassDecl dec = case dec of
+ ClassDecl { tcdCExt = (_an2, sortKey),
+ tcdSigs = sigs,tcdMeths = methods,
+ tcdATs = ats, tcdATDefs = at_defs
+ } -> map snd decls
+ where
+ srs :: SrcAnn a -> RealSrcSpan
+ srs a = realSrcSpan $ locA a
+ decls
+ = orderedDecls sortKey $ Map.fromList
+ [(ClsSigTag, map (\(L l s) -> (srs l, L l (SigD noExtField s))) sigs),
+ (ClsMethodTag, map (\(L l s) -> (srs l, L l (ValD noExtField s))) (bagToList methods)),
+ (ClsAtTag, map (\(L l s) -> (srs l, L l (TyClD noExtField $ FamDecl noExtField s))) ats),
+ (ClsAtdTag, map (\(L l s) -> (srs l, L l (InstD noExtField $ TyFamInstD noExtField s))) at_defs)
+ ]
+ _ -> error $ "hsDeclsClassDecl:dec=" ++ showAst dec
+
+replaceDeclsClassDecl :: TyClDecl GhcPs -> [LHsDecl GhcPs] -> TyClDecl GhcPs
+replaceDeclsClassDecl decl decls = case decl of
+ ClassDecl { tcdCExt = (an2, _) } -> decl'
+ where
+ (tags, methods', sigs', ats', at_defs', _, _docs) = partitionWithSortKey decls
+ decl' = decl { tcdCExt = (an2, AnnSortKey tags),
+ tcdSigs = sigs',tcdMeths = methods',
+ tcdATs = ats', tcdATDefs = at_defs'
+ }
+
+ _ -> error $ "replaceDeclsClassDecl:decl=" ++ showAst decl
+
+partitionWithSortKey
+ :: [LHsDecl GhcPs]
+ -> ([DeclTag], LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
+ [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl GhcPs])
+partitionWithSortKey = go
+ where
+ go [] = ([], emptyBag, [], [], [], [], [])
+ go ((L l decl) : ds) =
+ let (tags, bs, ss, ts, tfis, dfis, docs) = go ds in
+ case decl of
+ ValD _ b
+ -> (ClsMethodTag:tags, L l b `consBag` bs, ss, ts, tfis, dfis, docs)
+ SigD _ s
+ -> (ClsSigTag:tags, bs, L l s : ss, ts, tfis, dfis, docs)
+ TyClD _ (FamDecl _ t)
+ -> (ClsAtTag:tags, bs, ss, L l t : ts, tfis, dfis, docs)
+ InstD _ (TyFamInstD { tfid_inst = tfi })
+ -> (ClsAtdTag:tags, bs, ss, ts, L l tfi : tfis, dfis, docs)
+ InstD _ (DataFamInstD { dfid_inst = dfi })
+ -> (tags, bs, ss, ts, tfis, L l dfi : dfis, docs)
+ DocD _ d
+ -> (tags, bs, ss, ts, tfis, dfis, L l d : docs)
+ _ -> error $ "partitionBindsAndSigs" ++ (showAst decl)
+
+
+-- ---------------------------------------------------------------------
+
+orderedDeclsBinds
+ :: AnnSortKey BindTag
+ -> [LHsDecl GhcPs] -> [LHsDecl GhcPs]
+ -> [LHsDecl GhcPs]
+orderedDeclsBinds sortKey binds sigs =
+ case sortKey of
+ NoAnnSortKey ->
+ sortBy (\a b -> compare (realSrcSpan $ getLocA a)
+ (realSrcSpan $ getLocA b)) (binds ++ sigs)
+ AnnSortKey keys ->
+ let
+ go [] _ _ = []
+ go (BindTag:ks) (b:bs) ss = b : go ks bs ss
+ go (SigDTag:ks) bs (s:ss) = s : go ks bs ss
+ go (_:ks) bs ss = go ks bs ss
+ in
+ go keys binds sigs
+
+hsDeclsLocalBinds :: HsLocalBinds GhcPs -> [LHsDecl GhcPs]
+hsDeclsLocalBinds lb = case lb of
+ HsValBinds _ (ValBinds sortKey bs sigs) ->
+ let
+ bds = map wrapDecl (bagToList bs)
+ sds = map wrapSig sigs
+ in
+ orderedDeclsBinds sortKey bds sds
+ HsValBinds _ (XValBindsLR _) -> error $ "hsDecls.XValBindsLR not valid"
+ HsIPBinds {} -> []
+ EmptyLocalBinds {} -> []
+
+hsDeclsValBinds :: (HsValBindsLR GhcPs GhcPs) -> [LHsDecl GhcPs]
+hsDeclsValBinds (ValBinds sortKey bs sigs) =
+ let
+ bds = map wrapDecl (bagToList bs)
+ sds = map wrapSig sigs
+ in
+ orderedDeclsBinds sortKey bds sds
+hsDeclsValBinds XValBindsLR{} = error "hsDeclsValBinds"
+
+-- ---------------------------------------------------------------------
+
+-- |Pure function to convert a 'LHsDecl' to a 'LHsBind'. This does
+-- nothing to any annotations that may be attached to either of the elements.
+-- It is used as a utility function in 'replaceDecls'
+decl2Bind :: LHsDecl GhcPs -> [LHsBind GhcPs]
+decl2Bind (L l (ValD _ s)) = [L l s]
+decl2Bind _ = []
+
+-- |Pure function to convert a 'LSig' to a 'LHsBind'. This does
+-- nothing to any annotations that may be attached to either of the elements.
+-- It is used as a utility function in 'replaceDecls'
+decl2Sig :: LHsDecl GhcPs -> [LSig GhcPs]
+decl2Sig (L l (SigD _ s)) = [L l s]
+decl2Sig _ = []
+
+-- ---------------------------------------------------------------------
+
+-- |Convert a 'LSig' into a 'LHsDecl'
+wrapSig :: LSig GhcPs -> LHsDecl GhcPs
+wrapSig (L l s) = L l (SigD NoExtField s)
+
+-- ---------------------------------------------------------------------
+
+-- |Convert a 'LHsBind' into a 'LHsDecl'
+wrapDecl :: LHsBind GhcPs -> LHsDecl GhcPs
+wrapDecl (L l s) = L l (ValD NoExtField s)
+
+-- ---------------------------------------------------------------------
showAst :: (Data a) => a -> String
showAst ast
= showSDocUnsafe
- $ showAstData NoBlankSrcSpan NoBlankEpAnnotations ast
+ $ showAstData BlankSrcSpanFile NoBlankEpAnnotations ast
-- ---------------------------------------------------------------------
-- Putting these here for the time being, to avoid import loops
--
GitLab