From d3fe8581d40fbc55adab30b87c1f7e437063a7db Mon Sep 17 00:00:00 2001
From: David Knothe <dknothe314@me.com>
Date: Wed, 25 Jan 2023 12:06:13 +0100
Subject: Add EPAs

---
 compiler/GHC/Hs/Pat.hs            |  2 +-
 compiler/GHC/HsToCore/Utils.hs    |  1 +
 compiler/GHC/Parser.y             | 10 ++++++++--
 compiler/GHC/Parser/Annotation.hs |  1 +
 utils/check-exact/ExactPrint.hs   |  9 +++++++++
 utils/check-exact/Lookup.hs       |  1 +
 6 files changed, 21 insertions(+), 3 deletions(-)

diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs
index 3d7bc99860..7b43db2d2f 100644
--- a/compiler/GHC/Hs/Pat.hs
+++ b/compiler/GHC/Hs/Pat.hs
@@ -122,7 +122,7 @@ type instance XTuplePat GhcPs = EpAnn [AddEpAnn]
 type instance XTuplePat GhcRn = NoExtField
 type instance XTuplePat GhcTc = [Type]
 
-type instance XOrPat GhcPs = NoExtField
+type instance XOrPat GhcPs = EpAnn [AddEpAnn]
 type instance XOrPat GhcRn = NoExtField
 type instance XOrPat GhcTc = Type
 
diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs
index 612e00ffa2..bcb185f72c 100644
--- a/compiler/GHC/HsToCore/Utils.hs
+++ b/compiler/GHC/HsToCore/Utils.hs
@@ -81,6 +81,7 @@ import GHC.Types.Tickish
 import GHC.Utils.Misc
 import GHC.Driver.Session
 import GHC.Driver.Ppr
+import GHC.Data.FastString
 import qualified GHC.LanguageExtensions as LangExt
 
 import GHC.Tc.Types.Evidence
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index f994f4fdaf..5824b9ba8e 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -3070,7 +3070,10 @@ texp :: { ECP }
 
         | 'one' 'of' vocurly orpats close
                              {% do {
-                                    let pat = sLLa $1 (reLoc (last $4)) (OrPat NoExtField (NE.fromList $4))
+                                    let srcSpan = comb2 $1 (reLoc (last $4))
+                                    ; cs <- getCommentsFor srcSpan
+                                    ; let pat' = OrPat (EpAnn (spanAsAnchor srcSpan) [mj AnnOne $1, mj AnnOf $2] cs) (NE.fromList $4)
+                                    ; let pat = sL (noAnnSrcSpan srcSpan) pat'
                                     ; orPatsOn <- hintOrPats pat
                                     ; when (orPatsOn && length $4 < 2) $ addError $ mkPlainErrorMsgEnvelope (locA (getLoc pat)) (PsErrOrPatNeedsTwoAlternatives pat)
                                     ; return $ ecpFromPat pat
@@ -3085,7 +3088,10 @@ texp :: { ECP }
 orpats :: { [LPat GhcPs] }
         : tpat %shift      { [$1] }
 
-        | tpat ',' orpats  { $1 : $3 }
+        | tpat ',' orpats  {% do {
+                                  a <- addTrailingCommaA $1 (getLoc $2)
+                                  ; return (a:$3)
+                           } }
 
 -- Always at least one comma or bar.
 -- Though this can parse just commas (without any expressions), it won't
diff --git a/compiler/GHC/Parser/Annotation.hs b/compiler/GHC/Parser/Annotation.hs
index f4e1a06198..c0eda51bbc 100644
--- a/compiler/GHC/Parser/Annotation.hs
+++ b/compiler/GHC/Parser/Annotation.hs
@@ -258,6 +258,7 @@ data AnnKeywordId
     | AnnNewtype
     | AnnName -- ^ where a name loses its location in the AST, this carries it
     | AnnOf
+    | AnnOne
     | AnnOpen    -- ^ '{-\# DEPRECATED' etc. Opening of pragmas where
                  -- the capitalisation of the string can be changed by
                  -- the user. The actual text used is stored in a
diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs
index df7fdfda1e..a3332f5f19 100644
--- a/utils/check-exact/ExactPrint.hs
+++ b/utils/check-exact/ExactPrint.hs
@@ -63,6 +63,7 @@ import Data.Functor.Const
 import qualified Data.Set as Set
 import Data.Typeable
 import Data.List ( partition, sort, sortBy)
+import qualified Data.List.NonEmpty as NE
 import Data.Maybe ( isJust, mapMaybe )
 import Data.Void
 
@@ -4548,6 +4549,7 @@ instance ExactPrint (Pat GhcPs) where
   getAnnotationEntry (NPat an _ _ _)          = fromAnn an
   getAnnotationEntry (NPlusKPat an _ _ _ _ _) = fromAnn an
   getAnnotationEntry (SigPat an _ _)          = fromAnn an
+  getAnnotationEntry (OrPat an _)             = fromAnn an
 
   setAnnotationAnchor a@(WildPat _)              _ _s = a
   setAnnotationAnchor a@(VarPat _ _)             _ _s = a
@@ -4565,6 +4567,7 @@ instance ExactPrint (Pat GhcPs) where
   setAnnotationAnchor (NPat an a b c)          anc cs = (NPat (setAnchorEpa an anc cs) a b c)
   setAnnotationAnchor (NPlusKPat an a b c d e) anc cs = (NPlusKPat (setAnchorEpa an anc cs) a b c d e)
   setAnnotationAnchor (SigPat an a b)          anc cs = (SigPat (setAnchorEpa an anc cs) a b)
+  setAnnotationAnchor (OrPat an a)             anc cs = (OrPat (setAnchorEpa an anc cs) a)
 
   exact (WildPat w) = do
     anchor <- getAnchorU
@@ -4654,6 +4657,12 @@ instance ExactPrint (Pat GhcPs) where
     sig' <- markAnnotated sig
     return (SigPat an0 pat' sig')
 
+  exact (OrPat an pats) = do
+    an0 <- markEpAnnL an lidl AnnOne
+    an1 <- markEpAnnL an0 lidl AnnOf
+    pats' <- markAnnotated (NE.toList pats)
+    return (OrPat an1 (NE.fromList pats'))
+
 -- ---------------------------------------------------------------------
 
 instance ExactPrint (HsPatSigType GhcPs) where
diff --git a/utils/check-exact/Lookup.hs b/utils/check-exact/Lookup.hs
index d3a7df6c2a..1ba37d05dd 100644
--- a/utils/check-exact/Lookup.hs
+++ b/utils/check-exact/Lookup.hs
@@ -76,6 +76,7 @@ keywordToString kw =
       AnnModule       -> "module"
       AnnNewtype      -> "newtype"
       AnnOf           -> "of"
+      AnnOne          -> "one"
       AnnOpenB        -> "(|"
       AnnOpenBU       ->  "⦇"
       AnnOpenC        -> "{"
-- 
cgit v1.2.1