From e3fdd4197cd9def4af40acb3753843e3e9a74d7e Mon Sep 17 00:00:00 2001
From: Alan Zimmerman <alan.zimm@gmail.com>
Date: Wed, 7 Oct 2020 20:38:36 +0100
Subject: Api Annotations: Introduce AnnPercent for HsExplicitMult

For the case

  foo :: a %p -> b

The location of the '%' is captured, separate from the 'p'
---
 compiler/GHC/Parser.y              | 11 ++++++-----
 compiler/GHC/Parser/Annotation.hs  |  3 ++-
 compiler/GHC/Parser/PostProcess.hs |  7 ++++---
 3 files changed, 12 insertions(+), 9 deletions(-)

(limited to 'compiler')

diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index 666b329e84..1d1ae49685 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -2056,17 +2056,18 @@ type :: { LHsType GhcPs }
                                               [mu AnnRarrow $2] }
 
         | btype mult '->' ctype        {% hintLinear (getLoc $2)
-                                       >> ams $1 [mj AnnMult $2,mu AnnRarrow $3] -- See Note [GADT decl discards annotations]
-                                       >> ams (sLL $1 $> $ HsFunTy noExtField ((unLoc $2) (toUnicode $3)) $1 $4)
-                                              [mj AnnMult $2,mu AnnRarrow $3] }
+                                       >> let (arr, ann) = (unLoc $2) (toUnicode $3)
+                                          in (ams $1 [ann,mu AnnRarrow $3] -- See Note [GADT decl discards annotations]
+                                             >> ams (sLL $1 $> $ HsFunTy noExtField arr $1 $4)
+                                                  [ann,mu AnnRarrow $3]) }
 
         | btype '->.' ctype            {% hintLinear (getLoc $2)
                                        >> ams $1 [mu AnnLollyU $2] -- See Note [GADT decl discards annotations]
                                        >> ams (sLL $1 $> $ HsFunTy noExtField (HsLinearArrow UnicodeSyntax) $1 $3)
                                               [mu AnnLollyU $2] }
 
-mult :: { Located (IsUnicodeSyntax -> HsArrow GhcPs) }
-        : PREFIX_PERCENT atype          { sLL $1 $> (\u -> mkMultTy u $2) }
+mult :: { Located (IsUnicodeSyntax -> (HsArrow GhcPs, AddAnn)) }
+        : PREFIX_PERCENT atype          { sLL $1 $> (\u -> mkMultTy u $1 $2) }
 
 btype :: { LHsType GhcPs }
         : infixtype                     {% runPV $1 }
diff --git a/compiler/GHC/Parser/Annotation.hs b/compiler/GHC/Parser/Annotation.hs
index a3cbc92308..9381d591d4 100644
--- a/compiler/GHC/Parser/Annotation.hs
+++ b/compiler/GHC/Parser/Annotation.hs
@@ -301,7 +301,7 @@ data AnnKeywordId
     | AnnMdo
     | AnnMinus -- ^ '-'
     | AnnModule
-    | AnnMult -- ^ '%1'
+    | AnnPercentOne -- ^ '%1' -- for HsLinearArrow
     | AnnNewtype
     | AnnName -- ^ where a name loses its location in the AST, this carries it
     | AnnOf
@@ -318,6 +318,7 @@ data AnnKeywordId
     | AnnDollarDollar    -- ^ prefix '$$'  -- TemplateHaskell
     | AnnPackageName
     | AnnPattern
+    | AnnPercent -- ^ '%' -- for HsExplicitMult
     | AnnProc
     | AnnQualified
     | AnnRarrow -- ^ '->'
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index 4812486d19..a4ac42d382 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -2617,9 +2617,10 @@ mkLHsOpTy x op y =
   let loc = getLoc x `combineSrcSpans` getLoc op `combineSrcSpans` getLoc y
   in L loc (mkHsOpTy x op y)
 
-mkMultTy :: IsUnicodeSyntax -> LHsType GhcPs -> HsArrow GhcPs
-mkMultTy u (L _ (HsTyLit _ (HsNumTy _ 1))) = HsLinearArrow u
-mkMultTy u t = HsExplicitMult u t
+mkMultTy :: IsUnicodeSyntax -> Located Token -> LHsType GhcPs -> (HsArrow GhcPs, AddAnn)
+mkMultTy u tok t@(L _ (HsTyLit _ (HsNumTy _ 1)))
+  = (HsLinearArrow u, AddAnn AnnPercentOne (combineLocs tok t))
+mkMultTy u tok t = (HsExplicitMult u t, AddAnn AnnPercent (getLoc tok))
 
 -----------------------------------------------------------------------------
 -- Token symbols
-- 
cgit v1.2.1