[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