summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/GHC/Parser.y9
-rw-r--r--compiler/GHC/Parser/Annotation.hs2
-rw-r--r--testsuite/tests/printer/Makefile10
-rw-r--r--testsuite/tests/printer/Test19839.hs7
-rw-r--r--testsuite/tests/printer/Test19840.hs12
-rw-r--r--testsuite/tests/printer/all.T2
-rw-r--r--utils/check-exact/ExactPrint.hs39
-rw-r--r--utils/check-exact/Main.hs3
8 files changed, 66 insertions, 18 deletions
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index 025b031f02..27a1c4a9eb 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -2150,7 +2150,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) }
@@ -2270,8 +2270,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))) }
@@ -4174,6 +4174,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 0d7bc0a71f..49104ec964 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.Driver.Ppr
import GHC.Unit.Module.Warnings
@@ -576,7 +577,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
@@ -2914,25 +2915,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
-- ---------------------------------------------------------------------
@@ -3357,7 +3368,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 5840107527..e5ba8dd81b 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
View Lorry Controller Status