diff --git a/compiler/GHC/Hs/Binds.hs b/compiler/GHC/Hs/Binds.hs
index 2d67d7de27580f604f68c690009393ecb17a3ced..41977c86886e0a2a71ad9b0ce335a10d70dc25e3 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 5aa28c240f105c41055ee2838214a88b929837f9..9185f785f2ca8b527acdcd977088bae6bb1b60e7 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 1cd22a9190311fc3a2cc5bc912a72315cbe5896a..d14a6a2070cf4c6c5ef056e7a36a9910d5c9c3bd 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 0000000000000000000000000000000000000000..1943008778caed2ef78ad1af83fc626370e42cef
--- /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 0000000000000000000000000000000000000000..09fde257abc1439d3482fbbb02827e16dfb62f6f
--- /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 8d3b71ac9bf2991a437a8a6392140c94d8edc26b..05f9b098971d5a11a61cd7819bbf7fd3ba89f43f 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 6bbb5807c21cc7135b8f9fb4969d691123f3844a..8ba046ce42388e3386f85000a87c82d46730bf5b 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 215a19dd2492173e5dc2527a991cfd792a0b9943..ff0671611c66af0c2c0199599614f3249a0bf6b8 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 b498f6cc48af03c50fa8a25e2a1bb06d54a11f26..e1a5a2f7cc39100fc852eed16013e170fe9a55a2 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 45f3612a768c1be507a3fdc6ed28bb331fd9c018..340fa43cfafa2ec7c84231ef440d9cd6e2579cd7 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 14a05a23378682d7dcc83c81dfd752aad79855cf..59353df8245ae04811a1e51e65be378ea65cb93d 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