HsToken for @-patterns and TypeApplications (#19623)

One more step towards the new design of EPA.

3 files changed, 23 insertions, 3 deletions

diff --git a/compiler/Language/Haskell/Syntax/Expr.hs b/compiler/Language/Haskell/Syntax/Expr.hs
index 051edda97f..8d2a365a8c 100644
--- a/compiler/Language/Haskell/Syntax/Expr.hs
+++ b/compiler/Language/Haskell/Syntax/Expr.hs
@@ -371,6 +371,7 @@ data HsExpr p
 
   | HsAppType (XAppTypeE p) -- After typechecking: the type argument
               (LHsExpr p)
+             !(LHsToken "@" p)
               (LHsWcType (NoGhcTc p))  -- ^ Visible type application
        --
        -- Explicit type argument; e.g  f @Int x y
diff --git a/compiler/Language/Haskell/Syntax/Extension.hs b/compiler/Language/Haskell/Syntax/Extension.hs
index 5cffd96690..47b693a9bd 100644
--- a/compiler/Language/Haskell/Syntax/Extension.hs
+++ b/compiler/Language/Haskell/Syntax/Extension.hs
@@ -23,7 +23,7 @@ module Language.Haskell.Syntax.Extension where
 
 import GHC.Prelude
 
-import GHC.TypeLits (Symbol, KnownSymbol)
+import GHC.TypeLits (Symbol, KnownSymbol, symbolVal)
 import Data.Data hiding ( Fixity )
 import Data.Kind (Type)
 import GHC.Utils.Outputable
@@ -730,3 +730,10 @@ type LHsUniToken tok utok p = XRec p (HsUniToken tok utok)
 data HsUniToken (tok :: Symbol) (utok :: Symbol) = HsNormalTok | HsUnicodeTok
 
 deriving instance (KnownSymbol tok, KnownSymbol utok) => Data (HsUniToken tok utok)
+
+instance KnownSymbol tok => Outputable (HsToken tok) where
+   ppr _ = text (symbolVal (Proxy :: Proxy tok))
+
+instance (KnownSymbol tok, KnownSymbol utok) => Outputable (HsUniToken tok utok) where
+   ppr HsNormalTok  = text (symbolVal (Proxy :: Proxy tok))
+   ppr HsUnicodeTok = text (symbolVal (Proxy :: Proxy utok))
diff --git a/compiler/Language/Haskell/Syntax/Pat.hs b/compiler/Language/Haskell/Syntax/Pat.hs
index 0e9f11dc1b..12ef7ae98a 100644
--- a/compiler/Language/Haskell/Syntax/Pat.hs
+++ b/compiler/Language/Haskell/Syntax/Pat.hs
@@ -23,6 +23,7 @@ module Language.Haskell.Syntax.Pat (
         ConLikeP,
 
         HsConPatDetails, hsConPatArgs,
+        HsConPatTyArg(..),
         HsRecFields(..), HsFieldBind(..), LHsFieldBind,
         HsRecField, LHsRecField,
         HsRecUpdField, LHsRecUpdField,
@@ -69,7 +70,9 @@ data Pat p
     -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation
 
   | AsPat       (XAsPat p)
-                (LIdP p) (LPat p)    -- ^ As pattern
+                (LIdP p)
+               !(LHsToken "@" p)
+                (LPat p)    -- ^ As pattern
     -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnAt'
 
     -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation
@@ -217,9 +220,15 @@ type family ConLikeP x
 
 -- ---------------------------------------------------------------------
 
+-- | Type argument in a data constructor pattern,
+--   e.g. the @\@a@ in @f (Just \@a x) = ...@.
+data HsConPatTyArg p =
+  HsConPatTyArg
+    !(LHsToken "@" p)
+     (HsPatSigType p)
 
 -- | Haskell Constructor Pattern Details
-type HsConPatDetails p = HsConDetails (HsPatSigType (NoGhcTc p)) (LPat p) (HsRecFields p (LPat p))
+type HsConPatDetails p = HsConDetails (HsConPatTyArg (NoGhcTc p)) (LPat p) (HsRecFields p (LPat p))
 
 hsConPatArgs :: forall p . (UnXRec p) => HsConPatDetails p -> [LPat p]
 hsConPatArgs (PrefixCon _ ps) = ps
@@ -353,6 +362,9 @@ hsRecFieldSel = foExt . unXRec @p . hfbLHS
 ************************************************************************
 -}
 
+instance Outputable (HsPatSigType p) => Outputable (HsConPatTyArg p) where
+  ppr (HsConPatTyArg _ ty) = char '@' <> ppr ty
+
 instance (Outputable arg, Outputable (XRec p (HsRecField p arg)))
       => Outputable (HsRecFields p arg) where
   ppr (HsRecFields { rec_flds = flds, rec_dotdot = Nothing })