EPA: Fix explicit specificity and unicode linear arrow annotations

Closes #19839
Closes #19840

8 files changed, 66 insertions, 18 deletions

diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index 44ca8fa042..38c5233ab4 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -2151,7 +2151,7 @@ type :: { LHsType GhcPs }
 
         | btype '->.' ctype            {% hintLinear (getLoc $2) >>
                                           acsA (\cs -> sLL (reLoc $1) (reLoc $>)
-                                            $ HsFunTy (EpAnn (glAR $1) (mau $2) cs) (HsLinearArrow UnicodeSyntax Nothing) $1 $3) }
+                                            $ HsFunTy (EpAnn (glAR $1) (mlu $2) cs) (HsLinearArrow UnicodeSyntax Nothing) $1 $3) }
                                               -- [mu AnnLollyU $2] }
 
 mult :: { Located (IsUnicodeSyntax -> HsArrow GhcPs) }
@@ -2271,8 +2271,8 @@ tv_bndrs :: { [LHsTyVarBndr Specificity GhcPs] }
 
 tv_bndr :: { LHsTyVarBndr Specificity GhcPs }
         : tv_bndr_no_braces             { $1 }
-        | '{' tyvar '}'                 {% acsA (\cs -> sLL $1 $> (UserTyVar (EpAnn (glR $1) [mop $1, mcp $3] cs) InferredSpec $2)) }
-        | '{' tyvar '::' kind '}'       {% acsA (\cs -> sLL $1 $> (KindedTyVar (EpAnn (glR $1) [mop $1,mu AnnDcolon $3 ,mcp $5] cs) InferredSpec $2 $4)) }
+        | '{' tyvar '}'                 {% acsA (\cs -> sLL $1 $> (UserTyVar (EpAnn (glR $1) [moc $1, mcc $3] cs) InferredSpec $2)) }
+        | '{' tyvar '::' kind '}'       {% acsA (\cs -> sLL $1 $> (KindedTyVar (EpAnn (glR $1) [moc $1,mu AnnDcolon $3 ,mcc $5] cs) InferredSpec $2 $4)) }
 
 tv_bndr_no_braces :: { LHsTyVarBndr Specificity GhcPs }
         : tyvar                         {% acsA (\cs -> (sL1 (reLocN $1) (UserTyVar (EpAnn (glNR $1) [] cs) SpecifiedSpec $1))) }
@@ -4175,6 +4175,9 @@ mau :: Located Token -> TrailingAnn
 mau lt@(L l t) = if isUnicode lt then AddRarrowAnnU (EpaSpan $ rs l)
                                  else AddRarrowAnn  (EpaSpan $ rs l)
 
+mlu :: Located Token -> TrailingAnn
+mlu lt@(L l t) = AddLollyAnnU (EpaSpan $ rs l)
+
 -- | If the 'Token' is using its unicode variant return the unicode variant of
 --   the annotation
 toUnicodeAnn :: AnnKeywordId -> Located Token -> AnnKeywordId
diff --git a/compiler/GHC/Parser/Annotation.hs b/compiler/GHC/Parser/Annotation.hs
index e2701709f3..ab88285274 100644
--- a/compiler/GHC/Parser/Annotation.hs
+++ b/compiler/GHC/Parser/Annotation.hs
@@ -622,6 +622,7 @@ data TrailingAnn
   | AddVbarAnn EpaLocation    -- ^ Trailing '|'
   | AddRarrowAnn EpaLocation  -- ^ Trailing '->'
   | AddRarrowAnnU EpaLocation -- ^ Trailing '->', unicode variant
+  | AddLollyAnnU EpaLocation  -- ^ Trailing '⊸'
   deriving (Data,Show,Eq, Ord)
 
 instance Outputable TrailingAnn where
@@ -630,6 +631,7 @@ instance Outputable TrailingAnn where
   ppr (AddVbarAnn ss)    = text "AddVbarAnn"    <+> ppr ss
   ppr (AddRarrowAnn ss)  = text "AddRarrowAnn"  <+> ppr ss
   ppr (AddRarrowAnnU ss) = text "AddRarrowAnnU" <+> ppr ss
+  ppr (AddLollyAnnU ss)  = text "AddLollyAnnU"  <+> ppr ss
 
 -- | Annotation for items appearing in a list. They can have one or
 -- more trailing punctuations items, such as commas or semicolons.
diff --git a/testsuite/tests/printer/Makefile b/testsuite/tests/printer/Makefile
index 94893f6347..b6f05c16d1 100644
--- a/testsuite/tests/printer/Makefile
+++ b/testsuite/tests/printer/Makefile
@@ -587,3 +587,13 @@ Test19821:
 Test19834:
 	$(CHECK_PPR)   $(LIBDIR) Test19834.hs
 	$(CHECK_EXACT) $(LIBDIR) Test19834.hs
