[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

6 files changed, 91 insertions, 13 deletions

diff --git a/testsuite/tests/printer/Makefile b/testsuite/tests/printer/Makefile
index 1d0fc14f87..e8bbe7c079 100644
--- a/testsuite/tests/printer/Makefile
+++ b/testsuite/tests/printer/Makefile
@@ -558,6 +558,12 @@ InTreeAnnotations1:
 	$(CHECK_PPR)   $(LIBDIR) InTreeAnnotations1.hs
 	$(CHECK_EXACT) $(LIBDIR) InTreeAnnotations1.hs
 
+.PHONY: PprLinearArrow
+PprLinearArrow:
+	# $(CHECK_PPR)   $(LIBDIR) PprLinearArrow.hs
+	$(CHECK_EXACT) $(LIBDIR) PprLinearArrow.hs
+
+
 .PHONY: Test19784
 Test19784:
 	$(CHECK_PPR)   $(LIBDIR) Test19784.hs
diff --git a/testsuite/tests/printer/PprLinearArrow.hs b/testsuite/tests/printer/PprLinearArrow.hs
new file mode 100644
index 0000000000..1bf995ce6d
--- /dev/null
+++ b/testsuite/tests/printer/PprLinearArrow.hs
@@ -0,0 +1,26 @@
+{-# LANGUAGE LinearTypes, DataKinds, UnicodeSyntax #-}
+
+module PprLinearArrow where
+
+import GHC.Types (Multiplicity(One, Many))
+
+n1 :: a %1 -> b
+n1 = undefined
+
+u1 :: a %1 → b
+u1 = undefined
+
+n2 :: a  %(Many) -> b
+n2 = undefined
+
+u2 :: a  %(Many) → b
+u2 = undefined
+
+m3 :: a ⊸ b
+m3 = undefined
+
+n4 :: a %p  -> b
+n4 = undefined
+
+u4 :: a %p  → b
+u4 = undefined
diff --git a/testsuite/tests/printer/all.T b/testsuite/tests/printer/all.T
index 916ed6bbee..e936cdc64e 100644
--- a/testsuite/tests/printer/all.T
+++ b/testsuite/tests/printer/all.T
@@ -124,12 +124,18 @@ test('PprRecordDotSyntaxA', ignore_stderr, makefile_test, ['PprRecordDotSyntaxA'
 test('CommentsTest', ignore_stderr, makefile_test, ['CommentsTest'])
 test('InTreeAnnotations1', ignore_stderr, makefile_test, ['InTreeAnnotations1'])
 
+
+# Normal ppr does not reproduce unicode linear arrows, commented out
+# in the Makefile for this test. See #18846
+test('PprLinearArrow', ignore_stderr, makefile_test, ['PprLinearArrow'])
+
 test('Test19784', ignore_stderr, makefile_test, ['Test19784'])
 test('Test19798', ignore_stderr, makefile_test, ['Test19798'])
 
 # The exact printing manages the extra semicolons, normal ppr not, so
 # disabled in the Makefile for this test.
 test('Test19813', ignore_stderr, makefile_test, ['Test19813'])
+
 test('Test19814', ignore_stderr, makefile_test, ['Test19814'])
 test('Test19821', ignore_stderr, makefile_test, ['Test19821'])
 test('Test19834', ignore_stderr, makefile_test, ['Test19834'])
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
+