[Git][ghc/ghc][wip/or-pats] Preliminary Or-Pattern impl

David (@knothed) gitlab at gitlab.haskell.org
Tue Oct 25 09:12:52 UTC 2022



David pushed to branch wip/or-pats at Glasgow Haskell Compiler / GHC


Commits:
341890a2 by David Knothe at 2022-10-25T11:12:31+02:00
Preliminary Or-Pattern impl

- - - - -


20 changed files:

- compiler/GHC/Hs/Pat.hs
- compiler/GHC/Hs/Syn/Type.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/HsToCore/Match.hs
- compiler/GHC/HsToCore/Pmc/Desugar.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Parser/Types.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Rename/Pat.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/GHC/Tc/TyCl/PatSyn.hs
- compiler/GHC/Tc/Utils/Zonk.hs
- compiler/GHC/Types/Error/Codes.hs
- compiler/GHC/Types/Name/Reader.hs
- compiler/GHC/Utils/Outputable.hs
- compiler/Language/Haskell/Syntax/Extension.hs
- compiler/Language/Haskell/Syntax/Pat.hs
- libraries/unix


Changes:

=====================================
compiler/GHC/Hs/Pat.hs
=====================================
@@ -84,6 +84,7 @@ import GHC.Data.Maybe
 import GHC.Types.Name (Name, dataName)
 import GHC.Driver.Session
 import qualified GHC.LanguageExtensions as LangExt
+import GHC.Exts (toList)
 import Data.Data
 
 
@@ -121,6 +122,10 @@ type instance XTuplePat GhcPs = EpAnn [AddEpAnn]
 type instance XTuplePat GhcRn = NoExtField
 type instance XTuplePat GhcTc = [Type]
 
+type instance XOrPat GhcPs = EpAnn [AddEpAnn]
+type instance XOrPat GhcRn = NoExtField
+type instance XOrPat GhcTc = Type
+
 type instance XSumPat GhcPs = EpAnn EpAnnSumPat
 type instance XSumPat GhcRn = NoExtField
 type instance XSumPat GhcTc = [Type]
@@ -348,6 +353,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)           = brackets (interppDvBar (toList pats))
 pprPat (TuplePat _ pats bx)
     -- Special-case unary boxed tuples so that they are pretty-printed as
     -- `Solo x`, not `(x)`
