Implement empty one of

7 files changed, 26 insertions, 39 deletions

diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs
index 60f44001bb..8b676d42f5 100644
--- a/compiler/GHC/Hs/Pat.hs
+++ b/compiler/GHC/Hs/Pat.hs
@@ -352,7 +352,7 @@ pprPat (SplicePat ext splice)   =
       GhcTc -> dataConCantHappen ext
 pprPat (SigPat _ pat ty)        = ppr pat <+> dcolon <+> ppr ty
 pprPat (ListPat _ pats)         = brackets (interpp'SP pats)
-pprPat (OrPat _ pats)           = text "one of { " <+> pprWithSemis ppr pats <+> text " }"
+pprPat (OrPat _ pats)           = text "one of {" <+> pprWithSemis ppr pats <+> text "}"
 pprPat (TuplePat _ pats bx)
     -- Special-case unary boxed tuples so that they are pretty-printed as
     -- `MkSolo x`, not `(x)`
diff --git a/compiler/GHC/HsToCore/Pmc/Desugar.hs b/compiler/GHC/HsToCore/Pmc/Desugar.hs
index 3b30660b90..c95ef577cc 100644
--- a/compiler/GHC/HsToCore/Pmc/Desugar.hs
+++ b/compiler/GHC/HsToCore/Pmc/Desugar.hs
@@ -26,6 +26,8 @@ import GHC.Hs
 import GHC.Tc.Utils.Zonk (shortCutLit)
 import GHC.Types.Id
 import GHC.Core.ConLike
+import GHC.Core.Make (mkWildValBinder)
+import GHC.Core.Utils (exprType)
 import GHC.Types.Name
 import GHC.Builtin.Types
 import GHC.Builtin.Names (rationalTyConName)
@@ -231,7 +233,9 @@ desugarPat x pat = case pat of
     let tuple_con = tupleDataCon boxity (length vars)
     pure $ vanillaConGrd x tuple_con vars `consGrdDag` sequenceGrdDags grdss
 
-  OrPat _tys [] -> error "lol" -- pure failGrd
+  OrPat _tys [] -> do
+    let true = mkWildValBinder OneTy (exprType (Var trueDataConId))
+    return $ vanillaConGrd true falseDataCon [] `consGrdDag` mkPmLetVar true trueDataConId
   OrPat _tys (pat:pats) -> alternativesGrdDags <$> traverse (desugarLPat x) (pat:|pats)
 
   SumPat _ty p alt arity -> do
@@ -243,8 +247,6 @@ desugarPat x pat = case pat of
   SplicePat {} -> panic "Check.desugarPat: SplicePat"
 
 
--- failGrd = mkPmLetVar trueId trueDataConId `consGrdDag` vanillaConGrd trueId falseDataCon []
-
 -- | 'desugarPat', but also select and return a new match var.
 desugarPatV :: Pat GhcTc -> DsM (Id, GrdDag)
 desugarPatV pat = do
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index 21ab32e384..dbce38fcb7 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -507,22 +507,6 @@ Ambiguity:
     empty activation and inlining '[0] Something'.
 -}
 
