summaryrefslogtreecommitdiff
path: root/utils
diff options
context:
space:
mode:
authorAlan Zimmerman <alan.zimm@gmail.com>2021-05-26 22:20:07 +0100
committerAlan Zimmerman <alan.zimm@gmail.com>2021-05-27 19:25:24 +0100
commit6de8ac892a8001d1a0f00c7b44a731f1f9f5c0b1 (patch)
tree01774790bd6cac7162bb4fc40d3b810e9cc1c367 /utils
parentce1b8f4208530fe6449506ba22e3a05048f81564 (diff)
downloadhaskell-6de8ac892a8001d1a0f00c7b44a731f1f9f5c0b1.tar.gz
[EPA] exact print linear arrows.
Closes #19903 Note: the normal ppr does not reproduce unicode linear arrows, so that part of the normal printing test is ommented out in the Makefile for this test. See #18846
Diffstat (limited to 'utils')
-rw-r--r--utils/check-exact/ExactPrint.hs38
-rw-r--r--utils/check-exact/Main.hs3
-rw-r--r--utils/check-exact/README25
3 files changed, 53 insertions, 13 deletions
diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs
index afb19d8bd9..274b6aa464 100644
--- a/utils/check-exact/ExactPrint.hs
+++ b/utils/check-exact/ExactPrint.hs
@@ -196,8 +196,6 @@ enterAnn :: (ExactPrint a) => Entry -> a -> Annotated ()
enterAnn NoEntryVal a = do
p <- getPosP
debugM $ "enterAnn:NO ANN:(p,a) =" ++ show (p, astId a) ++ " starting"
- -- curAnchor <- getAnchorU
- -- printComments curAnchor
exact a
debugM $ "enterAnn:NO ANN:p =" ++ show (p, astId a) ++ " done"
enterAnn (Entry anchor' cs) a = do
@@ -269,9 +267,9 @@ enterAnn (Entry anchor' cs) a = do
withOffset st (advance edp >> exact a)
when ((getFollowingComments cs) /= []) $ do
- debugM $ "starting trailing comments:" ++ showAst (getFollowingComments cs)
+ -- debugM $ "starting trailing comments:" ++ showAst (getFollowingComments cs)
mapM_ printOneComment (map tokComment $ getFollowingComments cs)
- debugM $ "ending trailing comments"
+ -- debugM $ "ending trailing comments"
-- ---------------------------------------------------------------------
@@ -285,7 +283,8 @@ addComments :: [Comment] -> EPP ()
addComments csNew = do
debugM $ "addComments:" ++ show csNew
cs <- getUnallocatedComments
- let cmp (Comment _ l1 _) (Comment _ l2 _) = compare (anchor l1) (anchor l2)
+ -- Must compare without span filenames, for CPP injected comments with fake filename
+ let cmp (Comment _ l1 _) (Comment _ l2 _) = compare (ss2pos $ anchor l1) (ss2pos $ anchor l2)
-- AZ:TODO: sortedlist?
putUnallocatedComments (sortBy cmp $ csNew ++ cs)
@@ -370,8 +369,6 @@ instance ExactPrint HsModule where
Nothing -> return ()
Just (L ln mn) -> do
markEpAnn' an am_main AnnModule
- -- debugM $ "HsModule name: (ss,ln)=" ++ show (ss2pos ss,ss2pos (realSrcSpan ln))
- -- printStringAtSs ln (moduleNameString mn)
markAnnotated (L ln mn)
-- forM_ mdeprec markLocated
@@ -496,8 +493,19 @@ markLocatedAALS (EpAnn _ a _) f kw (Just str) = go (f a)
-- ---------------------------------------------------------------------
markArrow :: EpAnn TrailingAnn -> HsArrow GhcPs -> EPP ()
-markArrow EpAnnNotUsed _ = pure ()
-markArrow an _mult = markKwT (anns an)
+markArrow an arr = do
+ case arr of
+ HsUnrestrictedArrow _u ->
+ return ()
+ HsLinearArrow _u ma -> do
+ mapM_ markAddEpAnn ma
+ HsExplicitMult _u ma t -> do
+ mapM_ markAddEpAnn ma
+ markAnnotated t
+
+ case an of
+ EpAnnNotUsed -> pure ()
+ _ -> markKwT (anns an)
-- ---------------------------------------------------------------------
@@ -620,7 +628,7 @@ markAnnList' reallyTrail ann action = do
printComments :: RealSrcSpan -> EPP ()
printComments ss = do
cs <- commentAllocation ss
- debugM $ "printComments: (ss,comment locations): " ++ showPprUnsafe (rs2range ss,map commentAnchor cs)
+ -- debugM $ "printComments: (ss,comment locations): " ++ showPprUnsafe (rs2range ss,map commentAnchor cs)
mapM_ printOneComment cs
-- ---------------------------------------------------------------------
@@ -658,7 +666,11 @@ printOneComment c@(Comment _str loc _mo) = do
commentAllocation :: RealSrcSpan -> EPP [Comment]
commentAllocation ss = do
cs <- getUnallocatedComments
- let (earlier,later) = partition (\(Comment _str loc _mo) -> anchor loc <= ss) cs
+ -- Note: The CPP comment injection may change the file name in the
+ -- RealSrcSpan, which affects comparison, as the Ord instance for
+ -- RealSrcSpan compares the file first. So we sort via ss2pos
+ -- TODO: this is inefficient, use Pos all the way through
+ let (earlier,later) = partition (\(Comment _str loc _mo) -> (ss2pos $ anchor loc) <= (ss2pos ss)) cs
putUnallocatedComments later
-- debugM $ "commentAllocation:(ss,earlier,later)" ++ show (rs2range ss,earlier,later)
return earlier
@@ -3413,7 +3425,9 @@ instance ExactPrint (AmbiguousFieldOcc GhcPs) where
instance (ExactPrint a) => ExactPrint (HsScaled GhcPs a) where
getAnnotationEntry = const NoEntryVal
- exact (HsScaled _arr t) = markAnnotated t
+ exact (HsScaled arr t) = do
+ markAnnotated t
+ markArrow EpAnnNotUsed arr
-- ---------------------------------------------------------------------
diff --git a/utils/check-exact/Main.hs b/utils/check-exact/Main.hs
index 4789f5188b..63eabff460 100644
--- a/utils/check-exact/Main.hs
+++ b/utils/check-exact/Main.hs
@@ -193,7 +193,8 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/exactprin
-- "../../testsuite/tests/printer/Test19821.hs" Nothing
-- "../../testsuite/tests/printer/Test19834.hs" Nothing
-- "../../testsuite/tests/printer/Test19840.hs" Nothing
- "../../testsuite/tests/printer/Test19850.hs" Nothing
+ -- "../../testsuite/tests/printer/Test19850.hs" Nothing
+ "../../testsuite/tests/printer/PprLinearArrow.hs" Nothing
-- cloneT does not need a test, function can be retired
diff --git a/utils/check-exact/README b/utils/check-exact/README
index b27f0fbd55..07a7f26ed9 100644
--- a/utils/check-exact/README
+++ b/utils/check-exact/README
@@ -22,3 +22,28 @@ The utility generates the following files for ToBeTested.hs
- ToBeTested.ppr.hs : the ppr result
- ToBeTested.hs.ast : the AST of the original source
- ToBeTested.hs.ast.new : the AST of the re-parsed ppr source
+
+For local development/testing
+-----------------------------
+
+From this directory, start a ghci session by
+
+../../_build/stage1/bin/ghc --interactive
+
+Update Main.hs. the _tt function to firstly have the full local path
+of the _build/stage1/lib directory, and secondly to be cofigured to
+run the test of interest, by adding a new line to the many already
+there or commenting in the one (only) to be tested.
+
+ghci> :l Main.hs
+ghci> _tt
+*** Exception: ExitSuccess
+
+Note: GHC may complain about missing modules, etc, this is not a
+problem, the test passes if it gives ExitSuccess at the end.
+
+Logging can be turned on by flipping the comments in Utils.hs
+
+debugEnabledFlag = True
+-- debugEnabledFlag = False
+