@@ -570,6 +576,7 @@ isIrrefutableHsPat' is_strict = goL
     go (SumPat {})         = False
                     -- See Note [Unboxed sum patterns aren't irrefutable]
     go (ListPat {})        = False
+    go (OrPat _ pats)      = any (isIrrefutableHsPat' is_strict) pats
 
     go (ConPat
         { pat_con  = con
@@ -648,6 +655,7 @@ patNeedsParens p = go @p
     -- at a different GhcPass (see the case for GhcTc XPat below).
     go :: forall q. IsPass q => Pat (GhcPass q) -> Bool
     go (NPlusKPat {})    = p > opPrec
+    go (OrPat {})    =     p > opPrec
     go (SplicePat {})    = False
     go (ConPat { pat_args = ds })
                          = conPatNeedsParens p ds


=====================================
compiler/GHC/Hs/Syn/Type.hs
=====================================
@@ -51,6 +51,7 @@ hsPatType (LitPat _ lit)                = hsLitType lit
 hsPatType (AsPat _ var _ _)             = idType (unLoc var)
 hsPatType (ViewPat ty _ _)              = ty
 hsPatType (ListPat ty _)                = mkListTy ty
+hsPatType (OrPat ty _)                 = ty
 hsPatType (TuplePat tys _ bx)           = mkTupleTy1 bx tys
                   -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make
 hsPatType (SumPat tys _ _ _ )           = mkSumTy tys


=====================================
compiler/GHC/Hs/Utils.hs
=====================================
@@ -1194,6 +1194,7 @@ collect_pat flag pat bndrs = case pat of
   ParPat _ _ pat _      -> collect_lpat flag pat bndrs
   ListPat _ pats        -> foldr (collect_lpat flag) bndrs pats
   TuplePat _ pats _     -> foldr (collect_lpat flag) bndrs pats
+  OrPat _ _          -> [] -- or pattern's can't bind any variables and we don't want to have "conflicting defintions" errors
   SumPat _ pat _ _      -> collect_lpat flag pat bndrs
   LitPat _ _            -> bndrs
   NPat {}               -> bndrs


=====================================
compiler/GHC/HsToCore/Match.hs
=====================================
@@ -201,7 +201,7 @@ match (v:vs) ty eqns    -- Eqns *can* be empty
         ; let platform = targetPlatform dflags
                 -- Tidy the first pattern, generating
                 -- auxiliary bindings if necessary
-        ; (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns
+        ; (aux_binds, tidy_eqns) <- biconcat <$> mapAndUnzipM (tidyEqnInfo v) eqns
                 -- Group the equations and match each group in turn
         ; let grouped = groupEquations platform tidy_eqns
 
@@ -213,6 +213,7 @@ match (v:vs) ty eqns    -- Eqns *can* be empty
             foldr1 combineMatchResults match_results
         }
   where
+    biconcat (a, b) = (concat a, concat b)
     vars = v :| vs
 
     dropGroup :: Functor f => f (PatGroup,EquationInfo) -> f EquationInfo
@@ -392,7 +393,7 @@ only these which can be assigned a PatternGroup (see patGroup).
 -}
 
 tidyEqnInfo :: Id -> EquationInfo
-            -> DsM (DsWrapper, EquationInfo)
+            -> DsM ([DsWrapper], [EquationInfo])
         -- DsM'd because of internal call to dsLHsBinds
         --      and mkSelectorBinds.
         -- "tidy1" does the interesting stuff, looking at
@@ -405,14 +406,14 @@ tidyEqnInfo _ (EqnInfo { eqn_pats = [] })
   = panic "tidyEqnInfo"
 
 tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats, eqn_orig = orig })
-  = do { (wrap, pat') <- tidy1 v orig pat
-       ; return (wrap, eqn { eqn_pats = pat' : pats }) }
+  = do { (wraps, pats') <- tidy1 v orig pat
+       ; return $ (wraps, map (\p -> eqn { eqn_pats = p : pats }) pats') }
 
 tidy1 :: Id                  -- The Id being scrutinised
       -> Origin              -- Was this a pattern the user wrote?
       -> Pat GhcTc           -- The pattern against which it is to be matched
-      -> DsM (DsWrapper,     -- Extra bindings to do before the match
-              Pat GhcTc)     -- Equivalent pattern
+      -> DsM ([DsWrapper],     -- Extra bindings to do before the match
+              [Pat GhcTc])     -- Equivalent pattern(s)
 
 -------------------------------------------------------
 --      (pat', mr') = tidy1 v pat mr
@@ -422,19 +423,23 @@ tidy1 :: Id                  -- The Id being scrutinised
 
 tidy1 v o (ParPat _ _ pat _)  = tidy1 v o (unLoc pat)
 tidy1 v o (SigPat _ pat _)    = tidy1 v o (unLoc pat)
-tidy1 _ _ (WildPat ty)        = return (idDsWrapper, WildPat ty)
+tidy1 _ _ (WildPat ty)        = return ([idDsWrapper], [WildPat ty])
 tidy1 v o (BangPat _ (L l p)) = tidy_bang_pat v o l p
 
+tidy1 v o (OrPat _ pats) = do { r <- mapM (tidy1 v o . unLoc) (NEL.toList pats); return $ concatUnzip r } where
+  concatUnzip :: [([a], [b])] -> ([a], [b])
+  concatUnzip xs = let (as,bs) = unzip xs in (concat as, concat bs)
+
         -- case v of { x -> mr[] }
         -- = case v of { _ -> let x=v in mr[] }
 tidy1 v _ (VarPat _ (L _ var))
-  = return (wrapBind var v, WildPat (idType var))
+  = return ([wrapBind var v], [WildPat (idType var)])
 
         -- case v of { x at p -> mr[] }
         -- = case v of { p -> let x=v in mr[] }
 tidy1 v o (AsPat _ (L _ var) _ pat)
   = do  { (wrap, pat') <- tidy1 v o (unLoc pat)
-        ; return (wrapBind var v . wrap, pat') }
+        ; return (map (wrapBind var v .) wrap, pat') }
 
 {- now, here we handle lazy patterns:
     tidy1 v ~p bs = (v, v1 = case v of p -> v1 :
@@ -459,17 +464,17 @@ tidy1 v _ (LazyPat _ pat)
 
         ; (_,sel_prs) <- mkSelectorBinds [] pat (Var v)
         ; let sel_binds =  [NonRec b rhs | (b,rhs) <- sel_prs]
-        ; return (mkCoreLets sel_binds, WildPat (idType v)) }
+        ; return ([mkCoreLets sel_binds], [WildPat (idType v)]) }
 
 tidy1 _ _ (ListPat ty pats)
-  = return (idDsWrapper, unLoc list_ConPat)
+  = return ([idDsWrapper], [unLoc list_ConPat])
   where
     list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] [ty])
                         (mkNilPat ty)
                         pats
 
 tidy1 _ _ (TuplePat tys pats boxity)
-  = return (idDsWrapper, unLoc tuple_ConPat)
+  = return ([idDsWrapper], [unLoc tuple_ConPat])
   where
     arity = length pats
     tuple_ConPat = mkPrefixConPat (tupleDataCon boxity arity) pats tys'
@@ -479,7 +484,7 @@ tidy1 _ _ (TuplePat tys pats boxity)
            -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
 
 tidy1 _ _ (SumPat tys pat alt arity)
-  = return (idDsWrapper, unLoc sum_ConPat)
+  = return ([idDsWrapper], [unLoc sum_ConPat])
   where
     sum_ConPat = mkPrefixConPat (sumDataCon alt arity) [pat] (map getRuntimeRep tys ++ tys)
                  -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
@@ -488,7 +493,7 @@ tidy1 _ _ (SumPat tys pat alt arity)
 tidy1 _ o (LitPat _ lit)
   = do { unless (isGenerated o) $
            warnAboutOverflowedLit lit
-       ; return (idDsWrapper, tidyLitPat lit) }
+       ; return ([idDsWrapper], [tidyLitPat lit]) }
 
 -- NPats: we *might* be able to replace these w/ a simpler form
 tidy1 _ o (NPat ty (L _ lit at OverLit { ol_val = v }) mb_neg eq)
@@ -496,22 +501,22 @@ tidy1 _ o (NPat ty (L _ lit at OverLit { ol_val = v }) mb_neg eq)
            let lit' | Just _ <- mb_neg = lit{ ol_val = negateOverLitVal v }
                     | otherwise = lit
            in warnAboutOverflowedOverLit lit'
-       ; return (idDsWrapper, tidyNPat lit mb_neg eq ty) }
+       ; return ([idDsWrapper], [tidyNPat lit mb_neg eq ty]) }
 
 -- NPlusKPat: we may want to warn about the literals
 tidy1 _ o n@(NPlusKPat _ _ (L _ lit1) lit2 _ _)
   = do { unless (isGenerated o) $ do
            warnAboutOverflowedOverLit lit1
            warnAboutOverflowedOverLit lit2
-       ; return (idDsWrapper, n) }
+       ; return ([idDsWrapper], [n]) }
 
 -- Everything else goes through unchanged...
 tidy1 _ _ non_interesting_pat
-  = return (idDsWrapper, non_interesting_pat)
+  = return ([idDsWrapper], [non_interesting_pat])
 
 --------------------
 tidy_bang_pat :: Id -> Origin -> SrcSpanAnnA -> Pat GhcTc
-              -> DsM (DsWrapper, Pat GhcTc)
+              -> DsM ([DsWrapper], [Pat GhcTc])
 
 -- Discard par/sig under a bang
 tidy_bang_pat v o _ (ParPat _ _ (L l p) _) = tidy_bang_pat v o l p
@@ -560,7 +565,7 @@ tidy_bang_pat v o l p@(ConPat { pat_con = L _ (RealDataCon dc)
 --
 -- NB: SigPatIn, ConPatIn should not happen
 
-tidy_bang_pat _ _ l p = return (idDsWrapper, BangPat noExtField (L l p))
+tidy_bang_pat _ _ l p = return ([idDsWrapper], [BangPat noExtField (L l p)])
 
 -------------------
 push_bang_into_newtype_arg :: SrcSpanAnnA


=====================================
compiler/GHC/HsToCore/Pmc/Desugar.hs
=====================================
@@ -26,7 +26,7 @@ import GHC.Hs
 import GHC.Tc.Utils.Zonk (shortCutLit)
 import GHC.Types.Id
 import GHC.Core.ConLike
-import GHC.Types.Name
+import GHC.Types.Name ( NamedThing(getName) )
 import GHC.Builtin.Types
 import GHC.Builtin.Names (rationalTyConName)
 import GHC.Types.SrcLoc
@@ -236,6 +236,8 @@ desugarPat x pat = case pat of
     let tuple_con = tupleDataCon boxity (length vars)
     pure $ vanillaConGrd x tuple_con vars : concat grdss
 
+  OrPat _tys pats -> concatMapM (desugarLPat x) (NE.toList pats)
+
   SumPat _ty p alt arity -> do
     (y, grds) <- desugarLPatV p
     let sum_con = sumDataCon alt arity


=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -11,6 +11,7 @@
 {-# LANGUAGE DataKinds #-}
 
 {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
+{-# LANGUAGE InstanceSigs #-}
 
 --
 --  (c) The University of Glasgow 2002-2006
@@ -165,7 +166,8 @@ import Text.ParserCombinators.ReadP as ReadP
 import Data.Char
 import Data.Data       ( dataTypeOf, fromConstr, dataTypeConstrs )
 import Data.Kind       ( Type )
-import Data.List.NonEmpty (NonEmpty)
+import qualified Data.List.NonEmpty as NE
+import Data.List.NonEmpty (NonEmpty(..))
 
 {- **********************************************************************
 
@@ -1159,11 +1161,11 @@ checkPattern_details :: ParseContext -> PV (LocatedA (PatBuilder GhcPs)) -> P (L
 checkPattern_details extraDetails pp = runPV_details extraDetails (pp >>= checkLPat)
 
 checkLPat :: LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)
-checkLPat e@(L l _) = checkPat l e [] []
+checkLPat e@(L l _) = checkFPat l e [] []
 
-checkPat :: SrcSpanAnnA -> LocatedA (PatBuilder GhcPs) -> [HsConPatTyArg GhcPs] -> [LPat GhcPs]
+checkFPat :: SrcSpanAnnA -> LocatedA (PatBuilder GhcPs) -> [HsConPatTyArg GhcPs] -> [LPat GhcPs]
          -> PV (LPat GhcPs)
-checkPat loc (L l e@(PatBuilderVar (L ln c))) tyargs args
+checkFPat loc (L l e@(PatBuilderVar (L ln c))) tyargs args
   | isRdrDataCon c = return . L loc $ ConPat
       { pat_con_ext = noAnn -- AZ: where should this come from?
       , pat_con = L ln c
@@ -1174,24 +1176,26 @@ checkPat loc (L l e@(PatBuilderVar (L ln c))) tyargs args
   | (not (null args) && patIsRec c) = do
       ctx <- askParseContext
       patFail (locA l) . PsErrInPat e $ PEIP_RecPattern args YesPatIsRecursive ctx
-checkPat loc (L _ (PatBuilderAppType f at t)) tyargs args =
-  checkPat loc f (HsConPatTyArg at t : tyargs) args
-checkPat loc (L _ (PatBuilderApp f e)) [] args = do
+  | otherwise = return $ L l (VarPat noExtField (L ln c))
+checkFPat loc (L _ (PatBuilderAppType f at t)) tyargs args =
+  checkFPat loc f (HsConPatTyArg at t : tyargs) args
+checkFPat loc (L _ (PatBuilderApp f e)) [] args = do
   p <- checkLPat e
-  checkPat loc f [] (p : args)
-checkPat loc (L l e) [] [] = do
+  checkFPat loc f [] (p : args)
+checkFPat loc (L l e) [] [] = do
   p <- checkAPat loc e
   return (L l p)
-checkPat loc e _ _ = do
+checkFPat loc e _ _ = do
   details <- fromParseContext <$> askParseContext
   patFail (locA loc) (PsErrInPat (unLoc e) details)
 
 checkAPat :: SrcSpanAnnA -> PatBuilder GhcPs -> PV (Pat GhcPs)
 checkAPat loc e0 = do
  nPlusKPatterns <- getBit NPlusKPatternsBit
+ e0 <- rebalance e0
  case e0 of
    PatBuilderPat p -> return p
-   PatBuilderVar x -> return (VarPat noExtField x)
+   PatBuilderVar _ -> unLoc <$> checkLPat (L loc e0)
 
    -- Overloaded numeric patterns (e.g. f 0 x = x)
    -- Negation is recorded separately, so that the literal is zero or +ve
@@ -1213,6 +1217,12 @@ checkAPat loc e0 = do
      addError $ mkPlainErrorMsgEnvelope (getLocA op) PsErrAtInPatPos
      return (WildPat noExtField)
 
+   pat@(PatBuilderOpApp _ op _ _) | opIsDvbar (unLoc op) -> do
+     let (pats', anns) = unzip . NE.toList $ flatten pat loc
+     pats <- zipWithM checkAPat anns pats'
+     let lpats = zipWith L anns pats
+     return (OrPat EpAnnNotUsed (NE.fromList lpats))
+
    PatBuilderOpApp l (L cl c) r anns
      | isRdrDataCon c -> do
          l <- checkLPat l
@@ -1227,17 +1237,55 @@ checkAPat loc e0 = do
      p <- checkLPat e
      return (ParPat (EpAnn (spanAsAnchor (locA loc)) NoEpAnns emptyComments) lpar p rpar)
 
-   _           -> do
+   PatBuilderApp _ _ -> do
+    a <- checkFPat loc (L loc e0) [] []
+    return (unLoc a)
+
+   PatBuilderAppType {} -> do
+    a <- checkFPat loc (L loc e0) [] []
+    return (unLoc a)
+
+   _ -> do
      details <- fromParseContext <$> askParseContext
      patFail (locA loc) (PsErrInPat e0 details)
 
+flatten :: PatBuilder GhcPs -> SrcSpanAnnA -> NonEmpty (PatBuilder GhcPs, SrcSpanAnnA) -- flatten the or-hierarchy
+flatten x l = case x of
+  PatBuilderOpApp (L l1 p1) op (L l2 p2) _ | unLoc op == dvbar_RDR -> flatten p1 l1 `NE.append` flatten p2 l2
+  PatBuilderPar _ (L l p) _ -> flatten p l
+  _ -> (x,l) :| []
+
+-- Rebalance the PatBuilder tree to give '||' a lower precedence than '+', to make stuff like (n+3 || n+4) possible
+rebalance :: PatBuilder GhcPs -> PV (PatBuilder GhcPs)
+rebalance e = case e of
+  -- a || b ~> a || b
+  PatBuilderOpApp (L l1 pat1) op (L l2 pat2) ann | unLoc op == dvbar_RDR -> do
+    p1 <- rebalance pat1
+    p2 <- rebalance pat2
+    return $ PatBuilderOpApp (L l1 p1) op (L l2 p2) ann
+
+  -- (a || b) + c ~> a || (b + c)
+  PatBuilderOpApp (L _ (PatBuilderOpApp (L l1 pat1) iop (L l2 pat2) _))
+                  oop
+                  (L l3 pat3)
+                  oann
+                    | unLoc iop == dvbar_RDR && unLoc oop == plus_RDR -> do
+                      cs <- getCommentsFor (locA innpat_l)
+                      new1 <- rebalance pat1
+                      innpat <- rebalance $ PatBuilderOpApp (L l2 pat2) oop (L l3 pat3) (EpAnn (spanAsAnchor (locA innpat_l)) [] cs)
+                      return $ PatBuilderOpApp (L l1 new1) iop (L innpat_l innpat) oann where
+                        innpat_l = SrcSpanAnn EpAnnNotUsed $ combineSrcSpans (locA l2) (locA l3)
+     
+  x -> pure x
+
 placeHolderPunRhs :: DisambECP b => PV (LocatedA b)
 -- The RHS of a punned record field will be filled in by the renamer
 -- It's better not to make it an error, in case we want to print it when
 -- debugging
 placeHolderPunRhs = mkHsVarPV (noLocA pun_RDR)
 
-plus_RDR, pun_RDR :: RdrName
+dvbar_RDR, plus_RDR, pun_RDR :: RdrName
+dvbar_RDR = mkUnqual varName (fsLit "||") -- Hack
 plus_RDR = mkUnqual varName (fsLit "+") -- Hack
 pun_RDR  = mkUnqual varName (fsLit "pun-right-hand-side")
 
@@ -1848,6 +1896,7 @@ instance DisambECP (PatBuilder GhcPs) where
   mkHsIfPV l _ _ _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrIfThenElseInPat
   mkHsDoPV l _ _ _       = addFatalError $ mkPlainErrorMsgEnvelope l PsErrDoNotationInPat
   mkHsParPV l lpar p rpar   = return $ L (noAnnSrcSpan l) (PatBuilderPar lpar p rpar)
+  mkHsVarPV :: LocatedN RdrName -> PV (LocatedA (PatBuilder GhcPs))
   mkHsVarPV v@(getLoc -> l) = return $ L (na2la l) (PatBuilderVar v)
   mkHsLitPV lit@(L l a) = do
     checkUnboxedLitPat lit
@@ -3080,6 +3129,9 @@ mkSumOrTupleExpr l Unboxed (Sum alt arity e barsp barsa) anns = do
 mkSumOrTupleExpr l Boxed a at Sum{} _ =
     addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrUnsupportedBoxedSumExpr a
 
+-- Or
+mkSumOrTupleExpr l _ (OrPat' _) _ = pprPanic "mkSumOrTupleExpr" (ppr l)
+
 mkSumOrTuplePat
   :: SrcSpanAnnA -> Boxity -> SumOrTuple (PatBuilder GhcPs) -> [AddEpAnn]
   -> PV (LocatedA (PatBuilder GhcPs))
@@ -3108,6 +3160,12 @@ mkSumOrTuplePat l Boxed a at Sum{} _ =
     addFatalError $
       mkPlainErrorMsgEnvelope (locA l) $ PsErrUnsupportedBoxedSumPat a
 
+-- Or
+mkSumOrTuplePat l _ (OrPat' ps) anns = do
+  ps' <- traverse checkLPat ps
+  cs <- getCommentsFor (locA l)
+  return $ L l (PatBuilderPat (OrPat (EpAnn (spanAsAnchor $ locA l) anns cs) ps'))
+
 mkLHsOpTy :: PromotionFlag -> LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> LHsType GhcPs
 mkLHsOpTy prom x op y =
   let loc = getLoc x `combineSrcSpansA` (noAnnSrcSpan $ getLocA op) `combineSrcSpansA` getLoc y


=====================================
compiler/GHC/Parser/Types.hs
=====================================
@@ -24,12 +24,15 @@ import GHC.Data.OrdList
 
 import Data.Foldable
 import GHC.Parser.Annotation
-import Language.Haskell.Syntax
+import Language.Haskell.Syntax.Expr ( StmtLR )
+import Language.Haskell.Syntax.Extension ( Anno, LHsToken )
+import qualified Data.List.NonEmpty as NEL
 
 data SumOrTuple b
   = Sum ConTag Arity (LocatedA b) [EpaLocation] [EpaLocation]
   -- ^ Last two are the locations of the '|' before and after the payload
   | Tuple [Either (EpAnn EpaLocation) (LocatedA b)]
+  | OrPat' (NEL.NonEmpty (LocatedA b))
 
 pprSumOrTuple :: Outputable b => Boxity -> SumOrTuple b -> SDoc
 pprSumOrTuple boxity = \case
@@ -39,6 +42,10 @@ pprSumOrTuple boxity = \case
     Tuple xs ->
       parOpen <> (fcat . punctuate comma $ map ppr_tup xs)
               <> parClose
+    OrPat' xs ->
+      parOpen <> (fcat . punctuate (text " || ") . toList $ NEL.map ppr xs)
+              <> parClose
+      
   where
     ppr_tup (Left _)  = empty
     ppr_tup (Right e) = ppr e


=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -2267,6 +2267,7 @@ isStrictPattern (L loc pat) =
     ParPat _ _ p _  -> isStrictPattern p
     ViewPat _ _ p   -> isStrictPattern p
     SigPat _ p _    -> isStrictPattern p
+    OrPat _ p       -> any isStrictPattern p
     BangPat{}       -> True
     ListPat{}       -> True
     TuplePat{}      -> True


=====================================
compiler/GHC/Rename/Pat.hs
=====================================
@@ -605,6 +605,17 @@ rnPatAndThen mk (TuplePat _ pats boxed)
   = do { pats' <- rnLPatsAndThen mk pats
        ; return (TuplePat noExtField pats' boxed) }
 
+rnPatAndThen mk (OrPat _ pats)
+  = do { pats' <- rnLPatsAndThen mk (NE.toList pats)
+       ; mapM_ checkNoVarsBound pats'
+       ; return (OrPat noExtField (NE.fromList pats')) }
+       where
+        checkNoVarsBound :: LPat GhcRn -> CpsRn ()
+        checkNoVarsBound pat = do
+          let bnds = collectPatsBinders CollNoDictBinders [pat]
+          unless (null bnds) $
+            liftCps $ addErrAt (locA $ getLoc pat) TcRnOrPatBindsVariables
+
 rnPatAndThen mk (SumPat _ pat alt arity)
   = do { pat <- rnLPatAndThen mk pat
        ; return (SumPat noExtField pat alt arity)
@@ -1002,4 +1013,4 @@ rnOverLit origLit
           then do { (negate_name, fvs2) <- lookupSyntaxExpr negateName
                   ; return ((lit' { ol_val = negateOverLitVal val }, Just negate_name)
                                   , fvs1 `plusFV` fvs2) }
-          else return ((lit', Nothing), fvs1) }
+          else return ((lit', Nothing), fvs1) }
\ No newline at end of file


=====================================
compiler/GHC/Tc/Errors/Ppr.hs
=====================================
@@ -1000,6 +1000,9 @@ instance Diagnostic TcRnMessage where
     TcRnTypeDataForbids feature
       -> mkSimpleDecorated $
         ppr feature <+> text "are not allowed in type data declarations."
+    TcRnOrPatBindsVariables
+      -> mkSimpleDecorated $
+        text "Or Pattern may not bind variables"
 
   diagnosticReason = \case
     TcRnUnknownMessage m
@@ -1334,6 +1337,8 @@ instance Diagnostic TcRnMessage where
       -> ErrorWithoutFlag
     TcRnTypeDataForbids{}
       -> ErrorWithoutFlag
+    TcRnOrPatBindsVariables
+      -> ErrorWithoutFlag
 
   diagnosticHints = \case
     TcRnUnknownMessage m
@@ -1670,6 +1675,8 @@ instance Diagnostic TcRnMessage where
       -> [suggestExtension LangExt.TypeData]
     TcRnTypeDataForbids{}
       -> noHints
+    TcRnOrPatBindsVariables
+      -> noHints
 
   diagnosticCode = constructorCode
 


=====================================
compiler/GHC/Tc/Errors/Types.hs
=====================================
@@ -2314,6 +2314,14 @@ data TcRnMessage where
   -}
   TcRnTypeDataForbids :: !TypeDataForbids -> TcRnMessage
 
+  {-| TcRnOrPatBindsVariables is an error that happens when an
+     or-pattern binds variables, e.g. (A x || B _).
+
+     Test case:
+       none yet (TODO)
+  -}
+  TcRnOrPatBindsVariables :: TcRnMessage
+
   deriving Generic
 
 -- | Things forbidden in @type data@ declarations.


=====================================
compiler/GHC/Tc/Gen/Pat.hs
=====================================
@@ -5,6 +5,9 @@
 {-# LANGUAGE TypeFamilies #-}
 
 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+{-# HLINT ignore "Use camelCase" #-}
+{-# LANGUAGE ViewPatterns #-}
 
 {-
 (c) The University of Glasgow 2006
@@ -378,6 +381,13 @@ tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of
         { (pat', res) <- tc_lpat pat_ty penv pat thing_inside
         ; return (BangPat x pat', res) }
 
+  -- TODO: reject more programs
+  OrPat _ (NE.toList -> pats) -> do {
+    (pats', res) <- tc_lpats (map (const pat_ty) pats) penv pats thing_inside;
+    pat_ty <- expTypeToType (scaledThing pat_ty);
+    return (OrPat pat_ty (NE.fromList pats'), res)
+  }
+
   LazyPat x pat -> do
         { mult_wrap <- checkManyPattern pat_ty
             -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.


=====================================
compiler/GHC/Tc/TyCl/PatSyn.hs
=====================================
@@ -1105,6 +1105,7 @@ tcPatToExpr name args pat = go pat
     go1 p@(WildPat {})                       = notInvertible p
     go1 p@(AsPat {})                         = notInvertible p
     go1 p@(NPlusKPat {})                     = notInvertible p
+    go1 p@(OrPat {})                         = notInvertible p
 
     notInvertible p = Left (not_invertible_msg p)
 


=====================================
compiler/GHC/Tc/Utils/Zonk.hs
=====================================
@@ -91,6 +91,7 @@ import GHC.Data.Bag
 
 import Control.Monad
 import Data.List  ( partition )
+import qualified Data.List.NonEmpty as NE
 import Control.Arrow ( second )
 
 {- *********************************************************************
@@ -1338,6 +1339,11 @@ zonk_pat env (TuplePat tys pats boxed)
         ; (env', pats') <- zonkPats env pats
         ; return (env', TuplePat tys' pats' boxed) }
 
+zonk_pat env (OrPat ty pats)
+  = do  { ty' <- zonkTcTypeToTypeX env ty
+        ; (env', pats') <- zonkPats env (NE.toList pats)
+        ; return (env', OrPat ty' (NE.fromList pats')) }
+
 zonk_pat env (SumPat tys pat alt arity )
   = do  { tys' <- mapM (zonkTcTypeToTypeX env) tys
         ; (env', pat') <- zonkPat env pat


=====================================
compiler/GHC/Types/Error/Codes.hs
=====================================
@@ -468,6 +468,7 @@ type family GhcDiagnosticCode c = n | n -> c where
   GhcDiagnosticCode "TcRnNoExplicitAssocTypeOrDefaultDeclaration"   = 08585
   GhcDiagnosticCode "TcRnIllegalTypeData"                           = 15013
   GhcDiagnosticCode "TcRnTypeDataForbids"                           = 67297
+  GhcDiagnosticCode "TcRnOrPatBindsVariables"                       = 81303
 
   -- TcRnPragmaWarning
   GhcDiagnosticCode "WarningTxt"                                    = 63394


=====================================
compiler/GHC/Types/Name/Reader.hs
=====================================
@@ -72,7 +72,7 @@ module GHC.Types.Name.Reader (
         importSpecLoc, importSpecModule, isExplicitItem, bestImport,
 
         -- * Utils
-        opIsAt
+        opIsAt, opIsDvbar
   ) where
 
 import GHC.Prelude
@@ -1376,3 +1376,7 @@ pprLoc (UnhelpfulSpan {}) = empty
 -- | Indicate if the given name is the "@" operator
 opIsAt :: RdrName -> Bool
 opIsAt e = e == mkUnqual varName (fsLit "@")
+
+-- | Indicate if the given name is the "||" operator
+opIsDvbar :: RdrName -> Bool
+opIsDvbar e = e == mkUnqual varName (fsLit "||")


=====================================
compiler/GHC/Utils/Outputable.hs
=====================================
@@ -24,7 +24,7 @@ module GHC.Utils.Outputable (
         -- * Pretty printing combinators
         SDoc, runSDoc, PDoc(..),
         docToSDoc,
-        interppSP, interpp'SP, interpp'SP',
+        interppDvBar, interppSP, interpp'SP, interpp'SP',
         pprQuotedList, pprWithCommas, quotedListWithOr, quotedListWithNor,
         pprWithBars,
         empty, isEmpty, nest,
@@ -1344,6 +1344,11 @@ pprWithBars pp xs = fsep (intersperse vbar (map pp xs))
 interppSP  :: Outputable a => [a] -> SDoc
 interppSP  xs = sep (map ppr xs)
 
+-- | Returns the double-bar-separated concatenation of the pretty printed things.
+interppDvBar :: Outputable a => [a] -> SDoc
+interppDvBar xs = sep (punctuate dvbar (map ppr xs)) where
+  dvbar = docToSDoc $ Pretty.text "||"
+
 -- | Returns the comma-separated concatenation of the pretty printed things.
 interpp'SP :: Outputable a => [a] -> SDoc
 interpp'SP xs = interpp'SP' ppr xs


=====================================
compiler/Language/Haskell/Syntax/Extension.hs
=====================================
@@ -594,6 +594,7 @@ type family XBangPat     x
 type family XListPat     x
 type family XTuplePat    x
 type family XSumPat      x
+type family XOrPat      x
 type family XConPat      x
 type family XViewPat     x
 type family XSplicePat   x


=====================================
compiler/Language/Haskell/Syntax/Pat.hs
=====================================
@@ -51,6 +51,7 @@ import Data.Ord
 import Data.Int
 import Data.Function
 import qualified Data.List
+import qualified Data.List.NonEmpty as NEL
 
 type LPat p = XRec p (Pat p)
 
@@ -136,6 +137,9 @@ data Pat p
     --            'GHC.Parser.Annotation.AnnOpen' @'('@ or @'(#'@,
     --            'GHC.Parser.Annotation.AnnClose' @')'@ or  @'#)'@
 
+  | OrPat       (XOrPat p)
+                (NEL.NonEmpty (LPat p))
+
   | SumPat      (XSumPat p)        -- after typechecker, types of the alternative
                 (LPat p)           -- Sum sub-pattern
                 ConTag             -- Alternative (one-based)


=====================================
libraries/unix
=====================================
@@ -1 +1 @@
-Subproject commit 2a6079a2b76adf29d3e3ff213dffe66cabcb76c3
+Subproject commit 23edd4537e9051824a5683b324e6fb8abed5d6b3



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/341890a23631636483628c41d34386a9fb7800e4

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/341890a23631636483628c41d34386a9fb7800e4
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20221025/2de82afc/attachment-0001.html>


More information about the ghc-commits mailing list