[Git][ghc/ghc][wip/az/ghc-9.8-backports] EPA: track unicode version for unrestrictedFunTyCon
Alan Zimmerman (@alanz)
gitlab at gitlab.haskell.org
Mon Sep 18 18:25:29 UTC 2023
Alan Zimmerman pushed to branch wip/az/ghc-9.8-backports at Glasgow Haskell Compiler / GHC
Commits:
02c57c01 by Alan Zimmerman at 2023-09-18T18:18:59+01:00
EPA: track unicode version for unrestrictedFunTyCon
Closes #23885
Updates haddock submodule
(cherry picked from commit f9d79a6cb78d3ee606249b5393ccaf100577d7dc)
- - - - -
7 changed files:
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- testsuite/tests/printer/Makefile
- + testsuite/tests/printer/Test23885.hs
- testsuite/tests/printer/all.T
- utils/check-exact/ExactPrint.hs
- utils/haddock
Changes:
=====================================
compiler/GHC/Parser.y
=====================================
@@ -773,9 +773,9 @@ identifier :: { LocatedN RdrName }
| qvarop { $1 }
| qconop { $1 }
| '(' '->' ')' {% amsrn (sLL $1 $> $ getRdrName unrestrictedFunTyCon)
- (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) }
+ (NameAnnRArrow (isUnicode $2) (Just $ glAA $1) (glAA $2) (Just $ glAA $3) []) }
| '->' {% amsrn (sLL $1 $> $ getRdrName unrestrictedFunTyCon)
- (NameAnnRArrow (glAA $1) []) }
+ (NameAnnRArrow (isUnicode $1) Nothing (glAA $1) Nothing []) }
-----------------------------------------------------------------------------
-- Backpack stuff
@@ -3665,7 +3665,7 @@ ntgtycon :: { LocatedN RdrName } -- A "general" qualified tycon, excluding unit
| '(#' bars '#)' {% amsrn (sLL $1 $> $ getRdrName (sumTyCon (snd $2 + 1)))
(NameAnnBars NameParensHash (glAA $1) (map srcSpan2e (fst $2)) (glAA $3) []) }
| '(' '->' ')' {% amsrn (sLL $1 $> $ getRdrName unrestrictedFunTyCon)
- (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) }
+ (NameAnnRArrow (isUnicode $2) (Just $ glAA $1) (glAA $2) (Just $ glAA $3) []) }
| '[' ']' {% amsrn (sLL $1 $> $ listTyCon_RDR)
(NameAnnOnly NameSquare (glAA $1) (glAA $2) []) }
@@ -3747,7 +3747,8 @@ otycon :: { LocatedN RdrName }
op :: { LocatedN RdrName } -- used in infix decls
: varop { $1 }
| conop { $1 }
- | '->' { sL1n $1 $ getRdrName unrestrictedFunTyCon }
+ | '->' {% amsrn (sLL $1 $> $ getRdrName unrestrictedFunTyCon)
+ (NameAnnRArrow (isUnicode $1) Nothing (glAA $1) Nothing []) }
varop :: { LocatedN RdrName }
: varsym { $1 }
=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -757,7 +757,10 @@ data NameAnn
}
-- | Used for @->@, as an identifier
| NameAnnRArrow {
+ nann_unicode :: Bool,
+ nann_mopen :: Maybe EpaLocation,
nann_name :: EpaLocation,
+ nann_mclose :: Maybe EpaLocation,
nann_trailing :: [TrailingAnn]
}
-- | Used for an item with a leading @'@. The annotation for
@@ -1288,8 +1291,8 @@ instance Outputable NameAnn where
= text "NameAnnBars" <+> ppr a <+> ppr o <+> ppr n <+> ppr b <+> ppr t
ppr (NameAnnOnly a o c t)
= text "NameAnnOnly" <+> ppr a <+> ppr o <+> ppr c <+> ppr t
- ppr (NameAnnRArrow n t)
- = text "NameAnnRArrow" <+> ppr n <+> ppr t
+ ppr (NameAnnRArrow u o n c t)
+ = text "NameAnnRArrow" <+> ppr u <+> ppr o <+> ppr n <+> ppr c <+> ppr t
ppr (NameAnnQuote q n t)
= text "NameAnnQuote" <+> ppr q <+> ppr n <+> ppr t
ppr (NameAnnTrailing t)
=====================================
testsuite/tests/printer/Makefile
=====================================
@@ -800,3 +800,9 @@ Test23465:
Test23887:
$(CHECK_PPR) $(LIBDIR) Test23887.hs
$(CHECK_EXACT) $(LIBDIR) Test23887.hs
+
+.PHONY: Test23885
+Test23885:
+ # ppr is not currently unicode aware
+ # $(CHECK_PPR) $(LIBDIR) Test23885.hs
+ $(CHECK_EXACT) $(LIBDIR) Test23885.hs
=====================================
testsuite/tests/printer/Test23885.hs
=====================================
@@ -0,0 +1,25 @@
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE UnicodeSyntax #-}
+module Test23885 where
+
+import Control.Monad (Monad(..), join, ap)
+import Data.Monoid (Monoid(..))
+import Data.Semigroup (Semigroup(..))
+
+class Monoidy to comp id m | m to → comp id where
+ munit :: id `to` m
+ mjoin :: (m `comp` m) `to` m
+
+newtype Sum a = Sum a deriving Show
+instance Num a ⇒ Monoidy (→) (,) () (Sum a) where
+ munit _ = Sum 0
+ mjoin (Sum x, Sum y) = Sum $ x + y
+
+data NT f g = NT { runNT :: ∀ α. f α → g α }
=====================================
testsuite/tests/printer/all.T
=====================================
@@ -191,4 +191,5 @@ test('HsDocTy', [ignore_stderr, req_ppr_deps], makefile_test, ['HsDocTy'])
test('Test22765', [ignore_stderr, req_ppr_deps], makefile_test, ['Test22765'])
test('Test22771', [ignore_stderr, req_ppr_deps], makefile_test, ['Test22771'])
test('Test23465', [ignore_stderr, req_ppr_deps], makefile_test, ['Test23465'])
-test('Test23887', [ignore_stderr, req_ppr_deps], makefile_test, ['Test23887'])
\ No newline at end of file
+test('Test23887', [ignore_stderr, req_ppr_deps], makefile_test, ['Test23887'])
+test('Test23885', [ignore_stderr, req_ppr_deps], makefile_test, ['Test23885'])
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -4117,7 +4117,7 @@ instance ExactPrint (LocatedN RdrName) where
NameAnn a o l c t -> do
mn <- markName a o (Just (l,n)) c
case mn of
- (o', (Just (l',_n)), c') -> do -- (o', (Just (l',n')), c')
+ (o', (Just (l',_n)), c') -> do
t' <- markTrailing t
return (NameAnn a o' l' c' t')
_ -> error "ExactPrint (LocatedN RdrName)"
@@ -4139,10 +4139,23 @@ instance ExactPrint (LocatedN RdrName) where
(o',_,c') <- markName a o Nothing c
t' <- markTrailing t
return (NameAnnOnly a o' c' t')
- NameAnnRArrow nl t -> do
- (AddEpAnn _ nl') <- markKwC NoCaptureComments (AddEpAnn AnnRarrow nl)
+ NameAnnRArrow unicode o nl c t -> do
+ o' <- case o of
+ Just o0 -> do
+ (AddEpAnn _ o') <- markKwC NoCaptureComments (AddEpAnn AnnOpenP o0)
+ return (Just o')
+ Nothing -> return Nothing
+ (AddEpAnn _ nl') <-
+ if unicode
+ then markKwC NoCaptureComments (AddEpAnn AnnRarrowU nl)
+ else markKwC NoCaptureComments (AddEpAnn AnnRarrow nl)
+ c' <- case c of
+ Just c0 -> do
+ (AddEpAnn _ c') <- markKwC NoCaptureComments (AddEpAnn AnnCloseP c0)
+ return (Just c')
+ Nothing -> return Nothing
t' <- markTrailing t
- return (NameAnnRArrow nl' t')
+ return (NameAnnRArrow unicode o' nl' c' t')
NameAnnQuote q name t -> do
debugM $ "NameAnnQuote"
(AddEpAnn _ q') <- markKwC NoCaptureComments (AddEpAnn AnnSimpleQuote q)
=====================================
utils/haddock
=====================================
@@ -1 +1 @@
-Subproject commit 250d94539f110f66e24c82ff491423813fc1e8fa
+Subproject commit dfe0247fa70e5e9c88d5647fe00d0ad922cc31a2
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/02c57c01ad2b8a1ebb8cac68e46286eb9e94c009
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/02c57c01ad2b8a1ebb8cac68e46286eb9e94c009
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/20230918/72242a22/attachment-0001.html>
More information about the ghc-commits
mailing list