[Git][ghc/ghc][master] Update the check-exact infrastructure to match ghc-exactprint
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Mon Oct 17 23:21:20 UTC 2022
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
d80ad2f4 by Alan Zimmerman at 2022-10-17T19:20:40-04:00
Update the check-exact infrastructure to match ghc-exactprint
GHC tests the exact print annotations using the contents of
utils/check-exact.
The same functionality is provided via
https://github.com/alanz/ghc-exactprint
The latter was updated to ensure it works with all of the files on
hackage when 9.2 was released, as well as updated to ensure users of
the library could work properly (apply-refact, retrie, etc).
This commit brings the changes from ghc-exactprint into
GHC/utils/check-exact, adapting for the changes to master.
Once it lands, it will form the basis for the 9.4 version of
ghc-exactprint.
See also discussion around this process at #21355
- - - - -
17 changed files:
- testsuite/tests/ghc-api/exactprint/AddDecl2.expected.hs
- testsuite/tests/ghc-api/exactprint/RmDecl7.expected.hs
- testsuite/tests/ghc-api/exactprint/RmDecl7.hs
- testsuite/tests/printer/Makefile
- + testsuite/tests/printer/Test21355.hs
- testsuite/tests/printer/all.T
- utils/check-exact/.ghci
- utils/check-exact/ExactPrint.hs
- utils/check-exact/Lookup.hs
- utils/check-exact/Main.hs
- + utils/check-exact/Orphans.hs
- utils/check-exact/Parsers.hs
- utils/check-exact/Preprocess.hs
- utils/check-exact/Transform.hs
- utils/check-exact/Types.hs
- utils/check-exact/Utils.hs
- utils/check-exact/check-exact.cabal
Changes:
=====================================
testsuite/tests/ghc-api/exactprint/AddDecl2.expected.hs
=====================================
@@ -8,6 +8,6 @@ foo a b = a + b
-- | Do bar
bar x y = {- baz -} foo (x+y) x
--- end of file
-
nn = n2
+
+-- end of file
=====================================
testsuite/tests/ghc-api/exactprint/RmDecl7.expected.hs
=====================================
@@ -3,5 +3,5 @@ module RmDecl7 where
toplevel :: Integer -> Integer
toplevel x = c * x
+-- c,d :: Integer
d = 9
-
=====================================
testsuite/tests/ghc-api/exactprint/RmDecl7.hs
=====================================
@@ -6,4 +6,3 @@ toplevel x = c * x
-- c,d :: Integer
c = 7
d = 9
-
=====================================
testsuite/tests/printer/Makefile
=====================================
@@ -760,6 +760,11 @@ Test20256:
$(CHECK_PPR) $(LIBDIR) Test20256.hs
$(CHECK_EXACT) $(LIBDIR) Test20256.hs
+.PHONY: Test21355
+Test21355:
+ $(CHECK_PPR) $(LIBDIR) Test21355.hs
+ $(CHECK_EXACT) $(LIBDIR) Test21355.hs
+
.PHONY: Test21805
Test21805:
$(CHECK_PPR) $(LIBDIR) Test21805.hs
=====================================
testsuite/tests/printer/Test21355.hs
=====================================
@@ -0,0 +1,11 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE TemplateHaskell #-}
+module Test21355 where
+
+emptyBK = [d| {} |]
+
+data GitHubSignedReqBody''
+ (proxy :: KProxy k)
+ (key :: k)
+ (list :: [Type])
+ (result :: Type) where
=====================================
testsuite/tests/printer/all.T
=====================================
@@ -179,4 +179,5 @@ test('Test20258', [ignore_stderr, req_ppr_deps], makefile_test, ['Test20258'])
test('Test20297', [ignore_stderr, req_ppr_deps], makefile_test, ['Test20297'])
test('Test20315', normal, compile_fail, [''])
test('Test20846', [ignore_stderr, req_ppr_deps], makefile_test, ['Test20846'])
+test('Test21355', [ignore_stderr, req_ppr_deps], makefile_test, ['Test21355'])
test('Test21805', [ignore_stderr, req_ppr_deps], makefile_test, ['Test21805'])
=====================================
utils/check-exact/.ghci
=====================================
@@ -1,3 +1,3 @@
:set -package ghc
-:set -i./src
:set -Wall
+-- :set -fobject-code
=====================================
utils/check-exact/ExactPrint.hs
=====================================
The diff for this file was not included because it is too large.
=====================================
utils/check-exact/Lookup.hs
=====================================
@@ -1,7 +1,7 @@
module Lookup
(
keywordToString
- , KeywordId(..)
+ , AnnKeywordId(..)
, Comment(..)
) where
@@ -12,117 +12,114 @@ import Types
-- There is no specific mapping for the following constructors.
-- `AnnOpen`, `AnnClose`, `AnnVal`, `AnnPackageName`, `AnnHeader`, `AnnFunId`,
-- `AnnInfix`
-keywordToString :: KeywordId -> String
+keywordToString :: AnnKeywordId -> String
keywordToString kw =
let mkErr x = error $ "keywordToString: missing case for:" ++ show x
in
case kw of
-- Specifically handle all cases so that there are pattern match
-- warnings if new constructors are added.
- AnnComment _ -> mkErr kw
- AnnString _ -> mkErr kw
- AnnSemiSep -> ";"
- (G AnnAnyclass) -> "anyclass"
- (G AnnOpen ) -> mkErr kw
- (G AnnClose ) -> mkErr kw
- (G AnnVal ) -> mkErr kw
- (G AnnPackageName) -> mkErr kw
- (G AnnHeader ) -> mkErr kw
- (G AnnFunId ) -> mkErr kw
- (G AnnInfix ) -> mkErr kw
- (G AnnValStr ) -> mkErr kw
- (G AnnName ) -> mkErr kw
- (G AnnAs ) -> "as"
- (G AnnBang ) -> "!"
- (G AnnBackquote ) -> "`"
- (G AnnBy ) -> "by"
- (G AnnCase ) -> "case"
- (G AnnCases ) -> "cases"
- (G AnnClass ) -> "class"
- (G AnnCloseB ) -> "|)"
- (G AnnCloseBU ) -> "⦈"
- (G AnnCloseC ) -> "}"
- (G AnnCloseP ) -> ")"
- (G AnnClosePH ) -> "#)"
- (G AnnCloseQ ) -> "|]"
- (G AnnCloseQU ) -> "⟧"
- (G AnnCloseS ) -> "]"
- (G AnnColon ) -> ":"
- (G AnnComma ) -> ","
- (G AnnCommaTuple ) -> ","
- (G AnnDarrow ) -> "=>"
- (G AnnData ) -> "data"
- (G AnnDcolon ) -> "::"
- (G AnnDefault ) -> "default"
- (G AnnDeriving ) -> "deriving"
- (G AnnDo ) -> "do"
- (G AnnDot ) -> "."
- (G AnnDotdot ) -> ".."
- (G AnnElse ) -> "else"
- (G AnnEqual ) -> "="
- (G AnnExport ) -> "export"
- (G AnnFamily ) -> "family"
- (G AnnForall ) -> "forall"
- (G AnnForeign ) -> "foreign"
- (G AnnGroup ) -> "group"
- (G AnnHiding ) -> "hiding"
- (G AnnIf ) -> "if"
- (G AnnImport ) -> "import"
- (G AnnIn ) -> "in"
- (G AnnInstance ) -> "instance"
- (G AnnLam ) -> "\\"
- (G AnnLarrow ) -> "<-"
- (G AnnLet ) -> "let"
- (G AnnLollyU ) -> "⊸"
- (G AnnMdo ) -> "mdo"
- (G AnnMinus ) -> "-"
- (G AnnModule ) -> "module"
- (G AnnNewtype ) -> "newtype"
- (G AnnOf ) -> "of"
- (G AnnOpenB ) -> "(|"
- (G AnnOpenBU ) -> "⦇"
- (G AnnOpenC ) -> "{"
- (G AnnOpenE ) -> "[e|"
- (G AnnOpenEQ ) -> "[|"
- (G AnnOpenEQU ) -> "⟦"
- (G AnnOpenP ) -> "("
- (G AnnOpenPH ) -> "(#"
- (G AnnOpenS ) -> "["
- (G AnnPattern ) -> "pattern"
- (G AnnPercent ) -> "%"
- (G AnnPercentOne) -> "%1"
- (G AnnProc ) -> "proc"
- (G AnnQualified ) -> "qualified"
- (G AnnRarrow ) -> "->"
- (G AnnRec ) -> "rec"
- (G AnnRole ) -> "role"
- (G AnnSafe ) -> "safe"
- (G AnnSemi ) -> ";"
- (G AnnSignature) -> "signature"
- (G AnnStock ) -> "stock"
- (G AnnStatic ) -> "static"
- (G AnnThen ) -> "then"
- (G AnnTilde ) -> "~"
- (G AnnType ) -> "type"
- (G AnnUnit ) -> "()"
- (G AnnUsing ) -> "using"
- (G AnnVbar ) -> "|"
- (G AnnWhere ) -> "where"
- (G Annlarrowtail ) -> "-<"
- (G Annrarrowtail ) -> ">-"
- (G AnnLarrowtail ) -> "-<<"
- (G AnnRarrowtail ) -> ">>-"
- (G AnnSimpleQuote ) -> "'"
- (G AnnThTyQuote ) -> "''"
- (G AnnDollar ) -> "$"
- (G AnnDollarDollar ) -> "$$"
- (G AnnDarrowU) -> "⇒"
- (G AnnDcolonU) -> "∷"
- (G AnnForallU) -> "∀"
- (G AnnLarrowU) -> "←"
- (G AnnLarrowtailU) -> "⤛"
- (G AnnRarrowU) -> "→"
- (G AnnRarrowtailU) -> "⤜"
- (G AnnlarrowtailU) -> "⤙"
- (G AnnrarrowtailU) -> "⤚"
- (G AnnVia) -> "via"
+ AnnAnyclass -> "anyclass"
+ AnnOpen -> mkErr kw
+ AnnClose -> mkErr kw
+ AnnVal -> mkErr kw
+ AnnPackageName -> mkErr kw
+ AnnHeader -> mkErr kw
+ AnnFunId -> mkErr kw
+ AnnInfix -> mkErr kw
+ AnnValStr -> mkErr kw
+ AnnName -> mkErr kw
+ AnnAs -> "as"
+ AnnBang -> "!"
+ AnnBackquote -> "`"
+ AnnBy -> "by"
+ AnnCase -> "case"
+ AnnCases -> "cases"
+ AnnClass -> "class"
+ AnnCloseB -> "|)"
+ AnnCloseBU -> "⦈"
+ AnnCloseC -> "}"
+ AnnCloseP -> ")"
+ AnnClosePH -> "#)"
+ AnnCloseQ -> "|]"
+ AnnCloseQU -> "⟧"
+ AnnCloseS -> "]"
+ AnnColon -> ":"
+ AnnComma -> ","
+ AnnCommaTuple -> ","
+ AnnDarrow -> "=>"
+ AnnData -> "data"
+ AnnDcolon -> "::"
+ AnnDefault -> "default"
+ AnnDeriving -> "deriving"
+ AnnDo -> "do"
+ AnnDot -> "."
+ AnnDotdot -> ".."
+ AnnElse -> "else"
+ AnnEqual -> "="
+ AnnExport -> "export"
+ AnnFamily -> "family"
+ AnnForall -> "forall"
+ AnnForeign -> "foreign"
+ AnnGroup -> "group"
+ AnnHiding -> "hiding"
+ AnnIf -> "if"
+ AnnImport -> "import"
+ AnnIn -> "in"
+ AnnInstance -> "instance"
+ AnnLam -> "\\"
+ AnnLarrow -> "<-"
+ AnnLet -> "let"
+ AnnLollyU -> "⊸"
+ AnnMdo -> "mdo"
+ AnnMinus -> "-"
+ AnnModule -> "module"
+ AnnNewtype -> "newtype"
+ AnnOf -> "of"
+ AnnOpenB -> "(|"
+ AnnOpenBU -> "⦇"
+ AnnOpenC -> "{"
+ AnnOpenE -> "[e|"
+ AnnOpenEQ -> "[|"
+ AnnOpenEQU -> "⟦"
+ AnnOpenP -> "("
+ AnnOpenPH -> "(#"
+ AnnOpenS -> "["
+ AnnPattern -> "pattern"
+ AnnPercent -> "%"
+ AnnPercentOne -> "%1"
+ AnnProc -> "proc"
+ AnnQualified -> "qualified"
+ AnnRarrow -> "->"
+ AnnRec -> "rec"
+ AnnRole -> "role"
+ AnnSafe -> "safe"
+ AnnSemi -> ";"
+ AnnSignature -> "signature"
+ AnnStock -> "stock"
+ AnnStatic -> "static"
+ AnnThen -> "then"
+ AnnTilde -> "~"
+ AnnType -> "type"
+ AnnUnit -> "()"
+ AnnUsing -> "using"
+ AnnVbar -> "|"
+ AnnWhere -> "where"
+ Annlarrowtail -> "-<"
+ Annrarrowtail -> ">-"
+ AnnLarrowtail -> "-<<"
+ AnnRarrowtail -> ">>-"
+ AnnSimpleQuote -> "'"
+ AnnThTyQuote -> "''"
+ AnnDollar -> "$"
+ AnnDollarDollar -> "$$"
+ AnnDarrowU -> "⇒"
+ AnnDcolonU -> "∷"
+ AnnForallU -> "∀"
+ AnnLarrowU -> "←"
+ AnnLarrowtailU -> "⤛"
+ AnnRarrowU -> "→"
+ AnnRarrowtailU -> "⤜"
+ AnnlarrowtailU -> "⤙"
+ AnnrarrowtailU -> "⤚"
+ AnnVia -> "via"
=====================================
utils/check-exact/Main.hs
=====================================
@@ -36,9 +36,8 @@ import GHC.Data.FastString
-- ---------------------------------------------------------------------
_tt :: IO ()
--- _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/lib"
+_tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/lib/"
-- _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/exactprint/_build/stage1/lib"
-_tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/master/_build/stage1/lib"
-- _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/epw/_build/stage1/lib"
-- "../../testsuite/tests/ghc-api/exactprint/RenameCase1.hs" (Just changeRenameCase1)
@@ -79,7 +78,6 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/master/_b
-- "../../testsuite/tests/ghc-api/exactprint/RmTypeSig2.hs" (Just rmTypeSig2)
-- "../../testsuite/tests/ghc-api/exactprint/AddHiding1.hs" (Just addHiding1)
-- "../../testsuite/tests/ghc-api/exactprint/AddHiding2.hs" (Just addHiding2)
-
-- "../../testsuite/tests/printer/Ppr001.hs" Nothing
-- "../../testsuite/tests/ghc-api/annotations/CommentsTest.hs" Nothing
-- "../../testsuite/tests/hiefile/should_compile/Constructors.hs" Nothing
@@ -163,6 +161,7 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/master/_b
-- "../../testsuite/tests/printer/T15761.hs" Nothing
-- "../../testsuite/tests/printer/T18052a.hs" Nothing
-- "../../testsuite/tests/printer/T18247a.hs" Nothing
+ -- "../../testsuite/tests/printer/Test10268.hs" Nothing
-- "../../testsuite/tests/printer/Test10276.hs" Nothing
-- "../../testsuite/tests/printer/Test10278.hs" Nothing
-- "../../testsuite/tests/printer/Test10312.hs" Nothing
@@ -195,12 +194,14 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/master/_b
-- "../../testsuite/tests/printer/Test19834.hs" Nothing
-- "../../testsuite/tests/printer/Test19840.hs" Nothing
-- "../../testsuite/tests/printer/Test19850.hs" Nothing
+ "../../testsuite/tests/printer/Test20258.hs" Nothing
-- "../../testsuite/tests/printer/PprLinearArrow.hs" Nothing
-- "../../testsuite/tests/printer/PprSemis.hs" Nothing
-- "../../testsuite/tests/printer/PprEmptyMostly.hs" Nothing
-- "../../testsuite/tests/parser/should_compile/DumpSemis.hs" Nothing
-- "../../testsuite/tests/ghc-api/exactprint/Test20239.hs" Nothing
- "../../testsuite/tests/printer/Test21805.hs" Nothing
+ -- "../../testsuite/tests/printer/PprArrowLambdaCase.hs" Nothing
+ -- "../../testsuite/tests/printer/Test16279.hs" Nothing
-- cloneT does not need a test, function can be retired
@@ -265,6 +266,7 @@ main :: IO()
main = do
args <- getArgs
case args of
+ [] -> _tt
[libdir,fileName] -> testOneFile changers libdir fileName Nothing
[libdir,fileName,changerStr] -> do
case lookup changerStr changers of
@@ -373,6 +375,9 @@ type Changer = FilePath -> (ParsedSource -> IO ParsedSource)
noChange :: Changer
noChange _libdir parsed = return parsed
+-- changeDeltaAst :: Changer
+-- changeDeltaAst _libdir parsed = return (makeDeltaAst parsed)
+
changeRenameCase1 :: Changer
changeRenameCase1 _libdir parsed = return (rename "bazLonger" [((3,15),(3,18))] parsed)
@@ -401,9 +406,9 @@ changeRename1 _libdir parsed = return (rename "bar2" [((3,1),(3,4))] parsed)
changeRename2 :: Changer
changeRename2 _libdir parsed = return (rename "joe" [((2,1),(2,5))] parsed)
-rename :: (Data a) => String -> [(Pos, Pos)] -> a -> a
+rename :: (Data a, ExactPrint a) => String -> [(Pos, Pos)] -> a -> a
rename newNameStr spans' a
- = everywhere (mkT replaceRdr) a
+ = everywhere (mkT replaceRdr) (makeDeltaAst a)
where
newName = mkRdrUnqual (mkVarOcc newNameStr)
@@ -419,7 +424,7 @@ rename newNameStr spans' a
changeWhereIn4 :: Changer
changeWhereIn4 _libdir parsed
- = return (everywhere (mkT replace) parsed)
+ = return (everywhere (mkT replace) (makeDeltaAst parsed))
where
replace :: LocatedN RdrName -> LocatedN RdrName
replace (L ln _n)
@@ -453,9 +458,9 @@ changeLetIn1 _libdir parsed
changeAddDecl1 :: Changer
changeAddDecl1 libdir top = do
Right decl <- withDynFlags libdir (\df -> parseDecl df "<interactive>" "nn = n2")
- let decl' = setEntryDP' decl (DifferentLine 2 0)
+ let decl' = setEntryDP decl (DifferentLine 2 0)
- let (p',(_,_),_) = runTransform mempty doAddDecl
+ let (p',_,_) = runTransform doAddDecl
doAddDecl = everywhereM (mkM replaceTopLevelDecls) top
replaceTopLevelDecls :: ParsedSource -> Transform ParsedSource
replaceTopLevelDecls m = insertAtStart m decl'
@@ -466,11 +471,10 @@ changeAddDecl1 libdir top = do
changeAddDecl2 :: Changer
changeAddDecl2 libdir top = do
Right decl <- withDynFlags libdir (\df -> parseDecl df "<interactive>" "nn = n2")
- let decl' = setEntryDP' decl (DifferentLine 2 0)
- let top' = anchorEof top
+ let decl' = setEntryDP (makeDeltaAst decl) (DifferentLine 2 0)
- let (p',(_,_),_) = runTransform mempty doAddDecl
- doAddDecl = everywhereM (mkM replaceTopLevelDecls) top'
+ let (p',_,_) = runTransform doAddDecl
+ doAddDecl = everywhereM (mkM replaceTopLevelDecls) (makeDeltaAst top)
replaceTopLevelDecls :: ParsedSource -> Transform ParsedSource
replaceTopLevelDecls m = insertAtEnd m decl'
return p'
@@ -480,13 +484,13 @@ changeAddDecl2 libdir top = do
changeAddDecl3 :: Changer
changeAddDecl3 libdir top = do
Right decl <- withDynFlags libdir (\df -> parseDecl df "<interactive>" "nn = n2")
- let decl' = setEntryDP' decl (DifferentLine 2 0)
+ let decl' = setEntryDP decl (DifferentLine 2 0)
- let (p',(_,_),_) = runTransform mempty doAddDecl
+ let (p',_,_) = runTransform doAddDecl
doAddDecl = everywhereM (mkM replaceTopLevelDecls) top
f d (l1:l2:ls) = (l1:d:l2':ls)
where
- l2' = setEntryDP' l2 (DifferentLine 2 0)
+ l2' = setEntryDP l2 (DifferentLine 2 0)
replaceTopLevelDecls :: ParsedSource -> Transform ParsedSource
replaceTopLevelDecls m = insertAt f m decl'
@@ -499,9 +503,9 @@ changeLocalDecls :: Changer
changeLocalDecls libdir (L l p) = do
Right s@(L ls (SigD _ sig)) <- withDynFlags libdir (\df -> parseDecl df "sig" "nn :: Int")
Right d@(L ld (ValD _ decl)) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2")
- let decl' = setEntryDP' (L ld decl) (DifferentLine 1 0)
- let sig' = setEntryDP' (L ls sig) (SameLine 0)
- let (p',(_,_),_w) = runTransform mempty doAddLocal
+ let decl' = setEntryDP (L ld decl) (DifferentLine 1 0)
+ let sig' = setEntryDP (L ls sig) (SameLine 0)
+ let (p',_,_w) = runTransform doAddLocal
doAddLocal = everywhereM (mkM replaceLocalBinds) p
replaceLocalBinds :: LMatch GhcPs (LHsExpr GhcPs)
-> Transform (LMatch GhcPs (LHsExpr GhcPs))
@@ -511,10 +515,10 @@ changeLocalDecls libdir (L l p) = do
let oldDecls' = captureLineSpacing oldDecls
let oldBinds = concatMap decl2Bind oldDecls'
(os:oldSigs) = concatMap decl2Sig oldDecls'
- os' = setEntryDP' os (DifferentLine 2 0)
+ os' = setEntryDP os (DifferentLine 2 0)
let sortKey = captureOrder 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 5)))) a b c dd) cs)
+ let van' = (EpAnn anc (AnnList (Just (Anchor anc2 (MovedAnchor (DifferentLine 1 4)))) a b c dd) cs)
let binds' = (HsValBinds van'
(ValBinds sortKey (listToBag $ decl':oldBinds)
(sig':os':oldSigs)))
@@ -530,19 +534,19 @@ changeLocalDecls2 :: Changer
changeLocalDecls2 libdir (L l p) = do
Right d@(L ld (ValD _ decl)) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2")
Right s@(L ls (SigD _ sig)) <- withDynFlags libdir (\df -> parseDecl df "sig" "nn :: Int")
- let decl' = setEntryDP' (L ld decl) (DifferentLine 1 0)
- let sig' = setEntryDP' (L ls sig) (SameLine 2)
- let (p',(_,_),_w) = runTransform mempty doAddLocal
+ let decl' = setEntryDP (L ld decl) (DifferentLine 1 0)
+ let sig' = setEntryDP (L ls sig) (SameLine 2)
+ let (p',_,_w) = runTransform doAddLocal
doAddLocal = everywhereM (mkM replaceLocalBinds) p
replaceLocalBinds :: LMatch GhcPs (LHsExpr GhcPs)
-> Transform (LMatch GhcPs (LHsExpr GhcPs))
replaceLocalBinds (L lm (Match ma mln pats (GRHSs _ rhs EmptyLocalBinds{}))) = do
newSpan <- uniqueSrcSpanT
- let anc = (Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 3)))
- let anc2 = (Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 5)))
+ let anc = (Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 2)))
+ let anc2 = (Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 4)))
let an = EpAnn anc
(AnnList (Just anc2) Nothing Nothing
- [(undeltaSpan (rs newSpan) AnnWhere (SameLine 0))] [])
+ [AddEpAnn AnnWhere (EpaDelta (SameLine 0) [])] [])
emptyComments
let decls = [s,d]
let sortKey = captureOrder decls
@@ -558,10 +562,8 @@ changeLocalDecls2 libdir (L l p) = do
changeWhereIn3a :: Changer
changeWhereIn3a _libdir (L l p) = do
let decls0 = hsmodDecls p
- (decls,(_,_),w) = runTransform mempty (balanceCommentsList decls0)
- -- (_de0:_:de1:_d2:_) = decls
+ (decls,_,w) = runTransform (balanceCommentsList decls0)
debugM $ unlines w
- -- debugM $ "changeWhereIn3a:de1:" ++ showAst de1
let p2 = p { hsmodDecls = decls}
return (L l p2)
@@ -570,11 +572,11 @@ changeWhereIn3a _libdir (L l p) = do
changeWhereIn3b :: Changer
changeWhereIn3b _libdir (L l p) = do
let decls0 = hsmodDecls p
- (decls,(_,_),w) = runTransform mempty (balanceCommentsList decls0)
+ (decls,_,w) = runTransform (balanceCommentsList decls0)
(de0:_:de1:d2:_) = decls
- de0' = setEntryDP' de0 (DifferentLine 2 0)
- de1' = setEntryDP' de1 (DifferentLine 2 0)
- d2' = setEntryDP' d2 (DifferentLine 2 0)
+ de0' = setEntryDP de0 (DifferentLine 2 0)
+ de1' = setEntryDP de1 (DifferentLine 2 0)
+ d2' = setEntryDP d2 (DifferentLine 2 0)
decls' = d2':de1':de0':(tail decls)
debugM $ unlines w
debugM $ "changeWhereIn3b:de1':" ++ showAst de1'
@@ -584,17 +586,18 @@ changeWhereIn3b _libdir (L l p) = do
-- ---------------------------------------------------------------------
addLocaLDecl1 :: Changer
-addLocaLDecl1 libdir lp = do
+addLocaLDecl1 libdir top = do
Right (L ld (ValD _ decl)) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2")
- let decl' = setEntryDP' (L ld decl) (DifferentLine 1 5)
+ let decl' = setEntryDP (L ld decl) (DifferentLine 1 5)
doAddLocal = do
+ let lp = makeDeltaAst top
(de1:d2:d3:_) <- hsDecls lp
(de1'',d2') <- balanceComments de1 d2
(de1',_) <- modifyValD (getLocA de1'') de1'' $ \_m d -> do
return ((wrapDecl decl' : d),Nothing)
replaceDecls lp [de1', d2', d3]
- (lp',(_,_),w) <- runTransformT mempty doAddLocal
+ (lp',_,w) <- runTransformT doAddLocal
debugM $ "addLocaLDecl1:" ++ intercalate "\n" w
return lp'
@@ -610,32 +613,33 @@ addLocaLDecl2 libdir lp = do
(parent',_) <- modifyValD (getLocA de1) de1'' $ \_m (d:ds) -> do
newDecl' <- transferEntryDP' d newDecl
- let d' = setEntryDP' d (DifferentLine 1 0)
+ let d' = setEntryDP d (DifferentLine 1 0)
return ((newDecl':d':ds),Nothing)
replaceDecls lp [parent',d2']
- (lp',(_,_),_w) <- runTransformT mempty doAddLocal
+ (lp',_,_w) <- runTransformT doAddLocal
debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
return lp'
-- ---------------------------------------------------------------------
addLocaLDecl3 :: Changer
-addLocaLDecl3 libdir lp = do
+addLocaLDecl3 libdir top = do
Right newDecl <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2")
let
doAddLocal = do
+ let lp = makeDeltaAst top
(de1:d2:_) <- hsDecls lp
(de1'',d2') <- balanceComments de1 d2
(parent',_) <- modifyValD (getLocA de1) de1'' $ \_m (d:ds) -> do
- let newDecl' = setEntryDP' newDecl (DifferentLine 1 0)
+ let newDecl' = setEntryDP newDecl (DifferentLine 1 0)
return (((d:ds) ++ [newDecl']),Nothing)
replaceDecls (anchorEof lp) [parent',d2']
- (lp',(_,_),_w) <- runTransformT mempty doAddLocal
+ (lp',_,_w) <- runTransformT doAddLocal
debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
return lp'
@@ -649,15 +653,15 @@ addLocaLDecl4 libdir lp = do
doAddLocal = do
(parent:ds) <- hsDecls lp
- let newDecl' = setEntryDP' newDecl (DifferentLine 1 0)
- let newSig' = setEntryDP' newSig (DifferentLine 1 4)
+ let newDecl' = setEntryDP newDecl (DifferentLine 1 0)
+ let newSig' = setEntryDP newSig (DifferentLine 1 4)
(parent',_) <- modifyValD (getLocA parent) parent $ \_m decls -> do
return ((decls++[newSig',newDecl']),Nothing)
replaceDecls (anchorEof lp) (parent':ds)
- (lp',(_,_),_w) <- runTransformT mempty doAddLocal
+ (lp',_,_w) <- runTransformT doAddLocal
debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
return lp'
@@ -671,14 +675,14 @@ addLocaLDecl5 _libdir lp = do
decls <- hsDecls lp
[s1,de1,d2,d3] <- balanceCommentsList decls
- let d3' = setEntryDP' d3 (DifferentLine 2 0)
+ let d3' = setEntryDP d3 (DifferentLine 2 0)
(de1',_) <- modifyValD (getLocA de1) de1 $ \_m _decls -> do
- let d2' = setEntryDP' d2 (DifferentLine 1 0)
+ let d2' = setEntryDP d2 (DifferentLine 1 0)
return ([d2'],Nothing)
replaceDecls lp [s1,de1',d3']
- (lp',(_,_),_w) <- runTransformT mempty doAddLocal
+ (lp',_,_w) <- runTransformT doAddLocal
debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
return lp'
@@ -688,7 +692,7 @@ addLocaLDecl6 :: Changer
addLocaLDecl6 libdir lp = do
Right newDecl <- withDynFlags libdir (\df -> parseDecl df "decl" "x = 3")
let
- newDecl' = setEntryDP' newDecl (DifferentLine 1 4)
+ newDecl' = setEntryDP newDecl (DifferentLine 1 4)
doAddLocal = do
decls0 <- hsDecls lp
[de1'',d2] <- balanceCommentsList decls0
@@ -701,23 +705,24 @@ addLocaLDecl6 libdir lp = do
return ((newDecl' : decls),Nothing)
replaceDecls lp [de1', d2]
- (lp',(_,_),_w) <- runTransformT mempty doAddLocal
+ (lp',_,_w) <- runTransformT doAddLocal
debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
return lp'
-- ---------------------------------------------------------------------
rmDecl1 :: Changer
-rmDecl1 _libdir lp = do
+rmDecl1 _libdir top = do
let doRmDecl = do
+ let lp = makeDeltaAst top
tlDecs0 <- hsDecls lp
tlDecs <- balanceCommentsList $ captureLineSpacing tlDecs0
let (de1:_s1:_d2:d3:ds) = tlDecs
- let d3' = setEntryDP' d3 (DifferentLine 2 0)
+ let d3' = setEntryDP d3 (DifferentLine 2 0)
replaceDecls lp (de1:d3':ds)
- (lp',(_,_),_w) <- runTransformT mempty doRmDecl
+ (lp',_,_w) <- runTransformT doRmDecl
debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
return lp'
@@ -738,7 +743,7 @@ rmDecl2 _libdir lp = do
everywhereM (mkM go) lp
- let (lp',(_,_),_w) = runTransform mempty doRmDecl
+ let (lp',_,_w) = runTransform doRmDecl
debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
return lp'
@@ -751,12 +756,12 @@ rmDecl3 _libdir lp = do
[de1,d2] <- hsDecls lp
(de1',Just sd1) <- modifyValD (getLocA de1) de1 $ \_m [sd1] -> do
- let sd1' = setEntryDP' sd1 (DifferentLine 2 0)
+ let sd1' = setEntryDP sd1 (DifferentLine 2 0)
return ([],Just sd1')
replaceDecls lp [de1',sd1,d2]
- (lp',(_,_),_w) <- runTransformT mempty doRmDecl
+ (lp',_,_w) <- runTransformT doRmDecl
debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
return lp'
@@ -771,12 +776,12 @@ rmDecl4 _libdir lp = do
(de1',Just sd1) <- modifyValD (getLocA de1) de1 $ \_m [sd1,sd2] -> do
sd2' <- transferEntryDP' sd1 sd2
- let sd1' = setEntryDP' sd1 (DifferentLine 2 0)
+ let sd1' = setEntryDP sd1 (DifferentLine 2 0)
return ([sd2'],Just sd1')
replaceDecls (anchorEof lp) [de1',sd1]
- (lp',(_,_),_w) <- runTransformT mempty doRmDecl
+ (lp',_,_w) <- runTransformT doRmDecl
debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
return lp'
@@ -791,14 +796,14 @@ rmDecl5 _libdir lp = do
go (HsLet a tkLet lb tkIn expr) = do
decs <- hsDeclsValBinds lb
let dec = last decs
- _ <- transferEntryDPT (head decs) dec
+ _ <- transferEntryDP (head decs) dec
lb' <- replaceDeclsValbinds WithoutWhere lb [dec]
return (HsLet a tkLet lb' tkIn expr)
go x = return x
everywhereM (mkM go) lp
- let (lp',(_,_),_w) = runTransform mempty doRmDecl
+ let (lp',_,_w) = runTransform doRmDecl
debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
return lp'
@@ -818,16 +823,17 @@ rmDecl6 _libdir lp = do
replaceDecls lp [de1']
- (lp',(_,_),_w) <- runTransformT mempty doRmDecl
+ (lp',_,_w) <- runTransformT doRmDecl
debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
return lp'
-- ---------------------------------------------------------------------
rmDecl7 :: Changer
-rmDecl7 _libdir lp = do
+rmDecl7 _libdir top = do
let
doRmDecl = do
+ let lp = makeDeltaAst top
tlDecs <- hsDecls lp
[s1,de1,d2,d3] <- balanceCommentsList tlDecs
@@ -835,7 +841,7 @@ rmDecl7 _libdir lp = do
replaceDecls lp [s1,de1,d3']
- (lp',(_,_),_w) <- runTransformT mempty doRmDecl
+ (lp',_,_w) <- runTransformT doRmDecl
debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
return lp'
@@ -852,7 +858,7 @@ rmTypeSig1 _libdir lp = do
let s1' = (L l (SigD x1 (TypeSig x2 [n2'] typ)))
replaceDecls lp (s1':de1:d2)
- let (lp',(_,_),_w) = runTransform mempty doRmDecl
+ let (lp',_,_w) = runTransform doRmDecl
debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
return lp'
@@ -865,11 +871,11 @@ rmTypeSig2 _libdir lp = do
let [de1] = tlDecs
(de1',_) <- modifyValD (getLocA de1) de1 $ \_m [s,d] -> do
- d' <- transferEntryDPT s d
+ d' <- transferEntryDP s d
return ([d'],Nothing)
replaceDecls lp [de1']
- let (lp',(_,_),_w) = runTransform mempty doRmDecl
+ let (lp',_,_w) = runTransform doRmDecl
debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
return lp'
@@ -898,15 +904,16 @@ addHiding1 _libdir (L l p) = do
p' = p { hsmodImports = [L li imp1',imp2]}
return (L l p')
- let (lp',(_ans',_),_w) = runTransform mempty doTransform
+ let (lp',_,_w) = runTransform doTransform
debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
return lp'
-- ---------------------------------------------------------------------
addHiding2 :: Changer
-addHiding2 _libdir (L l p) = do
+addHiding2 _libdir top = do
let doTransform = do
+ let (L l p) = makeDeltaAst top
l1 <- uniqueSrcSpanT
l2 <- uniqueSrcSpanT
let
@@ -929,7 +936,7 @@ addHiding2 _libdir (L l p) = do
p' = p { hsmodImports = [L li imp1']}
return (L l p')
- let (lp',(_ans',_),_w) = runTransform mempty doTransform
+ let (lp',_,_w) = runTransform doTransform
debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
return lp'
=====================================
utils/check-exact/Orphans.hs
=====================================
@@ -0,0 +1,92 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+module Orphans where
+
+-- import Data.Default
+import GHC hiding (EpaComment)
+
+-- ---------------------------------------------------------------------
+
+class Default a where
+ def :: a
+
+-- ---------------------------------------------------------------------
+-- Orphan Default instances. See https://gitlab.haskell.org/ghc/ghc/-/issues/20372
+
+instance Default [a] where
+ def = []
+
+instance Default NameAnn where
+ def = mempty
+
+instance Default AnnList where
+ def = mempty
+
+instance Default AnnListItem where
+ def = mempty
+
+instance Default AnnPragma where
+ def = AnnPragma def def def
+
+instance Semigroup EpAnnImportDecl where
+ (<>) = error "unimplemented"
+instance Default EpAnnImportDecl where
+ def = EpAnnImportDecl def Nothing Nothing Nothing Nothing Nothing
+
+instance Default HsRuleAnn where
+ def = HsRuleAnn Nothing Nothing def
+
+instance Default AnnSig where
+ def = AnnSig def def
+
+instance Default GrhsAnn where
+ def = GrhsAnn Nothing def
+
+instance Default EpAnnUnboundVar where
+ def = EpAnnUnboundVar def def
+
+instance (Default a, Default b) => Default (a, b) where
+ def = (def, def)
+
+instance Default NoEpAnns where
+ def = NoEpAnns
+
+instance Default AnnParen where
+ def = AnnParen AnnParens def def
+
+instance Default AnnExplicitSum where
+ def = AnnExplicitSum def def def def
+
+instance Default EpAnnHsCase where
+ def = EpAnnHsCase def def def
+
+instance Default AnnsIf where
+ def = AnnsIf def def def def def
+
+instance Default (Maybe a) where
+ def = Nothing
+
+instance Default AnnProjection where
+ def = AnnProjection def def
+
+instance Default AnnFieldLabel where
+ def = AnnFieldLabel Nothing
+
+instance Default EpaLocation where
+ def = EpaDelta (SameLine 0) []
+
+instance Default AddEpAnn where
+ def = AddEpAnn def def
+
+instance Default AnnKeywordId where
+ def = Annlarrowtail {- gotta pick one -}
+
+instance Default AnnContext where
+ def = AnnContext Nothing [] []
+
+instance Default EpAnnSumPat where
+ def = EpAnnSumPat def def def
+
+instance Default AnnsModule where
+ def = AnnsModule [] mempty
=====================================
utils/check-exact/Parsers.hs
=====================================
@@ -111,7 +111,7 @@ runParser parser flags filename str = GHC.unP parser parseState
-- @
-- myParser fname expr = withDynFlags (\\d -> parseExpr d fname expr)
-- @
-withDynFlags :: FilePath -> (GHC.DynFlags -> a) -> IO a
+withDynFlags :: LibDir -> (GHC.DynFlags -> a) -> IO a
withDynFlags libdir action = ghcWrapper libdir $ do
dflags <- GHC.getSessionDynFlags
void $ GHC.setSessionDynFlags dflags
@@ -171,7 +171,7 @@ parseModule libdir file = parseModuleWithCpp libdir defaultCppOptions file
-- string; the `FilePath` parameter solely exists to provide a name
-- in source location annotations.
parseModuleFromString
- :: FilePath -- GHC libdir
+ :: LibDir -- GHC libdir
-> FilePath
-> String
-> IO (ParseResult GHC.ParsedSource)
@@ -190,7 +190,7 @@ parseModuleFromStringInternal dflags fileName str =
-> Right (lp, dflags, pmod)
in postParseTransform res
-parseModuleWithOptions :: FilePath -- ^ GHC libdir
+parseModuleWithOptions :: LibDir -- ^ GHC libdir
-> FilePath
-> IO (ParseResult GHC.ParsedSource)
parseModuleWithOptions libdir fp =
@@ -199,7 +199,7 @@ parseModuleWithOptions libdir fp =
-- | Parse a module with specific instructions for the C pre-processor.
parseModuleWithCpp
- :: FilePath -- ^ GHC libdir
+ :: LibDir -- ^ GHC libdir
-> CppOptions
-> FilePath -- ^ File to be parsed
-> IO (ParseResult GHC.ParsedSource)
@@ -213,7 +213,7 @@ parseModuleWithCpp libdir cpp fp = do
-- It is advised to use 'parseModule' or 'parseModuleWithCpp' instead of
-- this function.
parseModuleEpAnnsWithCpp
- :: FilePath -- ^ GHC libdir
+ :: LibDir -- ^ GHC libdir
-> CppOptions
-> FilePath -- ^ File to be parsed
-> IO
@@ -226,7 +226,7 @@ parseModuleEpAnnsWithCpp libdir cppOptions file = ghcWrapper libdir $ do
parseModuleEpAnnsWithCppInternal cppOptions dflags file
-- | Internal function. Default runner of GHC.Ghc action in IO.
-ghcWrapper :: FilePath -> GHC.Ghc a -> IO a
+ghcWrapper :: LibDir -> GHC.Ghc a -> IO a
ghcWrapper libdir a =
GHC.defaultErrorHandler GHC.defaultFatalMessager GHC.defaultFlushOut
$ GHC.runGhc (Just libdir) a
@@ -303,6 +303,7 @@ fixModuleTrailingComments (GHC.L l p) = GHC.L l p'
-- See ghc tickets #15513, #15541.
initDynFlags :: GHC.GhcMonad m => FilePath -> m GHC.DynFlags
initDynFlags file = do
+ -- Based on GHC backpack driver doBackPack
dflags0 <- GHC.getSessionDynFlags
let parser_opts0 = GHC.initParserOpts dflags0
(_, src_opts) <- GHC.liftIO $ GHC.getOptionsFromFile parser_opts0 file
@@ -327,6 +328,7 @@ initDynFlags file = do
-- See ghc tickets #15513, #15541.
initDynFlagsPure :: GHC.GhcMonad m => FilePath -> String -> m GHC.DynFlags
initDynFlagsPure fp s = do
+ -- AZ Note: "I" below appears to be Lennart Spitzner
-- I was told we could get away with using the unsafeGlobalDynFlags.
-- as long as `parseDynamicFilePragma` is impure there seems to be
-- no reason to use it.
=====================================
utils/check-exact/Preprocess.hs
=====================================
@@ -1,5 +1,6 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
-- | This module provides support for CPP, interpreter directives and line
-- pragmas.
module Preprocess
@@ -16,6 +17,7 @@ module Preprocess
import qualified GHC as GHC hiding (parseModule)
import qualified Control.Monad.IO.Class as GHC
+import qualified GHC.Data.Bag as GHC
import qualified GHC.Data.FastString as GHC
import qualified GHC.Data.StringBuffer as GHC
import qualified GHC.Driver.Config.Parser as GHC
@@ -26,17 +28,16 @@ import qualified GHC.Driver.Pipeline as GHC
import qualified GHC.Fingerprint.Type as GHC
import qualified GHC.Parser.Lexer as GHC
import qualified GHC.Settings as GHC
-import qualified GHC.Types.Error as GHC (getMessages)
+import qualified GHC.Types.Error as GHC (getErrorMessages, DiagnosticMessage(..))
import qualified GHC.Types.SourceError as GHC
import qualified GHC.Types.SourceFile as GHC
import qualified GHC.Types.SrcLoc as GHC
import qualified GHC.Utils.Error as GHC
import qualified GHC.Utils.Fingerprint as GHC
-import qualified GHC.Utils.Outputable as GHC
import GHC.Types.SrcLoc (mkSrcSpan, mkSrcLoc)
import GHC.Data.FastString (mkFastString)
-import Data.List (isPrefixOf)
+import Data.List (isPrefixOf, intercalate)
import Data.Maybe
import Types
import Utils
@@ -74,14 +75,14 @@ checkLine line s
size = length pragma
mSrcLoc = mkSrcLoc (mkFastString "LINE")
ss = mkSrcSpan (mSrcLoc line 1) (mSrcLoc line (size+1))
- in (res, Just $ mkLEpaComment pragma (GHC.spanAsAnchor ss))
+ in (res, Just $ mkLEpaComment pragma (GHC.spanAsAnchor ss) (GHC.realSrcSpan ss))
-- Deal with shebang/cpp directives too
-- x | "#" `isPrefixOf` s = ("",Just $ Comment ((line, 1), (line, length s)) s)
| "#!" `isPrefixOf` s =
let mSrcLoc = mkSrcLoc (mkFastString "SHEBANG")
ss = mkSrcSpan (mSrcLoc line 1) (mSrcLoc line (length s))
in
- ("",Just $ mkLEpaComment s (GHC.spanAsAnchor ss))
+ ("",Just $ mkLEpaComment s (GHC.spanAsAnchor ss) (GHC.realSrcSpan ss))
| otherwise = (s, Nothing)
getPragma :: String -> (String, String)
@@ -124,8 +125,8 @@ goodComment :: GHC.LEpaComment -> Bool
goodComment c = isGoodComment (tokComment c)
where
isGoodComment :: Comment -> Bool
- isGoodComment (Comment "" _ _) = False
- isGoodComment _ = True
+ isGoodComment (Comment "" _ _ _) = False
+ isGoodComment _ = True
toRealLocated :: GHC.Located a -> GHC.RealLocated a
@@ -167,7 +168,7 @@ getCppTokens directiveToks origSrcToks postCppToks = toks
missingAsComments = map mkCommentTok missingToks
where
mkCommentTok :: (GHC.Located GHC.Token,String) -> (GHC.Located GHC.Token,String)
- mkCommentTok (GHC.L l _,s) = (GHC.L l (GHC.ITlineComment s placeholderBufSpan),s)
+ mkCommentTok (GHC.L l _,s) = (GHC.L l (GHC.ITlineComment s (makeBufSpan l)),s)
toks = mergeBy locFn directiveToks missingAsComments
@@ -213,23 +214,29 @@ getPreprocessedSrcDirectPrim :: (GHC.GhcMonad m)
-> m (String, GHC.StringBuffer, GHC.DynFlags)
getPreprocessedSrcDirectPrim cppOptions src_fn = do
hsc_env <- GHC.getSession
- let dflags = GHC.hsc_dflags hsc_env
- new_env = GHC.hscSetFlags (injectCppOptions cppOptions dflags) hsc_env
+ let dfs = GHC.hsc_dflags hsc_env
+ new_env = hsc_env { GHC.hsc_dflags = injectCppOptions cppOptions dfs }
r <- GHC.liftIO $ GHC.preprocess new_env src_fn Nothing (Just (GHC.Cpp GHC.HsSrcFile))
case r of
- Left err -> error $ showErrorMessages err
+ Left err -> error $ showErrorMessages $ fmap GHC.GhcDriverMessage err
Right (dflags', hspp_fn) -> do
buf <- GHC.liftIO $ GHC.hGetStringBuffer hspp_fn
txt <- GHC.liftIO $ readFileGhc hspp_fn
return (txt, buf, dflags')
-showErrorMessages :: GHC.Messages GHC.DriverMessage -> String
-showErrorMessages msgs =
- GHC.renderWithContext GHC.defaultSDocContext
- $ GHC.vcat
- $ GHC.pprMsgEnvelopeBagWithLoc
- $ GHC.getMessages
- $ msgs
+showErrorMessages :: GHC.ErrorMessages -> String
+showErrorMessages msgs = intercalate "\n"
+ $ map (show @(GHC.MsgEnvelope GHC.DiagnosticMessage) . fmap toDiagnosticMessage)
+ $ GHC.bagToList
+ $ GHC.getErrorMessages msgs
+
+-- | Show Error Messages relies on show instance for MsgEnvelope DiagnosticMessage
+-- We convert a known Diagnostic into this generic version
+toDiagnosticMessage :: GHC.Diagnostic e => e -> GHC.DiagnosticMessage
+toDiagnosticMessage msg = GHC.DiagnosticMessage { diagMessage = GHC.diagnosticMessage msg
+ , diagReason = GHC.diagnosticReason msg
+ , diagHints = GHC.diagnosticHints msg
+ }
injectCppOptions :: CppOptions -> GHC.DynFlags -> GHC.DynFlags
injectCppOptions CppOptions{..} dflags =
@@ -261,7 +268,7 @@ getPreprocessorAsComments srcFile = do
let directives = filter (\(_lineNum,line) -> line /= [] && head line == '#')
$ zip [1..] (lines fcontents)
- let mkTok (lineNum,line) = (GHC.L l (GHC.ITlineComment line placeholderBufSpan),line)
+ let mkTok (lineNum,line) = (GHC.L l (GHC.ITlineComment line (makeBufSpan l)),line)
where
start = GHC.mkSrcLoc (GHC.mkFastString srcFile) lineNum 1
end = GHC.mkSrcLoc (GHC.mkFastString srcFile) lineNum (length line)
@@ -270,11 +277,11 @@ getPreprocessorAsComments srcFile = do
let toks = map mkTok directives
return toks
-placeholderBufSpan :: GHC.PsSpan
-placeholderBufSpan = pspan
+makeBufSpan :: GHC.SrcSpan -> GHC.PsSpan
+makeBufSpan ss = pspan
where
bl = GHC.BufPos 0
- pspan = GHC.PsSpan GHC.placeholderRealSpan (GHC.BufSpan bl bl)
+ pspan = GHC.PsSpan (GHC.realSrcSpan ss) (GHC.BufSpan bl bl)
-- ---------------------------------------------------------------------
@@ -283,7 +290,8 @@ parseError pst = do
let
-- (warns,errs) = GHC.getMessages pst dflags
-- throw $ GHC.mkSrcErr (GHC.unitBag $ GHC.mkPlainErrMsg dflags sspan err)
- GHC.throwErrors $ (GHC.GhcPsMessage <$> GHC.getPsErrorMessages pst)
+ -- GHC.throwErrors (fmap GHC.mkParserErr (GHC.getErrorMessages pst))
+ GHC.throwErrors (fmap GHC.GhcPsMessage (GHC.getPsErrorMessages pst))
-- ---------------------------------------------------------------------
=====================================
utils/check-exact/Transform.hs
=====================================
@@ -5,6 +5,7 @@
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
-----------------------------------------------------------------------------
-- |
@@ -31,26 +32,11 @@ module Transform
-- * Transform monad operations
, logTr
, logDataWithAnnsTr
- , getAnnsT, putAnnsT, modifyAnnsT
, uniqueSrcSpanT
- , cloneT
- , graftT
-
- , getEntryDPT
- , setEntryDPT
- , transferEntryDPT
- , setPrecedingLinesDeclT
- , setPrecedingLinesT
- , addSimpleAnnT
- , addTrailingCommaT
- , removeTrailingCommaT
-
-- ** Managing declarations, in Transform monad
, HasTransform (..)
, HasDecls (..)
- , hasDeclsSybTransform
- , hsDeclsGeneric
, hsDeclsPatBind, hsDeclsPatBindD
, replaceDeclsPatBind, replaceDeclsPatBindD
, modifyDeclsT
@@ -79,8 +65,6 @@ module Transform
, balanceComments
, balanceCommentsList
, balanceCommentsList'
- , balanceTrailingComments
- , moveTrailingComments
, anchorEof
-- ** Managing lists, pure functions
@@ -93,23 +77,17 @@ module Transform
, isUniqueSrcSpan
-- * Pure functions
- , mergeAnns
- , mergeAnnList
- , setPrecedingLinesDecl
- , setPrecedingLines
- , getEntryDP
, setEntryDP
- , setEntryDP'
+ , getEntryDP
, transferEntryDP
, transferEntryDP'
- , addTrailingComma
, wrapSig, wrapDecl
, decl2Sig, decl2Bind
- , deltaAnchor
) where
import Types
import Utils
+import Orphans (Default(..))
import Control.Monad.RWS
import qualified Control.Monad.Fail as Fail
@@ -119,15 +97,11 @@ import GHC.Data.Bag
import GHC.Data.FastString
import Data.Data
-import Data.List (sortBy, sortOn, find)
+import Data.List ( sortBy )
import Data.Maybe
-import qualified Data.Map as Map
-
import Data.Functor.Identity
import Control.Monad.State
-import Control.Monad.Writer
-
------------------------------------------------------------------------------
-- Transformation of source elements
@@ -137,11 +111,11 @@ import Control.Monad.Writer
type Transform = TransformT Identity
-- |Monad transformer version of 'Transform' monad
-newtype TransformT m a = TransformT { unTransformT :: RWST () [String] (Anns,Int) m a }
+newtype TransformT m a = TransformT { unTransformT :: RWST () [String] Int m a }
deriving (Monad,Applicative,Functor
,MonadReader ()
,MonadWriter [String]
- ,MonadState (Anns,Int)
+ ,MonadState Int
,MonadTrans
)
@@ -150,21 +124,21 @@ instance Fail.MonadFail m => Fail.MonadFail (TransformT m) where
-- | Run a transformation in the 'Transform' monad, returning the updated
-- annotations and any logging generated via 'logTr'
-runTransform :: Anns -> Transform a -> (a,(Anns,Int),[String])
-runTransform ans f = runTransformFrom 0 ans f
+runTransform :: Transform a -> (a,Int,[String])
+runTransform f = runTransformFrom 0 f
-runTransformT :: Anns -> TransformT m a -> m (a,(Anns,Int),[String])
-runTransformT ans f = runTransformFromT 0 ans f
+runTransformT :: TransformT m a -> m (a,Int,[String])
+runTransformT f = runTransformFromT 0 f
-- | Run a transformation in the 'Transform' monad, returning the updated
-- annotations and any logging generated via 'logTr', allocating any new
-- SrcSpans from the provided initial value.
-runTransformFrom :: Int -> Anns -> Transform a -> (a,(Anns,Int),[String])
-runTransformFrom seed ans f = runRWS (unTransformT f) () (ans,seed)
+runTransformFrom :: Int -> Transform a -> (a,Int,[String])
+runTransformFrom seed f = runRWS (unTransformT f) () seed
-- |Run a monad transformer stack for the 'TransformT' monad transformer
-runTransformFromT :: Int -> Anns -> TransformT m a -> m (a,(Anns,Int),[String])
-runTransformFromT seed ans f = runRWST (unTransformT f) () (ans,seed)
+runTransformFromT :: Int -> TransformT m a -> m (a,Int,[String])
+runTransformFromT seed f = runRWST (unTransformT f) () seed
-- | Change inner monad of 'TransformT'.
hoistTransform :: (forall x. m x -> n x) -> TransformT m a -> TransformT n a
@@ -180,31 +154,14 @@ logDataWithAnnsTr :: (Monad m) => (Data a) => String -> a -> TransformT m ()
logDataWithAnnsTr str ast = do
logTr $ str ++ showAst ast
--- |Access the 'Anns' being modified in this transformation
-getAnnsT :: (Monad m) => TransformT m Anns
-getAnnsT = gets fst
-
--- |Replace the 'Anns' after any changes
-putAnnsT :: (Monad m) => Anns -> TransformT m ()
-putAnnsT ans = do
- (_,col) <- get
- put (ans,col)
-
--- |Change the stored 'Anns'
-modifyAnnsT :: (Monad m) => (Anns -> Anns) -> TransformT m ()
-modifyAnnsT f = do
- ans <- getAnnsT
- putAnnsT (f ans)
-
-- ---------------------------------------------------------------------
--- |Once we have 'Anns', a 'SrcSpan' is used purely as part of an 'AnnKey'
--- to index into the 'Anns'. If we need to add new elements to the AST, they
--- need their own 'SrcSpan' for this.
+-- |If we need to add new elements to the AST, they need their own
+-- 'SrcSpan' for this.
uniqueSrcSpanT :: (Monad m) => TransformT m SrcSpan
uniqueSrcSpanT = do
- (an,col) <- get
- put (an,col + 1 )
+ col <- get
+ put (col + 1 )
let pos = mkSrcLoc (mkFastString "ghc-exactprint") (-1) col
return $ mkSrcSpan pos pos
@@ -216,43 +173,6 @@ srcSpanStartLine' :: SrcSpan -> Int
srcSpanStartLine' (RealSrcSpan s _) = srcSpanStartLine s
srcSpanStartLine' _ = 0
--- ---------------------------------------------------------------------
--- |Make a copy of an AST element, replacing the existing SrcSpans with new
--- ones, and duplicating the matching annotations.
-cloneT :: (Data a,Monad m) => a -> TransformT m (a, [(SrcSpan, SrcSpan)])
-cloneT ast = do
- runWriterT $ everywhereM (return `ext2M` replaceLocated) ast
- where
- replaceLocated :: forall loc a m. (Typeable loc,Data a,Monad m)
- => (GenLocated loc a) -> WriterT [(SrcSpan, SrcSpan)] (TransformT m) (GenLocated loc a)
- replaceLocated (L l t) = do
- case cast l :: Maybe SrcSpan of
- Just ss -> do
- newSpan <- lift uniqueSrcSpanT
- lift $ modifyAnnsT (\anns -> case Map.lookup (mkAnnKey (L ss t)) anns of
- Nothing -> anns
- Just an -> Map.insert (mkAnnKey (L newSpan t)) an anns)
- tell [(ss, newSpan)]
- return $ fromJust . cast $ L newSpan t
- Nothing -> return (L l t)
-
--- ---------------------------------------------------------------------
--- |Slightly more general form of cloneT
-graftT :: (Data a,Monad m) => Anns -> a -> TransformT m a
-graftT origAnns = everywhereM (return `ext2M` replaceLocated)
- where
- replaceLocated :: forall loc a m. (Typeable loc, Data a, Monad m)
- => GenLocated loc a -> TransformT m (GenLocated loc a)
- replaceLocated (L l t) = do
- case cast l :: Maybe SrcSpan of
- Just ss -> do
- newSpan <- uniqueSrcSpanT
- modifyAnnsT (\anns -> case Map.lookup (mkAnnKey (L ss t)) origAnns of
- Nothing -> anns
- Just an -> Map.insert (mkAnnKey (L newSpan t)) an anns)
- return $ fromJust $ cast $ L newSpan t
- Nothing -> return (L l t)
-
-- ---------------------------------------------------------------------
-- |If a list has been re-ordered or had items added, capture the new order in
@@ -270,7 +190,7 @@ captureMatchLineSpacing (L l (ValD x (FunBind a b (MG c (L d ms )))))
ms' = captureLineSpacing ms
captureMatchLineSpacing d = d
-captureLineSpacing :: Monoid t
+captureLineSpacing :: Default t
=> [LocatedAn t e] -> [LocatedAn t e]
captureLineSpacing [] = []
captureLineSpacing [d] = [d]
@@ -278,7 +198,7 @@ captureLineSpacing (de1:d2:ds) = de1:captureLineSpacing (d2':ds)
where
(l1,_) = ss2pos $ rs $ getLocA de1
(l2,_) = ss2pos $ rs $ getLocA d2
- d2' = setEntryDP' d2 (deltaPos (l2-l1) 0)
+ d2' = setEntryDP d2 (deltaPos (l2-l1) 0)
-- ---------------------------------------------------------------------
@@ -292,7 +212,6 @@ captureTypeSigSpacing (L l (SigD x (TypeSig (EpAnn anc (AnnSig dc rs') cs) ns (H
rd = case last ns of
L (SrcSpanAnn EpAnnNotUsed ll) _ -> realSrcSpan ll
L (SrcSpanAnn (EpAnn anc' _ _) _) _ -> anchor anc' -- TODO MovedAnchor?
- -- DP (line, col) = ss2delta (ss2pos $ anchor $ getLoc lc) r
dc' = case dca of
EpaSpan r -> AddEpAnn kw (EpaDelta (ss2delta (ss2posEnd rd) r) [])
EpaDelta _ _ -> AddEpAnn kw dca
@@ -348,131 +267,51 @@ wrapDecl (L l s) = L l (ValD NoExtField s)
-- ---------------------------------------------------------------------
--- |Create a simple 'Annotation' without comments, and attach it to the first
--- parameter.
-addSimpleAnnT :: (Data a,Monad m)
- => Located a -> DeltaPos -> [(KeywordId, DeltaPos)] -> TransformT m ()
-addSimpleAnnT ast dp kds = do
- let ann = annNone { annEntryDelta = dp
- , annsDP = kds
- }
- modifyAnnsT (Map.insert (mkAnnKey ast) ann)
-
--- ---------------------------------------------------------------------
-
--- |Add a trailing comma annotation, unless there is already one
-addTrailingCommaT :: (Data a,Monad m) => Located a -> TransformT m ()
-addTrailingCommaT ast = do
- modifyAnnsT (addTrailingComma ast (SameLine 0))
-
--- ---------------------------------------------------------------------
-
--- |Remove a trailing comma annotation, if there is one one
-removeTrailingCommaT :: (Data a,Monad m) => Located a -> TransformT m ()
-removeTrailingCommaT ast = do
- modifyAnnsT (removeTrailingComma ast)
-
--- ---------------------------------------------------------------------
-
--- |'Transform' monad version of 'getEntryDP'
-getEntryDPT :: (Data a,Monad m) => Located a -> TransformT m DeltaPos
-getEntryDPT ast = do
- anns <- getAnnsT
- return (getEntryDP anns ast)
-
--- ---------------------------------------------------------------------
-
--- |'Transform' monad version of 'getEntryDP'
-setEntryDPT :: (Monad m) => LocatedA a -> DeltaPos -> TransformT m ()
-setEntryDPT ast dp = do
- modifyAnnsT (setEntryDP ast dp)
-
--- ---------------------------------------------------------------------
-
--- |'Transform' monad version of 'transferEntryDP'
-transferEntryDPT :: (Monad m) => LocatedA a -> LocatedA b -> TransformT m (LocatedA b)
-transferEntryDPT _a b = do
- return b
- -- modifyAnnsT (transferEntryDP a b)
-
--- ---------------------------------------------------------------------
-
--- |'Transform' monad version of 'setPrecedingLinesDecl'
-setPrecedingLinesDeclT :: (Monad m) => LHsDecl GhcPs -> Int -> Int -> TransformT m ()
-setPrecedingLinesDeclT ld n c =
- modifyAnnsT (setPrecedingLinesDecl ld n c)
-
--- ---------------------------------------------------------------------
-
--- |'Transform' monad version of 'setPrecedingLines'
-setPrecedingLinesT :: (Monad m) => LocatedA a -> Int -> Int -> TransformT m ()
-setPrecedingLinesT ld n c =
- modifyAnnsT (setPrecedingLines ld n c)
-
--- ---------------------------------------------------------------------
-
--- | Left bias pair union
-mergeAnns :: Anns -> Anns -> Anns
-mergeAnns
- = Map.union
-
--- |Combine a list of annotations
-mergeAnnList :: [Anns] -> Anns
-mergeAnnList [] = error "mergeAnnList must have at lease one entry"
-mergeAnnList (x:xs) = foldr mergeAnns x xs
-
--- ---------------------------------------------------------------------
-
--- |Unwrap a HsDecl and call setPrecedingLines on it
--- ++AZ++ TODO: get rid of this, it is a synonym only
-setPrecedingLinesDecl :: LHsDecl GhcPs -> Int -> Int -> Anns -> Anns
-setPrecedingLinesDecl ld n c ans = setPrecedingLines ld n c ans
-
--- ---------------------------------------------------------------------
-
--- | Adjust the entry annotations to provide an `n` line preceding gap
-setPrecedingLines :: LocatedA a -> Int -> Int -> Anns -> Anns
-setPrecedingLines ast n c anne = setEntryDP ast (deltaPos n c) anne
-
--- ---------------------------------------------------------------------
-
--- |Return the true entry 'DeltaPos' from the annotation for a given AST
--- element. This is the 'DeltaPos' ignoring any comments.
-getEntryDP :: (Data a) => Anns -> Located a -> DeltaPos
-getEntryDP anns ast =
- case Map.lookup (mkAnnKey ast) anns of
- Nothing -> SameLine 0
- Just ann -> annTrueEntryDelta ann
-
--- ---------------------------------------------------------------------
-
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'))))
where
- L l' _ = setEntryDP' decl dp
+ L l' _ = setEntryDP decl dp
ms' :: [LMatch GhcPs (LHsExpr GhcPs)]
ms' = case ms of
[] -> []
- (m0':ms0) -> setEntryDP' m0' dp : ms0
-setEntryDPDecl d dp = setEntryDP' d dp
+ (m0':ms0) -> setEntryDP m0' dp : ms0
+setEntryDPDecl d dp = setEntryDP d dp
-- ---------------------------------------------------------------------
-- |Set the true entry 'DeltaPos' from the annotation for a given AST
-- element. This is the 'DeltaPos' ignoring any comments.
--- setEntryDP' :: (Data a) => LocatedA a -> DeltaPos -> LocatedA a
-setEntryDP' :: (Monoid t) => LocatedAn t a -> DeltaPos -> LocatedAn t a
-setEntryDP' (L (SrcSpanAnn EpAnnNotUsed l) a) dp
+setEntryDP :: Default t => LocatedAn t a -> DeltaPos -> LocatedAn t a
+setEntryDP (L (SrcSpanAnn EpAnnNotUsed l) a) dp
= L (SrcSpanAnn
- (EpAnn (Anchor (realSrcSpan l) (MovedAnchor dp)) mempty emptyComments)
+ (EpAnn (Anchor (realSrcSpan l) (MovedAnchor dp)) def emptyComments)
l) a
-setEntryDP' (L (SrcSpanAnn (EpAnn (Anchor r _) an (EpaComments [])) l) a) dp
+setEntryDP (L (SrcSpanAnn (EpAnn (Anchor r _) an (EpaComments [])) l) a) dp
= L (SrcSpanAnn
(EpAnn (Anchor r (MovedAnchor dp)) an (EpaComments []))
l) a
-setEntryDP' (L (SrcSpanAnn (EpAnn (Anchor r _) an cs) l) a) dp
- = case sortAnchorLocated (priorComments cs) of
+setEntryDP (L (SrcSpanAnn (EpAnn (Anchor r (MovedAnchor d)) an cs) l) a) dp
+ = L (SrcSpanAnn
+ (EpAnn (Anchor r (MovedAnchor d')) an cs')
+ l) a
+ where
+ (d',cs') = case cs of
+ EpaComments (h:t) ->
+ let
+ (dp0,c') = go h
+ in
+ (dp0, EpaComments (c':t))
+ EpaCommentsBalanced (h:t) ts ->
+ let
+ (dp0,c') = go h
+ in
+ (dp0, EpaCommentsBalanced (c':t) ts)
+ _ -> (dp, cs)
+ go (L (Anchor rr (MovedAnchor ma)) c) = (d, L (Anchor rr (MovedAnchor ma)) c)
+ go (L (Anchor rr _) c) = (d, L (Anchor rr (MovedAnchor dp)) c)
+setEntryDP (L (SrcSpanAnn (EpAnn (Anchor r _) an cs) l) a) dp
+ = case sortEpaComments (priorComments cs) of
[] ->
L (SrcSpanAnn
(EpAnn (Anchor r (MovedAnchor dp)) an cs)
@@ -484,57 +323,59 @@ setEntryDP' (L (SrcSpanAnn (EpAnn (Anchor r _) an cs) l) a) dp
where
cs'' = setPriorComments cs (L (Anchor (anchor ca) (MovedAnchor dp)) c:cs')
lc = head $ reverse $ (L ca c:cs')
- delta = ss2delta (ss2pos $ anchor $ getLoc lc) r
+ delta = tweakDelta $ ss2delta (ss2pos $ anchor $ getLoc lc) r
line = getDeltaLine delta
col = deltaColumn delta
- -- TODO: this adjustment by 1 happens all over the place. Generalise it
edp' = if line == 0 then SameLine col
else DifferentLine line col
- edp = edp' `debug` ("setEntryDP' :" ++ showGhc (edp', (ss2pos $ anchor $ getLoc lc), r))
+ edp = edp' `debug` ("setEntryDP :" ++ showGhc (edp', (ss2pos $ anchor $ getLoc lc), r))
--- |Set the true entry 'DeltaPos' from the annotation for a given AST
--- element. This is the 'DeltaPos' ignoring any comments.
-setEntryDP :: LocatedA a -> DeltaPos -> Anns -> Anns
-setEntryDP _ast _dp anns = anns
+
+-- ---------------------------------------------------------------------
+
+getEntryDP :: LocatedAn t a -> DeltaPos
+getEntryDP (L (SrcSpanAnn (EpAnn (Anchor _ (MovedAnchor dp)) _ _) _) _) = dp
+getEntryDP _ = SameLine 1
-- ---------------------------------------------------------------------
addEpaLocationDelta :: LayoutStartCol -> RealSrcSpan -> EpaLocation -> EpaLocation
addEpaLocationDelta _off _anc (EpaDelta d cs) = EpaDelta d cs
addEpaLocationDelta off anc (EpaSpan r)
- = EpaDelta (adjustDeltaForOffset 0 off (ss2deltaEnd anc r)) []
+ = EpaDelta (adjustDeltaForOffset off (ss2deltaEnd anc r)) []
-- Set the entry DP for an element coming after an existing keyword annotation
setEntryDPFromAnchor :: LayoutStartCol -> EpaLocation -> LocatedA t -> LocatedA t
setEntryDPFromAnchor _off (EpaDelta _ _) (L la a) = L la a
-setEntryDPFromAnchor off (EpaSpan anc) ll@(L la _) = setEntryDP' ll dp'
+setEntryDPFromAnchor off (EpaSpan anc) ll@(L la _) = setEntryDP ll dp'
where
r = case la of
(SrcSpanAnn EpAnnNotUsed l) -> realSrcSpan l
(SrcSpanAnn (EpAnn (Anchor r' _) _ _) _) -> r'
- dp' = adjustDeltaForOffset 0 off (ss2deltaEnd anc r)
+ dp' = adjustDeltaForOffset off (ss2deltaEnd anc r)
-- ---------------------------------------------------------------------
-- |Take the annEntryDelta associated with the first item and associate it with the second.
-- Also transfer any comments occuring before it.
-transferEntryDP :: (Monad m, Monoid t) => LocatedAn t a -> LocatedAn t b -> TransformT m (LocatedAn t b)
+transferEntryDP :: (Monad m, Monoid t2, Typeable t1, Typeable t2)
+ => LocatedAn t1 a -> LocatedAn t2 b -> TransformT m (LocatedAn t2 b)
transferEntryDP (L (SrcSpanAnn EpAnnNotUsed l1) _) (L (SrcSpanAnn EpAnnNotUsed _) b) = do
logTr $ "transferEntryDP': EpAnnNotUsed,EpAnnNotUsed"
return (L (SrcSpanAnn EpAnnNotUsed l1) b)
transferEntryDP (L (SrcSpanAnn (EpAnn anc _an cs) _l1) _) (L (SrcSpanAnn EpAnnNotUsed l2) b) = do
logTr $ "transferEntryDP': EpAnn,EpAnnNotUsed"
return (L (SrcSpanAnn (EpAnn anc mempty cs) l2) b)
-transferEntryDP (L (SrcSpanAnn (EpAnn anc1 _an1 cs1) _l1) _) (L (SrcSpanAnn (EpAnn _anc2 an2 cs2) l2) b) = do
+transferEntryDP (L (SrcSpanAnn (EpAnn anc1 an1 cs1) _l1) _) (L (SrcSpanAnn (EpAnn _anc2 an2 cs2) l2) b) = do
logTr $ "transferEntryDP': EpAnn,EpAnn"
-- Problem: if the original had preceding comments, blindly
-- transferring the location is not correct
case priorComments cs1 of
- [] -> return (L (SrcSpanAnn (EpAnn anc1 an2 cs2) l2) b)
+ [] -> return (L (SrcSpanAnn (EpAnn anc1 (combine an1 an2) cs2) l2) b)
-- TODO: what happens if the receiving side already has comments?
(L anc _:_) -> do
logDataWithAnnsTr "transferEntryDP':priorComments anc=" anc
- return (L (SrcSpanAnn (EpAnn anc an2 cs2) l2) b)
+ return (L (SrcSpanAnn (EpAnn anc1 (combine an1 an2) (cs1 <> cs2)) l2) b)
transferEntryDP (L (SrcSpanAnn EpAnnNotUsed _l1) _) (L (SrcSpanAnn (EpAnn anc2 an2 cs2) l2) b) = do
logTr $ "transferEntryDP': EpAnnNotUsed,EpAnn"
return (L (SrcSpanAnn (EpAnn anc2' an2 cs2) l2) b)
@@ -542,6 +383,11 @@ transferEntryDP (L (SrcSpanAnn EpAnnNotUsed _l1) _) (L (SrcSpanAnn (EpAnn anc2 a
anc2' = case anc2 of
Anchor _a op -> Anchor (realSrcSpan l2) op
+
+-- |If a and b are the same type return first arg, else return second
+combine :: (Typeable a, Typeable b) => a -> b -> b
+combine x y = fromMaybe y (cast x)
+
-- |Take the annEntryDelta associated with the first item and associate it with the second.
-- Also transfer any comments occuring before it.
-- TODO: call transferEntryDP, and use pushDeclDP
@@ -555,49 +401,24 @@ pushDeclDP :: HsDecl GhcPs -> DeltaPos -> HsDecl GhcPs
pushDeclDP (ValD x (FunBind a b (MG c (L d ms )))) dp
= ValD x (FunBind a b (MG c (L d' ms')))
where
- L d' _ = setEntryDP' (L d ms) dp
+ L d' _ = setEntryDP (L d ms) dp
ms' :: [LMatch GhcPs (LHsExpr GhcPs)]
ms' = case ms of
[] -> []
- (m0':ms0) -> setEntryDP' m0' dp : ms0
+ (m0':ms0) -> setEntryDP m0' dp : ms0
pushDeclDP d _dp = d
-- ---------------------------------------------------------------------
-addTrailingComma :: (Data a) => Located a -> DeltaPos -> Anns -> Anns
-addTrailingComma a dp anns =
- case Map.lookup (mkAnnKey a) anns of
- Nothing -> anns
- Just an ->
- case find isAnnComma (annsDP an) of
- Nothing -> Map.insert (mkAnnKey a) (an { annsDP = annsDP an ++ [(G AnnComma,dp)]}) anns
- Just _ -> anns
- where
- isAnnComma (G AnnComma,_) = True
- isAnnComma _ = False
-
--- ---------------------------------------------------------------------
-
-removeTrailingComma :: (Data a) => Located a -> Anns -> Anns
-removeTrailingComma a anns =
- case Map.lookup (mkAnnKey a) anns of
- Nothing -> anns
- Just an ->
- case find isAnnComma (annsDP an) of
- Nothing -> anns
- Just _ -> Map.insert (mkAnnKey a) (an { annsDP = filter (not.isAnnComma) (annsDP an) }) anns
- where
- isAnnComma (G AnnComma,_) = True
- isAnnComma _ = False
-
--- ---------------------------------------------------------------------
-
balanceCommentsList :: (Monad m) => [LHsDecl GhcPs] -> TransformT m [LHsDecl GhcPs]
-balanceCommentsList [] = return []
-balanceCommentsList [x] = return [x]
-balanceCommentsList (a:b:ls) = do
+balanceCommentsList ds = balanceCommentsList'' ds
+
+balanceCommentsList'' :: (Monad m) => [LHsDecl GhcPs] -> TransformT m [LHsDecl GhcPs]
+balanceCommentsList'' [] = return []
+balanceCommentsList'' [x] = return [x]
+balanceCommentsList'' (a:b:ls) = do
(a',b') <- balanceComments a b
- r <- balanceCommentsList (b':ls)
+ r <- balanceCommentsList'' (b':ls)
return (a':r)
-- |The GHC parser puts all comments appearing between the end of one AST
@@ -610,8 +431,6 @@ balanceComments :: (Monad m)
=> LHsDecl GhcPs -> LHsDecl GhcPs
-> TransformT m (LHsDecl GhcPs, LHsDecl GhcPs)
balanceComments first second = do
- -- logTr $ "balanceComments entered"
- -- logDataWithAnnsTr "first" first
case first of
(L l (ValD x fb@(FunBind{}))) -> do
(L l' fb',second') <- balanceCommentsFB (L l fb) second
@@ -631,11 +450,11 @@ balanceCommentsFB (L lf (FunBind x n (MG o (L lm matches)))) second = do
-- + move the trailing ones to the last match.
let
split = splitCommentsEnd (realSrcSpan $ locA lf) (epAnnComments $ ann lf)
- split2 = splitCommentsStart (realSrcSpan $ locA lf) (EpaComments (sortAnchorLocated $ priorComments split))
+ split2 = splitCommentsStart (realSrcSpan $ locA lf) (EpaComments (sortEpaComments $ priorComments split))
- before = sortAnchorLocated $ priorComments split2
- middle = sortAnchorLocated $ getFollowingComments split2
- after = sortAnchorLocated $ getFollowingComments split
+ before = sortEpaComments $ priorComments split2
+ middle = sortEpaComments $ getFollowingComments split2
+ after = sortEpaComments $ getFollowingComments split
lf' = setCommentsSrcAnn lf (EpaComments before)
logTr $ "balanceCommentsFB (before, after): " ++ showAst (before, after)
@@ -654,7 +473,6 @@ balanceCommentsFB (L lf (FunBind x n (MG o (L lm matches)))) second = do
[] -> moveLeadingComments m'' lf'
_ -> (m'',lf')
logTr $ "balanceCommentsMatch done"
- -- return (L lf'' (FunBind x n (MG mx (L lm (reverse (m''':ms))) o) t), second')
balanceComments' (L lf'' (FunBind x n (MG o (L lm (reverse (m''':ms)))))) second'
balanceCommentsFB f s = balanceComments' f s
@@ -663,13 +481,7 @@ balanceCommentsFB f s = balanceComments' f s
balanceCommentsMatch :: (Monad m)
=> LMatch GhcPs (LHsExpr GhcPs) -> TransformT m (LMatch GhcPs (LHsExpr GhcPs))
balanceCommentsMatch (L l (Match am mctxt pats (GRHSs xg grhss binds))) = do
- logTr $ "balanceCommentsMatch: (loc1)=" ++ showGhc (ss2range (locA l))
- -- logTr $ "balanceCommentsMatch: (move',stay')=" ++ showAst (move',stay')
logTr $ "balanceCommentsMatch: (logInfo)=" ++ showAst (logInfo)
- -- logTr $ "balanceCommentsMatch: (loc1)=" ++ showGhc (ss2range (locA l))
- logTr $ "balanceCommentsMatch: (anc1,cs1f)=" ++ showAst (anc1,cs1f)
- logTr $ "balanceCommentsMatch: (move,stay)=" ++ showAst (move,stay)
- logTr $ "balanceCommentsMatch: (l'', grhss')=" ++ showAst (l'', grhss')
return (L l'' (Match am mctxt pats (GRHSs xg grhss' binds')))
where
simpleBreak (r,_) = r /= 0
@@ -681,8 +493,9 @@ balanceCommentsMatch (L l (Match am mctxt pats (GRHSs xg grhss binds))) = do
stay = map snd stay'
(l'', grhss', binds', logInfo)
= case reverse grhss of
- [] -> (l, [], binds, (EpaComments [], SrcSpanAnn EpAnnNotUsed noSrcSpan))
- (L lg g@(GRHS EpAnnNotUsed _grs _rhs):gs) -> (l, reverse (L lg g:gs), binds, (EpaComments [], SrcSpanAnn EpAnnNotUsed noSrcSpan))
+ [] -> (l, [], binds, (EpaComments [], SrcSpanAnn EpAnnNotUsed noSrcSpan))
+ (L lg g@(GRHS EpAnnNotUsed _grs _rhs):gs)
+ -> (l, reverse (L lg g:gs), binds, (EpaComments [], SrcSpanAnn EpAnnNotUsed noSrcSpan))
(L lg (GRHS ag grs rhs):gs) ->
let
anc1' = setFollowingComments anc1 stay
@@ -707,11 +520,11 @@ pushTrailingComments _ _cs (HsIPBinds _ _) = error "TODO: pushTrailingComments:H
pushTrailingComments w cs lb@(HsValBinds an _)
= (True, HsValBinds an' vb)
where
- (decls, _, _ws1) = runTransform mempty (hsDeclsValBinds lb)
+ (decls, _, _ws1) = runTransform (hsDeclsValBinds lb)
(an', decls') = case reverse decls of
[] -> (addCommentsToEpAnn (spanHsLocaLBinds lb) an cs, decls)
(L la d:ds) -> (an, L (addCommentsToSrcAnn la cs) d:ds)
- (vb,_ws2) = case runTransform mempty (replaceDeclsValbinds w lb (reverse decls')) of
+ (vb,_ws2) = case runTransform (replaceDeclsValbinds w lb (reverse decls')) of
((HsValBinds _ vb'), _, ws2') -> (vb', ws2')
_ -> (ValBinds NoAnnSortKey emptyBag [], [])
@@ -736,7 +549,6 @@ balanceComments' la1 la2 = do
logTr $ "balanceComments': (loc1,loc2)=" ++ showGhc (ss2range loc1,ss2range loc2)
logTr $ "balanceComments': (anc1)=" ++ showAst (anc1)
logTr $ "balanceComments': (cs1s)=" ++ showAst (cs1s)
- logTr $ "balanceComments': (sort cs1f)=" ++ showAst (sortOn fst cs1f)
logTr $ "balanceComments': (cs1stay,cs1move)=" ++ showAst (cs1stay,cs1move)
logTr $ "balanceComments': (an1',an2')=" ++ showAst (an1',an2')
return (la1', la2')
@@ -762,8 +574,8 @@ balanceComments' la1 la2 = do
-- Need to also check for comments more closely attached to la1,
-- ie trailing on the same line
(move'',stay') = break (simpleBreak 0) (trailingCommentsDeltas (anchorFromLocatedA la1) (map snd stay''))
- move = sortAnchorLocated $ map snd (cs1move ++ move'' ++ move')
- stay = sortAnchorLocated $ map snd (cs1stay ++ stay')
+ move = sortEpaComments $ map snd (cs1move ++ move'' ++ move')
+ stay = sortEpaComments $ map snd (cs1stay ++ stay')
an1' = setCommentsSrcAnn (getLoc la1) (EpaCommentsBalanced (map snd cs1p) move)
an2' = setCommentsSrcAnn (getLoc la2) (EpaCommentsBalanced stay (map snd cs2f))
@@ -785,7 +597,7 @@ trailingCommentsDeltas anc (la@(L l _):las)
-- AZ:TODO: this is identical to commentsDeltas
priorCommentsDeltas :: RealSrcSpan -> [LEpaComment]
-> [(Int, LEpaComment)]
-priorCommentsDeltas anc cs = go anc (reverse $ sortAnchorLocated cs)
+priorCommentsDeltas anc cs = go anc (reverse $ sortEpaComments cs)
where
go :: RealSrcSpan -> [LEpaComment] -> [(Int, LEpaComment)]
go _ [] = []
@@ -798,6 +610,8 @@ priorCommentsDeltas anc cs = go anc (reverse $ sortAnchorLocated cs)
(ll,_) = ss2pos (anchor loc)
+-- ---------------------------------------------------------------------
+
-- | Split comments into ones occuring before the end of the reference
-- span, and those after it.
splitCommentsEnd :: RealSrcSpan -> EpAnnComments -> EpAnnComments
@@ -839,8 +653,8 @@ moveLeadingComments (L la a) lb = (L la' a, lb')
`debug` ("moveLeadingComments: (before, after, la', lb'):" ++ showAst (before, after, la', lb'))
where
split = splitCommentsEnd (realSrcSpan $ locA la) (epAnnComments $ ann la)
- before = sortAnchorLocated $ priorComments split
- after = sortAnchorLocated $ getFollowingComments split
+ before = sortEpaComments $ priorComments split
+ after = sortEpaComments $ getFollowingComments split
-- TODO: need to set an entry delta on lb' to zero, and move the
-- original spacing to the first comment.
@@ -880,17 +694,30 @@ anchorFromLocatedA (L (SrcSpanAnn an loc) _)
commentOrigDelta :: LEpaComment -> LEpaComment
commentOrigDelta (L (GHC.Anchor la _) (GHC.EpaComment t pp))
= (L (GHC.Anchor la op) (GHC.EpaComment t pp))
+ `debug` ("commentOrigDelta: (la, pp, r,c, op)=" ++ showAst (la, pp, r,c, op))
where
(r,c) = ss2posEnd pp
+
op' = if r == 0
then MovedAnchor (ss2delta (r,c+1) la)
- else MovedAnchor (ss2delta (r,c) la)
+ -- then MovedAnchor (ss2delta (r,c+0) la)
+ -- else MovedAnchor (ss2delta (r,c) la)
+ else MovedAnchor (tweakDelta $ ss2delta (r,c) la)
op = if t == EpaEofComment && op' == MovedAnchor (SameLine 0)
then MovedAnchor (DifferentLine 1 0)
else op'
-- ---------------------------------------------------------------------
+
+-- | For comment-related deltas starting on a new line we have an
+-- off-by-one problem. Adjust
+tweakDelta :: DeltaPos -> DeltaPos
+tweakDelta (SameLine d) = SameLine d
+tweakDelta (DifferentLine l d) = DifferentLine l (d-1)
+
+-- ---------------------------------------------------------------------
+
balanceSameLineComments :: (Monad m)
=> LMatch GhcPs (LHsExpr GhcPs) -> TransformT m (LMatch GhcPs (LHsExpr GhcPs))
balanceSameLineComments (L la (Match anm mctxt pats (GRHSs x grhss lb))) = do
@@ -917,7 +744,7 @@ balanceSameLineComments (L la (Match anm mctxt pats (GRHSs x grhss lb))) = do
gac = addCommentOrigDeltas $ epAnnComments ga
gfc = getFollowingComments gac
- gac' = setFollowingComments gac (sortAnchorLocated $ gfc ++ move)
+ gac' = setFollowingComments gac (sortEpaComments $ gfc ++ move)
ga' = (EpAnn anc an gac')
an1' = setCommentsSrcAnn la cs1
@@ -925,59 +752,6 @@ balanceSameLineComments (L la (Match anm mctxt pats (GRHSs x grhss lb))) = do
-- ---------------------------------------------------------------------
-
--- |After moving an AST element, make sure any comments that may belong
--- with the following element in fact do. Of necessity this is a heuristic
--- process, to be tuned later. Possibly a variant should be provided with a
--- passed-in decision function.
-balanceTrailingComments :: (Monad m) => (Data a,Data b) => Located a -> Located b
- -> TransformT m [(Comment, DeltaPos)]
-balanceTrailingComments first second = do
- let
- k1 = mkAnnKey first
- k2 = mkAnnKey second
- moveComments p ans = (ans',move)
- where
- an1 = gfromJust "balanceTrailingComments k1" $ Map.lookup k1 ans
- an2 = gfromJust "balanceTrailingComments k2" $ Map.lookup k2 ans
- cs1f = annFollowingComments an1
- (move,stay) = break p cs1f
- an1' = an1 { annFollowingComments = stay }
- ans' = Map.insert k1 an1' $ Map.insert k2 an2 ans
-
- simpleBreak (_,SameLine _) = False
- simpleBreak (_,DifferentLine _ _) = True
-
- ans <- getAnnsT
- let (ans',mov) = moveComments simpleBreak ans
- putAnnsT ans'
- return mov
-
--- ---------------------------------------------------------------------
-
--- ++AZ++ TODO: This needs to be renamed/reworked, based on what it actually gets used for
--- |Move any 'annFollowingComments' values from the 'Annotation' associated to
--- the first parameter to that of the second.
-moveTrailingComments :: (Data a,Data b)
- => Located a -> Located b -> Transform ()
-moveTrailingComments first second = do
- let
- k1 = mkAnnKey first
- k2 = mkAnnKey second
- moveComments ans = ans'
- where
- an1 = gfromJust "moveTrailingComments k1" $ Map.lookup k1 ans
- an2 = gfromJust "moveTrailingComments k2" $ Map.lookup k2 ans
- cs1f = annFollowingComments an1
- cs2f = annFollowingComments an2
- an1' = an1 { annFollowingComments = [] }
- an2' = an2 { annFollowingComments = cs1f ++ cs2f }
- ans' = Map.insert k1 an1' $ Map.insert k2 an2' ans
-
- modifyAnnsT moveComments
-
--- ---------------------------------------------------------------------
-
anchorEof :: ParsedSource -> ParsedSource
anchorEof (L l m@(HsModule (XModulePs an _lo _ _) _mn _exps _imps _decls)) = L l (m { hsmodExt = (hsmodExt m){ hsmodAnn = an' } })
where
@@ -992,15 +766,6 @@ commentsOrigDeltasDecl (L (SrcSpanAnn an l) d) = L (SrcSpanAnn an' l) d
-- ---------------------------------------------------------------------
--- | Take an anchor and a preceding location, and generate an
--- equivalent one with a 'MovedAnchor' delta.
-deltaAnchor :: Anchor -> RealSrcSpan -> Anchor
-deltaAnchor (Anchor anc _) ss = Anchor anc (MovedAnchor dp)
- where
- dp = ss2delta (ss2pos anc) ss
-
--- ---------------------------------------------------------------------
-
-- | Create a @SrcSpanAnn@ with a @MovedAnchor@ operation using the
-- given @DeltaPos at .
noAnnSrcSpanDP :: (Monoid ann) => SrcSpan -> DeltaPos -> SrcSpanAnn' (EpAnn ann)
@@ -1026,13 +791,13 @@ dn :: Int -> EpaLocation
dn n = EpaDelta (SameLine n) []
m0 :: AnchorOperation
-m0 = MovedAnchor (SameLine 0)
+m0 = MovedAnchor $ SameLine 0
m1 :: AnchorOperation
-m1 = MovedAnchor (SameLine 1)
+m1 = MovedAnchor $ SameLine 1
mn :: Int -> AnchorOperation
-mn n = MovedAnchor (SameLine n)
+mn n = MovedAnchor $ SameLine n
addComma :: SrcSpanAnnA -> SrcSpanAnnA
addComma (SrcSpanAnn EpAnnNotUsed l)
@@ -1154,12 +919,7 @@ instance HasDecls (LocatedA (Match GhcPs (LocatedA (HsExpr GhcPs)))) where
(l', rhs') <- case binds of
EmptyLocalBinds{} -> do
logTr $ "replaceDecls LMatch empty binds"
- modifyAnnsT (setPrecedingLines (ghead "LMatch.replaceDecls" newBinds) 1 4)
- -- only move the comment if the original where clause was empty.
- -- toMove <- balanceTrailingComments m m
- -- insertCommentBefore (mkAnnKey m) toMove (matchEpAnn AnnWhere)
- -- TODO: move trailing comments on the same line to before the binds
logDataWithAnnsTr "Match.replaceDecls:balancing comments:m" m
L l' m' <- balanceSameLineComments m
logDataWithAnnsTr "Match.replaceDecls:(m1')" (L l' m')
@@ -1180,8 +940,8 @@ instance HasDecls (LocatedA (HsExpr GhcPs)) where
logTr "replaceDecls HsLet"
let lastAnc = realSrcSpan $ spanHsLocaLBinds binds
-- TODO: may be an intervening comment, take account for lastAnc
- let (newDecls', tkIn', ex') = case (tkLet, tkIn) of
- (L (TokenLoc l) _, L (TokenLoc i) _) ->
+ let (tkLet', tkIn', ex',newDecls') = case (tkLet, tkIn) of
+ (L (TokenLoc l) ls, L (TokenLoc i) is) ->
let
off = case l of
(EpaSpan r) -> LayoutStartCol $ snd $ ss2pos r
@@ -1191,12 +951,14 @@ instance HasDecls (LocatedA (HsExpr GhcPs)) where
newDecls'' = case newDecls of
[] -> newDecls
(d:ds) -> setEntryDPDecl d (SameLine 0) : ds
- in ( newDecls''
- , L (TokenLoc (addEpaLocationDelta off lastAnc i)) HsTok
- , ex'' )
- _ -> (newDecls, tkIn, ex)
+ -- in ( EpAnn a (AnnsLet l (addEpaLocationDelta off lastAnc i)) cs
+ in ( L (TokenLoc l) ls
+ , L (TokenLoc (addEpaLocationDelta off lastAnc i)) is
+ , ex''
+ , newDecls'')
+ (_,_) -> (tkLet, tkIn, ex, newDecls)
binds' <- replaceDeclsValbinds WithoutWhere binds newDecls'
- return (L ll (HsLet x tkLet binds' tkIn' ex'))
+ return (L ll (HsLet x tkLet' binds' tkIn' ex'))
-- TODO: does this make sense? Especially as no hsDecls for HsPar
replaceDecls (L l (HsPar x lpar e rpar)) newDecls
@@ -1246,21 +1008,7 @@ replaceDeclsPatBind :: (Monad m) => LHsBind GhcPs -> [LHsDecl GhcPs]
replaceDeclsPatBind (L l (PatBind x a (GRHSs xr rhss binds))) newDecls
= do
logTr "replaceDecls PatBind"
- -- Need to throw in a fresh where clause if the binds were empty,
- -- in the annotations.
- case binds of
- EmptyLocalBinds{} -> do
- let
- addWhere _mkds =
- error "TBD"
- modifyAnnsT addWhere
- modifyAnnsT (setPrecedingLines (ghead "LMatch.replaceDecls" newDecls) 1 4)
-
- _ -> return ()
-
- -- modifyAnnsT (captureOrderAnnKey (mkAnnKey p) newDecls)
binds'' <- replaceDeclsValbinds WithWhere binds newDecls
- -- let binds' = L (getLoc binds) binds''
return (L l (PatBind x a (GRHSs xr rhss binds'')))
replaceDeclsPatBind x _ = error $ "replaceDeclsPatBind called for:" ++ showGhc x
@@ -1275,9 +1023,7 @@ instance HasDecls (LocatedA (Stmt GhcPs (LocatedA (HsExpr GhcPs)))) where
replaceDecls (L l (LetStmt x lb)) newDecls
= do
- -- modifyAnnsT (captureOrder s newDecls)
lb'' <- replaceDeclsValbinds WithWhere lb newDecls
- -- let lb' = L (getLoc lb) lb''
return (L l (LetStmt x lb''))
replaceDecls (L l (LastStmt x e d se)) newDecls
= do
@@ -1300,102 +1046,6 @@ instance HasDecls (LocatedA (Stmt GhcPs (LocatedA (HsExpr GhcPs)))) where
-- ---------------------------------------------------------------------
--- |Do a transformation on an AST fragment by providing a function to process
--- the general case and one specific for a 'LHsBind'. This is required
--- because a 'FunBind' may have multiple 'Match' items, so we cannot
--- gurantee that 'replaceDecls' after 'hsDecls' is idempotent.
-hasDeclsSybTransform :: (Data t2,Monad m)
- => (forall t. HasDecls t => t -> m t)
- -- ^Worker function for the general case
- -> (LHsBind GhcPs -> m (LHsBind GhcPs))
- -- ^Worker function for FunBind/PatBind
- -> t2 -- ^Item to be updated
- -> m t2
-hasDeclsSybTransform workerHasDecls workerBind t = trf t
- where
- trf = mkM parsedSource
- `extM` lmatch
- `extM` lexpr
- `extM` lstmt
- `extM` lhsbind
- `extM` lvald
-
- parsedSource (p::ParsedSource) = workerHasDecls p
-
- lmatch (lm::LMatch GhcPs (LHsExpr GhcPs))
- = workerHasDecls lm
-
- lexpr (le::LHsExpr GhcPs)
- = workerHasDecls le
-
- lstmt (d::LStmt GhcPs (LHsExpr GhcPs))
- = workerHasDecls d
-
- lhsbind (b@(L _ FunBind{}):: LHsBind GhcPs)
- = workerBind b
- lhsbind b@(L _ PatBind{})
- = workerBind b
- lhsbind x = return x
-
- lvald (L l (ValD x d)) = do
- (L _ d') <- lhsbind (L l d)
- return (L l (ValD x d'))
- lvald x = return x
-
--- ---------------------------------------------------------------------
-
--- |A 'FunBind' wraps up one or more 'Match' items. 'hsDecls' cannot
--- return anything for these as there is not meaningful 'replaceDecls' for it.
--- This function provides a version of 'hsDecls' that returns the 'FunBind'
--- decls too, where they are needed for analysis only.
-hsDeclsGeneric :: (Data t,Monad m) => t -> TransformT m [LHsDecl GhcPs]
-hsDeclsGeneric t = q t
- where
- q = return []
- `mkQ` parsedSource
- `extQ` lmatch
- `extQ` lexpr
- `extQ` lstmt
- `extQ` lhsbind
- `extQ` lhsbindd
- `extQ` llocalbinds
- `extQ` localbinds
-
- parsedSource (p::ParsedSource) = hsDecls p
-
- lmatch (lm::LMatch GhcPs (LHsExpr GhcPs)) = hsDecls lm
-
- lexpr (le::LHsExpr GhcPs) = hsDecls le
-
- lstmt (d::LStmt GhcPs (LHsExpr GhcPs)) = hsDecls d
-
- -- ---------------------------------
-
- lhsbind :: (Monad m) => LHsBind GhcPs -> TransformT m [LHsDecl GhcPs]
- lhsbind (L _ (FunBind _ _ (MG _ (L _ matches)))) = do
- dss <- mapM hsDecls matches
- return (concat dss)
- lhsbind p@(L _ (PatBind{})) = do
- hsDeclsPatBind p
- lhsbind _ = return []
-
- -- ---------------------------------
-
- lhsbindd (L l (ValD _ d)) = lhsbind (L l d)
- lhsbindd _ = return []
-
- -- ---------------------------------
-
- llocalbinds :: (Monad m) => Located (HsLocalBinds GhcPs) -> TransformT m [LHsDecl GhcPs]
- llocalbinds (L _ ds) = localbinds ds
-
- -- ---------------------------------
-
- localbinds :: (Monad m) => HsLocalBinds GhcPs -> TransformT m [LHsDecl GhcPs]
- localbinds d = hsDeclsValBinds d
-
--- ---------------------------------------------------------------------
-
-- |Look up the annotated order and sort the decls accordingly
-- TODO:AZ: this should be pure
orderedDecls :: (Monad m)
@@ -1492,8 +1142,8 @@ oldWhereAnnotation (EpAnn anc an cs) ww _oldSpan = do
newWhereAnnotation :: (Monad m) => WithWhere -> TransformT m (EpAnn AnnList)
newWhereAnnotation ww = do
newSpan <- uniqueSrcSpanT
- let anc = Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 3))
- let anc2 = Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 5))
+ let anc = Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 2))
+ let anc2 = Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 4))
let w = case ww of
WithWhere -> [AddEpAnn AnnWhere (EpaDelta (SameLine 0) [])]
WithoutWhere -> []
@@ -1558,5 +1208,3 @@ modifyDeclsT action t = do
decls <- liftT $ hsDecls t
decls' <- action decls
liftT $ replaceDecls t decls'
-
--- ---------------------------------------------------------------------
=====================================
utils/check-exact/Types.hs
=====================================
@@ -13,120 +13,17 @@ module Types
import GHC hiding (EpaComment)
import GHC.Utils.Outputable hiding ( (<>) )
-import Data.Data (Data, toConstr,cast)
-
-import qualified Data.Map as Map
+import Data.Data (Data)
-- ---------------------------------------------------------------------
--- | This structure holds a complete set of annotations for an AST
-type Anns = Map.Map AnnKey Annotation
-
-emptyAnns :: Anns
-emptyAnns = Map.empty
-
--- | For every @Located a@, use the @SrcSpan@ and constructor name of
--- a as the key, to store the standard annotation.
--- These are used to maintain context in the AP and EP monads
-data AnnKey = AnnKey RealSrcSpan AnnConName
- deriving (Eq, Data, Ord)
-
--- More compact Show instance
-instance Show AnnKey where
- show (AnnKey ss cn) = "AnnKey " ++ showPprUnsafe ss ++ " " ++ show cn
-
-mkAnnKeyPrim :: (Data a) => Located a -> AnnKey
-mkAnnKeyPrim (L l a) = AnnKey (realSrcSpan l) (annGetConstr a)
-
-mkAnnKeyPrimA :: (Data a) => LocatedA a -> AnnKey
-mkAnnKeyPrimA (L l a) = AnnKey (realSrcSpan $ locA l) (annGetConstr a)
-
--- Holds the name of a constructor
-data AnnConName = CN { unConName :: String }
- deriving (Eq, Ord, Data)
-
--- More compact show instance
-instance Show AnnConName where
- show (CN s) = "CN " ++ show s
-
-annGetConstr :: (Data a) => a -> AnnConName
-annGetConstr a = CN (show $ toConstr a)
-
--- |Make an unwrapped @AnnKey@ for the @LHsDecl@ case, a normal one otherwise.
-mkAnnKey :: (Data a) => Located a -> AnnKey
-mkAnnKey ld =
- case cast ld :: Maybe (LHsDecl GhcPs) of
- Just d -> declFun mkAnnKeyPrimA d
- Nothing -> mkAnnKeyPrim ld
-
type Pos = (Int,Int)
-- ---------------------------------------------------------------------
-annNone :: Annotation
-annNone = Ann (SameLine 0) [] [] [] Nothing Nothing
-
-data Annotation = Ann
- {
- -- The first three fields relate to interfacing up into the AST
- annEntryDelta :: !DeltaPos
- -- ^ Offset used to get to the start of the SrcSpan, from whatever the prior
- -- output was, including all annPriorComments (field below).
- , annPriorComments :: ![(Comment, DeltaPos)]
- -- ^ Comments coming after the last non-comment output of the preceding
- -- element but before the SrcSpan being annotated by this Annotation. If
- -- these are changed then annEntryDelta (field above) must also change to
- -- match.
- , annFollowingComments :: ![(Comment, DeltaPos)]
- -- ^ Comments coming after the last output for the element subject to this
- -- Annotation. These will only be added by AST transformations, and care
- -- must be taken not to disturb layout of following elements.
-
- -- The next three fields relate to interacing down into the AST
- , annsDP :: ![(KeywordId, DeltaPos)]
- -- ^ Annotations associated with this element.
- , annSortKey :: !(Maybe [RealSrcSpan])
- -- ^ 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.
- , annCapturedSpan :: !(Maybe AnnKey)
- -- ^ Occasionally we must calculate a SrcSpan for an unlocated list of
- -- elements which we must remember for the Print phase. e.g. the statements
- -- in a HsLet or HsDo. These must be managed as a group because they all
- -- need eo be vertically aligned for the Haskell layout rules, and this
- -- guarantees this property in the presence of AST edits.
-
- } deriving (Eq)
-
--- ---------------------------------------------------------------------
-
-declFun :: (forall a . Data a => LocatedA a -> b) -> LHsDecl GhcPs -> b
-declFun f (L l de) =
- case de of
- TyClD _ d -> f (L l d)
- InstD _ d -> f (L l d)
- DerivD _ d -> f (L l d)
- ValD _ d -> f (L l d)
- SigD _ d -> f (L l d)
- KindSigD _ d -> f (L l d)
- DefD _ d -> f (L l d)
- ForD _ d -> f (L l d)
- WarningD _ d -> f (L l d)
- AnnD _ d -> f (L l d)
- RuleD _ d -> f (L l d)
- SpliceD _ d -> f (L l d)
- DocD _ d -> f (L l d)
- RoleAnnotD _ d -> f (L l d)
-
--- ---------------------------------------------------------------------
-
data Rigidity = NormalLayout | RigidLayout deriving (Eq, Ord, Show)
-
+-- ---------------------------------------------------------------------
-- | A Haskell comment. The @AnnKeywordId@ is present if it has been converted
-- from an @AnnKeywordId@ because the annotation must be interleaved into the
@@ -134,47 +31,34 @@ data Rigidity = NormalLayout | RigidLayout deriving (Eq, Ord, Show)
data Comment = Comment
{
commentContents :: !String -- ^ The contents of the comment including separators
-
- -- AZ:TODO: commentIdentifier is a misnomer, should be commentSrcSpan, it is
- -- the thing we use to decide where in the output stream the comment should
- -- go.
, commentAnchor :: !Anchor
+ , commentPriorTok :: !RealSrcSpan
, commentOrigin :: !(Maybe AnnKeywordId) -- ^ We sometimes turn syntax into comments in order to process them properly.
}
- deriving (Eq)
+ deriving (Data, Eq)
instance Show Comment where
- show (Comment cs ss o) = "(Comment " ++ show cs ++ " " ++ showPprUnsafe ss ++ " " ++ show o ++ ")"
+ show (Comment cs ss r o)
+ = "(Comment " ++ show cs ++ " " ++ showPprUnsafe ss ++ " " ++ show r ++ " " ++ show o ++ ")"
instance Ord Comment where
- compare (Comment _ ss1 _) (Comment _ ss2 _) = compare (anchor ss1) (anchor ss2)
+ -- When we have CPP injected comments with a fake filename, or LINE
+ -- pragma, the file name changes, so we need to compare the
+ -- locations only, with out the filename.
+ compare (Comment _ ss1 _ _) (Comment _ ss2 _ _) = compare (ss2pos $ anchor ss1) (ss2pos $ anchor ss2)
+ where
+ ss2pos ss = (srcSpanStartLine ss,srcSpanStartCol ss)
instance Outputable Comment where
ppr x = text (show x)
--- | The different syntactic elements which are not represented in the
--- AST.
-data KeywordId = G AnnKeywordId -- ^ A normal keyword
- | AnnSemiSep -- ^ A separating comma
- | AnnComment Comment
- | AnnString String -- ^ Used to pass information from
- -- Delta to Print when we have to work
- -- out details from the original
- -- SrcSpan.
- deriving (Eq)
-
-instance Show KeywordId where
- show (G gc) = "(G " ++ show gc ++ ")"
- show AnnSemiSep = "AnnSemiSep"
- show (AnnComment dc) = "(AnnComment " ++ show dc ++ ")"
- show (AnnString s) = "(AnnString " ++ s ++ ")"
-
-- | Marks the start column of a layout block.
newtype LayoutStartCol = LayoutStartCol { getLayoutStartCol :: Int }
deriving (Eq, Num)
instance Show LayoutStartCol where
show (LayoutStartCol sc) = "(LayoutStartCol " ++ show sc ++ ")"
+
-- ---------------------------------------------------------------------
-- Duplicated here so it can be used in show instances
=====================================
utils/check-exact/Utils.hs
=====================================
@@ -20,10 +20,13 @@ module Utils
where
import Control.Monad.State
import Data.Function
+import Data.Maybe (isJust)
import Data.Ord (comparing)
import GHC.Hs.Dump
import Lookup
+import Orphans (Default())
+import qualified Orphans as Orphans
import GHC hiding (EpaComment)
import qualified GHC
@@ -32,12 +35,8 @@ import GHC.Types.Name.Reader
import GHC.Types.SrcLoc
import GHC.Driver.Ppr
import GHC.Data.FastString
+import qualified GHC.Data.Strict as Strict
-import qualified GHC.Types.Name.Occurrence as OccName (OccName(..),pprNameSpaceBrief)
-
-import Control.Arrow
-
-import qualified Data.Map as Map
import Data.Data hiding ( Fixity )
import Data.List (sortBy, elemIndex)
@@ -51,29 +50,15 @@ debugEnabledFlag :: Bool
-- debugEnabledFlag = True
debugEnabledFlag = False
--- |Global switch to enable debug tracing in ghc-exactprint Pretty
-debugPEnabledFlag :: Bool
--- debugPEnabledFlag = True
-debugPEnabledFlag = False
-
-- |Provide a version of trace that comes at the end of the line, so it can
-- easily be commented out when debugging different things.
debug :: c -> String -> c
debug c s = if debugEnabledFlag
then trace s c
else c
-
--- |Provide a version of trace for the Pretty module, which can be enabled
--- separately from 'debug' and 'debugM'
-debugP :: String -> c -> c
-debugP s c = if debugPEnabledFlag
- then trace s c
- else c
-
debugM :: Monad m => String -> m ()
debugM s = when debugEnabledFlag $ traceM s
-
-- ---------------------------------------------------------------------
warn :: c -> String -> c
@@ -83,12 +68,12 @@ warn c _ = c
-- | A good delta has no negative values.
isGoodDelta :: DeltaPos -> Bool
isGoodDelta (SameLine co) = co >= 0
-isGoodDelta (DifferentLine ro co) = ro > 0 && co >= 0
+isGoodDelta (DifferentLine ro _co) = ro > 0
-- Note: DifferentLine invariant is ro is nonzero and positive
-- | Create a delta from the current position to the start of the given
--- @SrcSpan at .
+-- @RealSrcSpan at .
ss2delta :: Pos -> RealSrcSpan -> DeltaPos
ss2delta ref ss = pos2delta ref (ss2pos ss)
@@ -137,25 +122,15 @@ undeltaSpan :: RealSrcSpan -> AnnKeywordId -> DeltaPos -> AddEpAnn
undeltaSpan anchor kw dp = AddEpAnn kw (EpaSpan sp)
where
(l,c) = undelta (ss2pos anchor) dp (LayoutStartCol 0)
- len = length (keywordToString (G kw))
+ len = length (keywordToString kw)
sp = range2rs ((l,c),(l,c+len))
--- | Add together two @DeltaPos@ taking into account newlines
---
--- > DP (0, 1) `addDP` DP (0, 2) == DP (0, 3)
--- > DP (0, 9) `addDP` DP (1, 5) == DP (1, 5)
--- > DP (1, 4) `addDP` DP (1, 3) == DP (2, 3)
-addDP :: DeltaPos -> DeltaPos -> DeltaPos
-addDP dp (DifferentLine c d) = DifferentLine (getDeltaLine dp+c) d
-addDP (DifferentLine a b) (SameLine d) = DifferentLine a (b+d)
-addDP (SameLine b) (SameLine d) = SameLine (b+d)
-
-- ---------------------------------------------------------------------
-adjustDeltaForOffset :: Int -> LayoutStartCol -> DeltaPos -> DeltaPos
-adjustDeltaForOffset _ _colOffset dp@(SameLine _) = dp
-adjustDeltaForOffset d (LayoutStartCol colOffset) (DifferentLine l c)
- = DifferentLine l (c - colOffset - d)
+adjustDeltaForOffset :: LayoutStartCol -> DeltaPos -> DeltaPos
+adjustDeltaForOffset _colOffset dp@(SameLine _) = dp
+adjustDeltaForOffset (LayoutStartCol colOffset) (DifferentLine l c)
+ = DifferentLine l (c - colOffset)
-- ---------------------------------------------------------------------
@@ -213,27 +188,23 @@ isListComp = isDoComprehensionContext
-- ---------------------------------------------------------------------
-isGadt :: Foldable f => f (LConDecl (GhcPass p)) -> Bool
-isGadt = any $ \ case
- L _ ConDeclGADT {} -> True
- _ -> False
-
--- ---------------------------------------------------------------------
-
--- Is a RdrName of type Exact? SYB query, so can be extended to other types too
-isExactName :: (Data name) => name -> Bool
-isExactName = False `mkQ` isExact
+needsWhere :: DataDefnCons (LConDecl (GhcPass p)) -> Bool
+needsWhere (NewTypeCon _) = True
+needsWhere (DataTypeCons _ []) = True
+needsWhere (DataTypeCons _ ((L _ (ConDeclGADT{})):_)) = True
+needsWhere _ = False
-- ---------------------------------------------------------------------
insertCppComments :: ParsedSource -> [LEpaComment] -> ParsedSource
insertCppComments (L l p) cs = L l p'
where
- ncs = EpaComments cs
an' = case GHC.hsmodAnn $ GHC.hsmodExt p of
- (EpAnn a an ocs) -> EpAnn a an (ocs <> ncs)
+ (EpAnn a an ocs) -> EpAnn a an (EpaComments cs')
+ where
+ cs' = sortEpaComments $ priorComments ocs ++ getFollowingComments ocs ++ cs
unused -> unused
- p' = p { GHC.hsmodExt = (GHC.hsmodExt p) { GHC.hsmodAnn = an' } }
+ p' = p { GHC.hsmodExt = (GHC.hsmodExt p) { GHC.hsmodAnn = an' } }
-- ---------------------------------------------------------------------
@@ -245,14 +216,23 @@ ghcCommentText (L _ (GHC.EpaComment (EpaBlockComment s) _)) = s
ghcCommentText (L _ (GHC.EpaComment (EpaEofComment) _)) = ""
tokComment :: LEpaComment -> Comment
-tokComment t@(L lt _) = mkComment (normaliseCommentText $ ghcCommentText t) lt
+tokComment t@(L lt c) = mkComment (normaliseCommentText $ ghcCommentText t) lt (ac_prior_tok c)
+
+mkEpaComments :: [Comment] -> [Comment] -> EpAnnComments
+mkEpaComments priorCs []
+ = EpaComments (map comment2LEpaComment priorCs)
+mkEpaComments priorCs postCs
+ = EpaCommentsBalanced (map comment2LEpaComment priorCs) (map comment2LEpaComment postCs)
+
+comment2LEpaComment :: Comment -> LEpaComment
+comment2LEpaComment (Comment s anc r _mk) = mkLEpaComment s anc r
-mkLEpaComment :: String -> Anchor -> LEpaComment
--- Note: fudging the ac_prior_tok value, hope it does not cause a problem
-mkLEpaComment s anc = (L anc (GHC.EpaComment (EpaLineComment s) (anchor anc)))
+mkLEpaComment :: String -> Anchor -> RealSrcSpan -> LEpaComment
+mkLEpaComment "" anc r = (L anc (GHC.EpaComment (EpaEofComment) r))
+mkLEpaComment s anc r = (L anc (GHC.EpaComment (EpaLineComment s) r))
-mkComment :: String -> Anchor -> Comment
-mkComment c anc = Comment c anc Nothing
+mkComment :: String -> Anchor -> RealSrcSpan -> Comment
+mkComment c anc r = Comment c anc r Nothing
-- Windows comments include \r in them from the lexer.
normaliseCommentText :: String -> String
@@ -260,38 +240,37 @@ normaliseCommentText [] = []
normaliseCommentText ('\r':xs) = normaliseCommentText xs
normaliseCommentText (x:xs) = x:normaliseCommentText xs
+-- |Must compare without span filenames, for CPP injected comments with fake filename
+cmpComments :: Comment -> Comment -> Ordering
+cmpComments (Comment _ l1 _ _) (Comment _ l2 _ _) = compare (ss2pos $ anchor l1) (ss2pos $ anchor l2)
+
+-- |Sort, comparing without span filenames, for CPP injected comments with fake filename
+sortComments :: [Comment] -> [Comment]
+sortComments cs = sortBy cmpComments cs
+
+-- |Sort, comparing without span filenames, for CPP injected comments with fake filename
+sortEpaComments :: [LEpaComment] -> [LEpaComment]
+sortEpaComments cs = sortBy cmp cs
+ where
+ cmp (L l1 _) (L l2 _) = compare (ss2pos $ anchor l1) (ss2pos $ anchor l2)
+
-- | Makes a comment which originates from a specific keyword.
-mkKWComment :: AnnKeywordId -> EpaLocation -> [Comment]
+mkKWComment :: AnnKeywordId -> EpaLocation -> Comment
mkKWComment kw (EpaSpan ss)
- = [Comment (keywordToString $ G kw) (Anchor ss UnchangedAnchor) (Just kw)]
-mkKWComment kw (EpaDelta dp cs)
- = (map tokComment cs) ++ [Comment (keywordToString $ G kw) (Anchor placeholderRealSpan (MovedAnchor dp)) (Just kw)]
+ = Comment (keywordToString kw) (Anchor ss UnchangedAnchor) ss (Just kw)
+mkKWComment kw (EpaDelta dp _)
+ = Comment (keywordToString kw) (Anchor placeholderRealSpan (MovedAnchor dp)) placeholderRealSpan (Just kw)
-comment2dp :: (Comment, DeltaPos) -> (KeywordId, DeltaPos)
-comment2dp = first AnnComment
+-- | Detects a comment which originates from a specific keyword.
+isKWComment :: Comment -> Bool
+isKWComment c = isJust (commentOrigin c)
+
+noKWComments :: [Comment] -> [Comment]
+noKWComments = filter (\c -> not (isKWComment c))
sortAnchorLocated :: [GenLocated Anchor a] -> [GenLocated Anchor a]
sortAnchorLocated = sortBy (compare `on` (anchor . getLoc))
-getAnnotationEP :: (Data a) => Located a -> Anns -> Maybe Annotation
-getAnnotationEP la as =
- Map.lookup (mkAnnKey la) as
-
--- | The "true entry" is the distance from the last concrete element to the
--- start of the current element.
-annTrueEntryDelta :: Annotation -> DeltaPos
-annTrueEntryDelta Ann{annEntryDelta, annPriorComments} =
- foldr addDP (SameLine 0) (map (\(a, b) -> addDP b (dpFromString $ commentContents a)) annPriorComments )
- `addDP` annEntryDelta
-
--- | Return the DP of the first item that generates output, either a comment or the entry DP
-annLeadingCommentEntryDelta :: Annotation -> DeltaPos
-annLeadingCommentEntryDelta Ann{annPriorComments,annEntryDelta} = dp
- where
- dp = case annPriorComments of
- [] -> annEntryDelta
- ((_,ed):_) -> ed
-
-- | Calculates the distance from the start of a string to the end of
-- a string.
dpFromString :: String -> DeltaPos
@@ -326,18 +305,18 @@ name2String = showPprUnsafe
-- ---------------------------------------------------------------------
-occAttributes :: OccName.OccName -> String
-occAttributes o = "(" ++ ns ++ vo ++ tv ++ tc ++ d ++ ds ++ s ++ v ++ ")"
- where
- -- ns = (showSDocUnsafe $ OccName.pprNameSpaceBrief $ occNameSpace o) ++ ", "
- ns = (showSDocUnsafe $ OccName.pprNameSpaceBrief $ occNameSpace o) ++ ", "
- vo = if isVarOcc o then "Var " else ""
- tv = if isTvOcc o then "Tv " else ""
- tc = if isTcOcc o then "Tc " else ""
- d = if isDataOcc o then "Data " else ""
- ds = if isDataSymOcc o then "DataSym " else ""
- s = if isSymOcc o then "Sym " else ""
- v = if isValOcc o then "Val " else ""
+-- occAttributes :: OccName.OccName -> String
+-- occAttributes o = "(" ++ ns ++ vo ++ tv ++ tc ++ d ++ ds ++ s ++ v ++ ")"
+-- where
+-- -- ns = (showSDocUnsafe $ OccName.pprNameSpaceBrief $ occNameSpace o) ++ ", "
+-- ns = (showSDocUnsafe $ OccName.pprNameSpaceBrief $ occNameSpace o) ++ ", "
+-- vo = if isVarOcc o then "Var " else ""
+-- tv = if isTvOcc o then "Tv " else ""
+-- tc = if isTcOcc o then "Tc " else ""
+-- d = if isDataOcc o then "Data " else ""
+-- ds = if isDataSymOcc o then "DataSym " else ""
+-- s = if isSymOcc o then "Sym " else ""
+-- v = if isValOcc o then "Val " else ""
-- ---------------------------------------------------------------------
@@ -345,6 +324,101 @@ locatedAnAnchor :: LocatedAn a t -> RealSrcSpan
locatedAnAnchor (L (SrcSpanAnn EpAnnNotUsed l) _) = realSrcSpan l
locatedAnAnchor (L (SrcSpanAnn (EpAnn a _ _) _) _) = anchor a
+-- ---------------------------------------------------------------------
+
+setAnchorAn :: (Default an) => LocatedAn an a -> Anchor -> EpAnnComments -> LocatedAn an a
+setAnchorAn (L (SrcSpanAnn EpAnnNotUsed l) a) anc cs
+ = (L (SrcSpanAnn (EpAnn anc Orphans.def cs) l) a)
+ -- `debug` ("setAnchorAn: anc=" ++ showAst anc)
+setAnchorAn (L (SrcSpanAnn (EpAnn _ an _) l) a) anc cs
+ = (L (SrcSpanAnn (EpAnn anc an cs) l) a)
+ -- `debug` ("setAnchorAn: anc=" ++ showAst anc)
+
+setAnchorEpa :: (Default an) => EpAnn an -> Anchor -> EpAnnComments -> EpAnn an
+setAnchorEpa EpAnnNotUsed anc cs = EpAnn anc Orphans.def cs
+setAnchorEpa (EpAnn _ an _) anc cs = EpAnn anc an cs
+
+setAnchorEpaL :: EpAnn AnnList -> Anchor -> EpAnnComments -> EpAnn AnnList
+setAnchorEpaL EpAnnNotUsed anc cs = EpAnn anc mempty cs
+setAnchorEpaL (EpAnn _ an _) anc cs = EpAnn anc (an {al_anchor = Nothing}) cs
+
+setAnchorHsModule :: HsModule GhcPs -> Anchor -> EpAnnComments -> HsModule GhcPs
+setAnchorHsModule hsmod anc cs = hsmod { hsmodExt = (hsmodExt hsmod) {hsmodAnn = an'} }
+ where
+ anc' = anc { anchor_op = UnchangedAnchor }
+ an' = setAnchorEpa (hsmodAnn $ hsmodExt hsmod) anc' cs
+
+-- |Version of l2l that preserves the anchor, immportant if it has an
+-- updated AnchorOperation
+moveAnchor :: Monoid b => SrcAnn a -> SrcAnn b
+moveAnchor (SrcSpanAnn EpAnnNotUsed l) = noAnnSrcSpan l
+moveAnchor (SrcSpanAnn (EpAnn anc _ cs) l) = SrcSpanAnn (EpAnn anc mempty cs) l
+
+-- ---------------------------------------------------------------------
+
+trailingAnnLoc :: TrailingAnn -> EpaLocation
+trailingAnnLoc (AddSemiAnn ss) = ss
+trailingAnnLoc (AddCommaAnn ss) = ss
+trailingAnnLoc (AddVbarAnn ss) = ss
+
+setTrailingAnnLoc :: TrailingAnn -> EpaLocation -> TrailingAnn
+setTrailingAnnLoc (AddSemiAnn _) ss = (AddSemiAnn ss)
+setTrailingAnnLoc (AddCommaAnn _) ss = (AddCommaAnn ss)
+setTrailingAnnLoc (AddVbarAnn _) ss = (AddVbarAnn ss)
+
+addEpAnnLoc :: AddEpAnn -> EpaLocation
+addEpAnnLoc (AddEpAnn _ l) = l
+
+-- ---------------------------------------------------------------------
+
+-- TODO: move this to GHC
+anchorToEpaLocation :: Anchor -> EpaLocation
+anchorToEpaLocation (Anchor r UnchangedAnchor) = EpaSpan r
+anchorToEpaLocation (Anchor _ (MovedAnchor dp)) = EpaDelta dp []
+
+-- ---------------------------------------------------------------------
+-- Horrible hack for dealing with some things still having a SrcSpan,
+-- not an Anchor.
+
+{-
+A SrcSpan is defined as
+
+data SrcSpan =
+ RealSrcSpan !RealSrcSpan !(Maybe BufSpan) -- See Note [Why Maybe BufPos]
+ | UnhelpfulSpan !UnhelpfulSpanReason
+
+data BufSpan =
+ BufSpan { bufSpanStart, bufSpanEnd :: {-# UNPACK #-} !BufPos }
+ deriving (Eq, Ord, Show)
+
+newtype BufPos = BufPos { bufPos :: Int }
+
+
+We use the BufPos to encode a delta, using bufSpanStart for the line,
+and bufSpanEnd for the col.
+
+To be absolutely sure, we make the delta versions use -ve values.
+
+-}
+
+hackSrcSpanToAnchor :: SrcSpan -> Anchor
+hackSrcSpanToAnchor (UnhelpfulSpan s) = error $ "hackSrcSpanToAnchor : UnhelpfulSpan:" ++ show s
+hackSrcSpanToAnchor (RealSrcSpan r Strict.Nothing) = Anchor r UnchangedAnchor
+hackSrcSpanToAnchor (RealSrcSpan r (Strict.Just (BufSpan (BufPos s) (BufPos e))))
+ = if s <= 0 && e <= 0
+ then Anchor r (MovedAnchor (deltaPos (-s) (-e)))
+ `debug` ("hackSrcSpanToAnchor: (r,s,e)=" ++ showAst (r,s,e) )
+ else Anchor r UnchangedAnchor
+
+hackAnchorToSrcSpan :: Anchor -> SrcSpan
+hackAnchorToSrcSpan (Anchor r UnchangedAnchor) = RealSrcSpan r Strict.Nothing
+hackAnchorToSrcSpan (Anchor r (MovedAnchor dp))
+ = RealSrcSpan r (Strict.Just (BufSpan (BufPos s) (BufPos e)))
+ `debug` ("hackAnchorToSrcSpan: (r,dp,s,e)=" ++ showAst (r,dp,s,e) )
+ where
+ s = - (getDeltaLine dp)
+ e = - (deltaColumn dp)
+
-- ---------------------------------------------------------------------
showAst :: (Data a) => a -> String
=====================================
utils/check-exact/check-exact.cabal
=====================================
@@ -22,6 +22,7 @@ Executable check-exact
Ghc-Options: -Wall
other-modules: ExactPrint
Lookup
+ Orphans
Parsers
Preprocess
Transform
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d80ad2f40f2092f14402351a6a3cb944039a57df
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d80ad2f40f2092f14402351a6a3cb944039a57df
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20221017/0202c260/attachment-0001.html>
More information about the ghc-commits
mailing list