HsUniToken and HsToken for HsArrow (#19623)

Another step towards a simpler design for exact printing.

Updates the haddock submodule.

3 files changed, 24 insertions, 11 deletions

diff --git a/compiler/Language/Haskell/Syntax/Decls.hs b/compiler/Language/Haskell/Syntax/Decls.hs
index fcbb5856b1..df06635ab3 100644
--- a/compiler/Language/Haskell/Syntax/Decls.hs
+++ b/compiler/Language/Haskell/Syntax/Decls.hs
@@ -1,5 +1,6 @@
 
 {-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
@@ -1215,7 +1216,7 @@ type HsConDeclH98Details pass
 -- GHC.Tc.TyCl—but that is an orthogonal concern.)
 data HsConDeclGADTDetails pass
    = PrefixConGADT [HsScaled pass (LBangType pass)]
-   | RecConGADT (XRec pass [LConDeclField pass])
+   | RecConGADT (XRec pass [LConDeclField pass]) (LHsUniToken "->" "→" pass)
 
 instance Outputable NewOrData where
   ppr NewType  = text "newtype"
diff --git a/compiler/Language/Haskell/Syntax/Extension.hs b/compiler/Language/Haskell/Syntax/Extension.hs
index 278b8aa99e..8d8eadf135 100644
--- a/compiler/Language/Haskell/Syntax/Extension.hs
+++ b/compiler/Language/Haskell/Syntax/Extension.hs
@@ -706,3 +706,16 @@ type LHsToken tok p = XRec p (HsToken tok)
 data HsToken (tok :: Symbol) = HsTok
 
 deriving instance KnownSymbol tok => Data (HsToken tok)
+
+type LHsUniToken tok utok p = XRec p (HsUniToken tok utok)
+
+-- With UnicodeSyntax, there might be multiple ways to write the same token.
+-- For example an arrow could be either "->" or "→". This choice must be
+-- recorded in order to exactprint such tokens,
+-- so instead of HsToken "->" we introduce HsUniToken "->" "→".
+--
+-- See also IsUnicodeSyntax in GHC.Parser.Annotation; we do not use here to
+-- avoid a dependency.
+data HsUniToken (tok :: Symbol) (utok :: Symbol) = HsNormalTok | HsUnicodeTok
+
+deriving instance (KnownSymbol tok, KnownSymbol utok) => Data (HsUniToken tok utok)
diff --git a/compiler/Language/Haskell/Syntax/Type.hs b/compiler/Language/Haskell/Syntax/Type.hs
index 1b311716d0..74f8f98432 100644
--- a/compiler/Language/Haskell/Syntax/Type.hs
+++ b/compiler/Language/Haskell/Syntax/Type.hs
@@ -7,6 +7,7 @@
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
                                       -- in module Language.Haskell.Syntax.Extension
 {-
@@ -22,7 +23,7 @@ module Language.Haskell.Syntax.Type (
         Mult, HsScaled(..),
         hsMult, hsScaledThing,
         HsArrow(..),
-        hsLinear, hsUnrestricted,
+        HsLinearArrowTokens(..),
 
         HsType(..), HsCoreTy, LHsType, HsKind, LHsKind,
         HsForAllTelescope(..), HsTyVarBndr(..), LHsTyVarBndr,
@@ -913,16 +914,20 @@ data HsTyLit
 
 -- | Denotes the type of arrows in the surface language
 data HsArrow pass
-  = HsUnrestrictedArrow IsUnicodeSyntax
+  = HsUnrestrictedArrow !(LHsUniToken "->" "→" pass)
     -- ^ a -> b or a → b
-  | HsLinearArrow IsUnicodeSyntax (Maybe AddEpAnn)
+  | HsLinearArrow !(HsLinearArrowTokens pass)
     -- ^ a %1 -> b or a %1 → b, or a ⊸ b
-  | HsExplicitMult IsUnicodeSyntax (Maybe AddEpAnn) (LHsType pass)
+  | HsExplicitMult !(LHsToken "%" pass) !(LHsType pass) !(LHsUniToken "->" "→" pass)
     -- ^ a %m -> b or a %m → b (very much including `a %Many -> b`!
     -- This is how the programmer wrote it). It is stored as an
     -- `HsType` so as to preserve the syntax as written in the
     -- program.
 
+data HsLinearArrowTokens pass
+  = HsPct1 !(LHsToken "%1" pass) !(LHsUniToken "->" "→" pass)
+  | HsLolly !(LHsToken "⊸" pass)
+
 -- | This is used in the syntax. In constructor declaration. It must keep the
 -- arrow representation.
 data HsScaled pass a = HsScaled (HsArrow pass) a
@@ -933,12 +938,6 @@ hsMult (HsScaled m _) = m
 hsScaledThing :: HsScaled pass a -> a
 hsScaledThing (HsScaled _ t) = t
 
--- | When creating syntax we use the shorthands. It's better for printing, also,
--- the shorthands work trivially at each pass.
-hsUnrestricted, hsLinear :: a -> HsScaled pass a
-hsUnrestricted = HsScaled (HsUnrestrictedArrow NormalSyntax)
-hsLinear = HsScaled (HsLinearArrow NormalSyntax Nothing)
-
 instance Outputable a => Outputable (HsScaled pass a) where
    ppr (HsScaled _cnt t) = -- ppr cnt <> ppr t
                             ppr t