+
+.PHONY: Test19839
+Test19839:
+	$(CHECK_PPR)   $(LIBDIR) Test19839.hs
+	$(CHECK_EXACT) $(LIBDIR) Test19839.hs
+
+.PHONY: Test19840
+Test19840:
+	$(CHECK_PPR)   $(LIBDIR) Test19840.hs
+	$(CHECK_EXACT) $(LIBDIR) Test19840.hs
diff --git a/testsuite/tests/printer/Test19839.hs b/testsuite/tests/printer/Test19839.hs
new file mode 100644
index 0000000000..9cd48a0c52
--- /dev/null
+++ b/testsuite/tests/printer/Test19839.hs
@@ -0,0 +1,7 @@
+module Test19839 where
+
+minimal :: a ⊸ a
+minimal x = x
+
+maximal :: a -> a
+maximal x = x
diff --git a/testsuite/tests/printer/Test19840.hs b/testsuite/tests/printer/Test19840.hs
new file mode 100644
index 0000000000..de2e81486d
--- /dev/null
+++ b/testsuite/tests/printer/Test19840.hs
@@ -0,0 +1,12 @@
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Test19840 where
+
+class C a where
+  f         :: forall {z}. z -> a -> a
+  default f :: forall {z}. z -> a -> a
+  f _ x = x
+
+  g         :: forall {z::k} . z -> a -> a
+  g _ x = x
diff --git a/testsuite/tests/printer/all.T b/testsuite/tests/printer/all.T
index 618206ae54..b868427bfd 100644
--- a/testsuite/tests/printer/all.T
+++ b/testsuite/tests/printer/all.T
@@ -133,3 +133,5 @@ 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'])
+test('Test19839', ignore_stderr, makefile_test, ['Test19839'])
+test('Test19840', ignore_stderr, makefile_test, ['Test19840'])
diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs
index 9d670b2245..f63e9e61e1 100644
--- a/utils/check-exact/ExactPrint.hs
+++ b/utils/check-exact/ExactPrint.hs
@@ -26,6 +26,7 @@ import GHC.Types.Basic hiding (EP)
 import GHC.Types.Fixity
 import GHC.Types.ForeignCall
 import GHC.Types.SourceText
+import GHC.Types.Var
 import GHC.Utils.Outputable hiding ( (<>) )
 import GHC.Unit.Module.Warnings
 import GHC.Utils.Misc
@@ -575,7 +576,7 @@ markKwT (AddVbarAnn ss)    = markKwA AnnVbar ss
 markKwT (AddRarrowAnn ss)  = markKwA AnnRarrow ss
 markKwT (AddRarrowAnnU ss) = markKwA AnnRarrowU ss
 -- markKwT (AddLollyAnn ss)   = markKwA AnnLolly ss
--- markKwT (AddLollyAnnU ss)  = markKwA AnnLollyU ss
+markKwT (AddLollyAnnU ss)  = markKwA AnnLollyU ss
 
 markKw :: AddEpAnn -> EPP ()
 markKw (AddEpAnn kw ss) = markKwA kw ss
@@ -2911,25 +2912,35 @@ instance ExactPrint (InjectivityAnn GhcPs) where
 
 -- ---------------------------------------------------------------------
 
--- instance ExactPrint (HsTyVarBndr () GhcPs) where
---   getAnnotationEntry (UserTyVar an _ _)     = fromAnn an
---   getAnnotationEntry (KindedTyVar an _ _ _) = fromAnn an
---   exact = withPpr
+class Typeable flag => ExactPrintTVFlag flag where
+  exactTVDelimiters :: EpAnn [AddEpAnn] -> flag -> Annotated () -> Annotated ()
+
+instance ExactPrintTVFlag () where
+  exactTVDelimiters an _ thing_inside = do
+    markEpAnnAll an id AnnOpenP
+    thing_inside
+    markEpAnnAll an id AnnCloseP
+
+instance ExactPrintTVFlag Specificity where
+  exactTVDelimiters an s thing_inside = do
+    markEpAnnAll an id open
+    thing_inside
+    markEpAnnAll an id close
+    where
+      (open, close) = case s of
+        SpecifiedSpec -> (AnnOpenP, AnnCloseP)
+        InferredSpec  -> (AnnOpenC, AnnCloseC)
 
-instance (Typeable flag) => ExactPrint (HsTyVarBndr flag GhcPs) where
+instance ExactPrintTVFlag flag => ExactPrint (HsTyVarBndr flag GhcPs) where
   getAnnotationEntry (UserTyVar an _ _)     = fromAnn an
   getAnnotationEntry (KindedTyVar an _ _ _) = fromAnn an
 
-  exact (UserTyVar an _ n)     = do
-    markEpAnnAll an id AnnOpenP
-    markAnnotated n
-    markEpAnnAll an id AnnCloseP
-  exact (KindedTyVar an _ n k) = do
-    markEpAnnAll an id AnnOpenP
+  exact (UserTyVar an flag n) =
+    exactTVDelimiters an flag $ markAnnotated n
+  exact (KindedTyVar an flag n k) = exactTVDelimiters an flag $ do
     markAnnotated n
     markEpAnn an AnnDcolon
     markAnnotated k
-    markEpAnnAll an id AnnCloseP
 
 -- ---------------------------------------------------------------------
 
@@ -3354,7 +3365,7 @@ instance ExactPrint Void where
 
 -- ---------------------------------------------------------------------
 
-instance (Typeable flag) => ExactPrint (HsOuterTyVarBndrs flag GhcPs) where
+instance ExactPrintTVFlag flag => ExactPrint (HsOuterTyVarBndrs flag GhcPs) where
   getAnnotationEntry (HsOuterImplicit _) = NoEntryVal
   getAnnotationEntry (HsOuterExplicit an _) = fromAnn an
 
diff --git a/utils/check-exact/Main.hs b/utils/check-exact/Main.hs
index d0971dac65..807ab7290b 100644
--- a/utils/check-exact/Main.hs
+++ b/utils/check-exact/Main.hs
@@ -188,7 +188,8 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/exactprin
  -- "../../testsuite/tests/printer/Test19813.hs" Nothing
  -- "../../testsuite/tests/printer/Test19814.hs" Nothing
  -- "../../testsuite/tests/printer/Test19821.hs" Nothing
- "../../testsuite/tests/printer/Test19834.hs" Nothing
+ -- "../../testsuite/tests/printer/Test19834.hs" Nothing
+ "../../testsuite/tests/printer/Test19840.hs" Nothing
 
 -- cloneT does not need a test, function can be retired