[Git][ghc/ghc][wip/or-pats] Preliminary Or-Pattern impl
David (@knothed)
gitlab at gitlab.haskell.org
Tue Oct 25 08:53:11 UTC 2022
David pushed to branch wip/or-pats at Glasgow Haskell Compiler / GHC
Commits:
e0c1c2e3 by David Knothe at 2022-10-25T10:52:56+02:00
Preliminary Or-Pattern impl
- - - - -
19 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
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
=====================================
@@ -150,6 +150,7 @@ import Data.Either
import Data.Foldable ( toList )
import Data.Function
import Data.List ( partition, deleteBy )
+import Debug.Trace
{-
************************************************************************
@@ -1194,6 +1195,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)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e0c1c2e3fef46a65da4cba9a2a9ea2690aebdf9a
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e0c1c2e3fef46a65da4cba9a2a9ea2690aebdf9a
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/63b8a606/attachment-0001.html>
More information about the ghc-commits
mailing list