-{- Note [%shift: orpats -> pat]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Context:
-    orpats -> pat .
-    orpats -> pat . ',' orpats
-
-Example:
-
-    (one of a, b)
-
-Ambiguity:
-    We use ',' as a delimiter between options inside an or-pattern.
-    However, the ',' could also mean a tuple pattern.
-    If the user wants a tuple pattern, they have to put the or-pattern in parentheses.
--}
-
 {- Note [Parser API Annotations]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 A lot of the productions are now cluttered with calls to
@@ -3075,20 +3059,21 @@ texp :: { ECP }
 
         | 'one' 'of' vocurly orpats close
                              {% do {
-                                    let srcSpan = comb2 $1 $ reLoc (fromJust $ lastMaybe $4)
+                                    --let srcSpan = comb2 $1 $ maybe $2 reLoc (lastMaybe $4)
+                                    let srcSpan = maybe (comb2 $1 $2) (\a -> comb2 $1 (reLoc a)) (lastMaybe $4)
+                                    --let srcSpan = comb2 $1 $ reLoc (fromJust (lastMaybe $4))
                                     ; cs <- getCommentsFor srcSpan
                                     ; let pat' = OrPat (EpAnn (spanAsAnchor srcSpan) [mj AnnOne $1, mj AnnOf $2] cs) $4
                                     ; let pat = sL (noAnnSrcSpan srcSpan) pat'
                                     ; orPatsOn <- hintOrPats pat
-                                    ; when (orPatsOn && null $4) $ addError $ mkPlainErrorMsgEnvelope (locA (getLoc pat)) (PsErrEmptyOrPatWithoutCurlys pat)
                                     ; return $ ecpFromPat pat
                              }  }
 
         | 'one' 'of' '{' orpats '}'
                              {% do {
-                                    let srcSpan = comb2 $1 $5 -- todo: loc ?
+                                    let srcSpan = comb2 $1 $5
                                     ; cs <- getCommentsFor srcSpan
-                                    ; let pat' = OrPat (EpAnn (spanAsAnchor srcSpan) [mj AnnOne $1, mj AnnOf $2] cs) $4
+                                    ; let pat' = OrPat (EpAnn (spanAsAnchor srcSpan) [mj AnnOne $1, mj AnnOf $2, mj AnnOpenC $3, mj AnnCloseC $5] cs) $4
                                     ; let pat = sL (noAnnSrcSpan srcSpan) pat'
                                     ; _ <- hintOrPats pat
                                     ; return $ ecpFromPat pat
@@ -3101,10 +3086,18 @@ texp :: { ECP }
                              mkHsViewPatPV (comb2 (reLoc $1) (reLoc $>)) $1 $3 [mu AnnRarrow $2] }
 
 orpats :: { [LPat GhcPs] }
-        : %shift           { [] }
+        :                      { [] }
+        | tpat                 { [$1] }
+
+        | tpat ';' orpatss  {% do {
+                                  a <- addTrailingSemiA $1 (getLoc $2)
+                                  ; return (a:$3)
+                           } }
 
-        | tpat ';' orpats  {% do {
-                                  a <- addTrailingCommaA $1 (getLoc $2)
+orpatss :: { [LPat GhcPs] }
+        : tpat                  { [$1] }
+        | tpat ';' orpatss  {% do {
+                                  a <- addTrailingSemiA $1 (getLoc $2)
                                   ; return (a:$3)
                            } }
 
diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs
index 4015540cc5..28f2376beb 100644
--- a/compiler/GHC/Parser/Errors/Ppr.hs
+++ b/compiler/GHC/Parser/Errors/Ppr.hs
@@ -523,9 +523,6 @@ instance Diagnostic PsMessage where
                 , text "'" <> text [looks_like_char] <> text "' (" <> text looks_like_char_name <> text ")" <> comma
                 , text "but it is not" ]
 
-    PsErrEmptyOrPatWithoutCurlys _
-      -> mkSimpleDecorated $ vcat [text "An empty or-pattern needs curly braces: one of"]
-
     PsErrIllegalOrPat pat
       -> mkSimpleDecorated $ vcat [text "Illegal or-pattern:" <+> ppr (unLoc pat)]
 
@@ -648,7 +645,6 @@ instance Diagnostic PsMessage where
     PsErrInvalidCApiImport {}                     -> ErrorWithoutFlag
     PsErrMultipleConForNewtype {}                 -> ErrorWithoutFlag
     PsErrUnicodeCharLooksLike{}                   -> ErrorWithoutFlag
-    PsErrEmptyOrPatWithoutCurlys{}                -> ErrorWithoutFlag
     PsErrIllegalOrPat{}                           -> ErrorWithoutFlag
 
   diagnosticHints = \case
@@ -822,7 +818,6 @@ instance Diagnostic PsMessage where
     PsErrMultipleConForNewtype {}                 -> noHints
     PsErrUnicodeCharLooksLike{}                   -> noHints
     PsErrIllegalOrPat{}                           -> [suggestExtension LangExt.OrPatterns]
-    PsErrEmptyOrPatWithoutCurlys{}              -> noHints
 
   diagnosticCode = constructorCode
 
diff --git a/compiler/GHC/Parser/Errors/Types.hs b/compiler/GHC/Parser/Errors/Types.hs
index 221f13fd93..060d65ef68 100644
--- a/compiler/GHC/Parser/Errors/Types.hs
+++ b/compiler/GHC/Parser/Errors/Types.hs
@@ -474,9 +474,6 @@ data PsMessage
     -- | Or pattern used without -XOrPatterns
     | PsErrIllegalOrPat (LPat GhcPs)
 
-    -- | Writing (one of) instead of (one of {}) is illegal
-    | PsErrEmptyOrPatWithoutCurlys (LPat GhcPs)
-
    deriving Generic
 
 -- | Extra details about a parse error, which helps
diff --git a/compiler/GHC/Types/Error/Codes.hs b/compiler/GHC/Types/Error/Codes.hs
index af44632d01..986284baf7 100644
--- a/compiler/GHC/Types/Error/Codes.hs
+++ b/compiler/GHC/Types/Error/Codes.hs
@@ -270,7 +270,6 @@ type family GhcDiagnosticCode c = n | n -> c where
   GhcDiagnosticCode "PsErrMultipleConForNewtype"                    = 05380
   GhcDiagnosticCode "PsErrUnicodeCharLooksLike"                     = 31623
   GhcDiagnosticCode "PsErrIllegalOrPat"                             = 29847
-  GhcDiagnosticCode "PsErrEmptyOrPatWithoutCurlys"                = 96152
 
   -- Driver diagnostic codes
   GhcDiagnosticCode "DriverMissingHomeModules"                      = 32850
diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs
index 709e18ddd5..f7fe7d87b5 100644
--- a/utils/check-exact/ExactPrint.hs
+++ b/utils/check-exact/ExactPrint.hs
@@ -63,7 +63,6 @@ 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
 
@@ -4672,8 +4671,10 @@ instance ExactPrint (Pat GhcPs) where
   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'))
+    an2 <- markEpAnnL an1 lidl AnnOpenC
+    pats' <- markAnnotated pats
+    an3 <- markEpAnnL an2 lidl AnnCloseC
+    return (OrPat an3 pats')
 
 -- ---------------------------------------------------------------------