[Git][ghc/ghc][wip/or-pats] Clean-up
David (@knothed)
gitlab at gitlab.haskell.org
Mon Dec 12 14:36:11 UTC 2022
David pushed to branch wip/or-pats at Glasgow Haskell Compiler / GHC
Commits:
af128825 by David Knothe at 2022-12-12T15:36:02+01:00
Clean-up
- - - - -
26 changed files:
- compiler/GHC/Hs/Pat.hs
- compiler/GHC/HsToCore/Match.hs
- compiler/GHC/HsToCore/Pmc/Desugar.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Errors/Types.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Types/Name/Reader.hs
- compiler/Language/Haskell/Syntax/Extension.hs
- compiler/Language/Haskell/Syntax/Pat.hs
- testsuite/tests/deSugar/should_run/Or5.hs → testsuite/tests/deSugar/should_run/Or4.hs
- testsuite/tests/deSugar/should_run/Or5.stderr → testsuite/tests/deSugar/should_run/Or4.stderr
- testsuite/tests/deSugar/should_run/Or5.stdout → testsuite/tests/deSugar/should_run/Or4.stdout
- testsuite/tests/deSugar/should_run/all.T
- testsuite/tests/parser/should_fail/Or1.hs
- testsuite/tests/parser/should_fail/Or1.stderr
- testsuite/tests/parser/should_fail/Or2.hs
- testsuite/tests/parser/should_fail/Or2.stderr
- − testsuite/tests/parser/should_fail/Or3.hs
- − testsuite/tests/parser/should_fail/Or3.stderr
- testsuite/tests/parser/should_fail/all.T
- − testsuite/tests/rename/should_fail/Or4.stderr
- testsuite/tests/rename/should_fail/all.T
- testsuite/tests/rename/should_fail/Or4.hs → testsuite/tests/typecheck/should_fail/Or3.hs
- + testsuite/tests/typecheck/should_fail/Or3.stderr
- testsuite/tests/typecheck/should_fail/all.T
Changes:
=====================================
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 = EpAnn [AddEpAnn]
+type instance XOrPat GhcPs = NoExtField
type instance XOrPat GhcRn = NoExtField
type instance XOrPat GhcTc = Type
=====================================
compiler/GHC/HsToCore/Match.hs
=====================================
@@ -425,13 +425,13 @@ tidyEqnInfo _ (EqnInfo { eqn_pats = [] })
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 }) }
+ ; return (wrap, eqn { eqn_pats = pat' : 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(s)
+ Pat GhcTc) -- Equivalent pattern
-------------------------------------------------------
-- (pat', mr') = tidy1 v pat mr
@@ -447,7 +447,7 @@ tidy1 v o (BangPat _ (L l p)) = tidy_bang_pat v o l p
tidy1 v o (OrPat x pats) = do
(wraps, pats) <- mapAndUnzipM (tidy1 v o . unLoc) (NEL.toList pats)
let wrap = foldr (.) id wraps in
- return $ (wrap, OrPat x (NEL.fromList $ map (L noSrcSpanA) pats))
+ return (wrap, OrPat x (NEL.fromList $ map (L noSrcSpanA) pats))
-- case v of { x -> mr[] }
-- = case v of { _ -> let x=v in mr[] }
=====================================
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 ( NamedThing(getName) )
+import GHC.Types.Name
import GHC.Builtin.Types
import GHC.Builtin.Names (rationalTyConName)
import GHC.Types.SrcLoc
=====================================
compiler/GHC/Parser.y
=====================================
@@ -3063,7 +3063,7 @@ texp :: { ECP }
| 'one' 'of' vocurly orpats close
{% do {
- let pat = sLLa $1 (reLoc (last $4)) (mkorpat $4)
+ let pat = sLLa $1 (reLoc (last $4)) (OrPat NoExtField (NE.fromList $4))
; orPatsOn <- hintOrPats pat
; when (orPatsOn && length $4 < 2) $ addError $ mkPlainErrorMsgEnvelope (locA (getLoc pat)) (PsErrOrPatNeedsTwoAlternatives pat)
; return $ ecpFromPat pat
@@ -4273,10 +4273,6 @@ msemim l = if isZeroWidthSpan (gl l) then Nothing else Just (EpaSpan $ rs $ gl l
mu :: AnnKeywordId -> Located Token -> AddEpAnn
mu a lt@(L l t) = AddEpAnn (toUnicodeAnn a lt) (EpaSpan $ rs l)
--- Merge the source spans of the tokens into the first one.
-merge_ts :: Located Token -> Located Token -> Located Token
-merge_ts (L l1 t) (L l2 _) = L (combineSrcSpans l1 l2) t
-
-- | If the 'Token' is using its unicode variant return the unicode variant of
-- the annotation
toUnicodeAnn :: AnnKeywordId -> Located Token -> AnnKeywordId
=====================================
compiler/GHC/Parser/Errors/Types.hs
=====================================
@@ -471,8 +471,10 @@ data PsMessage
Char -- ^ the character it looks like
String -- ^ the name of the character that it looks like
+ -- | Or pattern used without -XOrPatterns
| PsErrIllegalOrPat (LPat GhcPs)
+ -- | Or pattern with just a single alternative like (one of x)
| PsErrOrPatNeedsTwoAlternatives (LPat GhcPs)
deriving Generic
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -110,7 +110,7 @@ module GHC.Parser.PostProcess (
DisambECP(..),
ecpFromExp,
ecpFromCmd,
- ecpFromPat, mkorpat,
+ ecpFromPat,
PatBuilder,
-- Type/datacon ambiguity resolution
@@ -1469,9 +1469,6 @@ ecpFromCmd a = ECP (ecpFromCmd' a)
ecpFromPat :: LPat GhcPs -> ECP
ecpFromPat a = ECP (ecpFromPat' a)
-mkorpat :: [LPat GhcPs] -> Pat GhcPs
-mkorpat ps = OrPat EpAnnNotUsed (NE.fromList ps)
-
-- The 'fbinds' parser rule produces values of this type. See Note
-- [RecordDotSyntax field updates].
type Fbind b = Either (LHsRecField GhcPs (LocatedA b)) (LHsRecProj GhcPs (LocatedA b))
@@ -1604,9 +1601,6 @@ class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where
mkHsViewPatPV
:: SrcSpan -> LHsExpr GhcPs -> LocatedA b -> [AddEpAnn] -> PV (LocatedA b)
-- | Disambiguate "a at b" (as-pattern)
- mkHsOrPatPV
- :: SrcSpan -> LocatedA b -> LocatedA b -> [AddEpAnn] -> PV (LocatedA b)
- -- | Disambiguate "a at b" (as-pattern)
mkHsAsPatPV
:: SrcSpan -> LocatedN RdrName -> LHsToken "@" GhcPs -> LocatedA b -> PV (LocatedA b)
-- | Disambiguate "~a" (lazy pattern)
@@ -1729,8 +1723,6 @@ instance DisambECP (HsCmd GhcPs) where
in pp_op <> ppr c
mkHsViewPatPV l a b _ = cmdFail l $
ppr a <+> text "->" <+> ppr b
- mkHsOrPatPV l a b _ = cmdFail l $
- ppr a <+> text "->" <+> ppr b
mkHsAsPatPV l v _ c = cmdFail l $
pprPrefixOcc (unLoc v) <> text "@" <> ppr c
mkHsLazyPatPV l c _ = cmdFail l $
@@ -1828,8 +1820,6 @@ instance DisambECP (HsExpr GhcPs) where
return $ L l (SectionR (comment (realSrcSpan l) cs) op e)
mkHsViewPatPV l a b _ = addError (mkPlainErrorMsgEnvelope l $ PsErrViewPatInExpr a b)
>> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn))
- mkHsOrPatPV l a b _ = addError (mkPlainErrorMsgEnvelope l $ PsErrViewPatInExpr a b) -- todo OR
- >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn))
mkHsAsPatPV l v _ e = addError (mkPlainErrorMsgEnvelope l $ PsErrTypeAppWithoutSpace (unLoc v) e)
>> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn))
mkHsLazyPatPV l e _ = addError (mkPlainErrorMsgEnvelope l $ PsErrLazyPatWithoutSpace e)
@@ -1914,15 +1904,6 @@ instance DisambECP (PatBuilder GhcPs) where
p <- checkLPat b
cs <- getCommentsFor l
return $ L (noAnnSrcSpan l) (PatBuilderPat (ViewPat (EpAnn (spanAsAnchor l) anns cs) a p))
- mkHsOrPatPV l a b anns = do
- p <- flatten <$> checkLPat a
- q <- flatten <$> checkLPat b
- cs <- getCommentsFor l
- return $ L (noAnnSrcSpan l) (PatBuilderPat (OrPat (EpAnn (spanAsAnchor l) anns cs) (NE.append p q)))
- where
- flatten :: LPat GhcPs -> NE.NonEmpty (LPat GhcPs)
- flatten (L _ (OrPat _ xs)) = join (NE.map flatten xs)
- flatten x = NE.singleton x
mkHsAsPatPV l v at e = do
p <- checkLPat e
cs <- getCommentsFor l
=====================================
compiler/GHC/Tc/Errors/Types.hs
=====================================
@@ -2552,7 +2552,7 @@ data TcRnMessage where
or-pattern binds variables or has dictionary or evidence biders, e.g. (one of A, B x).
Test case:
- none yet (TODO)
+ testsuite/tests/typecheck/should_fail/Or3
-}
TcRnOrPatBindsVariables
:: Pat GhcTc -- the or-pattern
=====================================
compiler/GHC/Types/Name/Reader.hs
=====================================
@@ -1375,4 +1375,4 @@ pprLoc (UnhelpfulSpan {}) = empty
-- | Indicate if the given name is the "@" operator
opIsAt :: RdrName -> Bool
-opIsAt e = e == mkUnqual varName (fsLit "@")
\ No newline at end of file
+opIsAt e = e == mkUnqual varName (fsLit "@")
=====================================
compiler/Language/Haskell/Syntax/Extension.hs
=====================================
@@ -66,7 +66,7 @@ See also Note [IsPass] and Note [NoGhcTc] in GHC.Hs.Extension.
-}
-- | A placeholder type for TTG extension points that are not currently
--- unused to represent any particular value.
+-- used to represent any particular value.
--
-- This should not be confused with 'DataConCantHappen', which are found in unused
-- extension /constructors/ and therefore should never be inhabited. In
=====================================
compiler/Language/Haskell/Syntax/Pat.hs
=====================================
@@ -140,7 +140,8 @@ data Pat p
| OrPat (XOrPat p)
(NEL.NonEmpty (LPat p))
-
+ -- ^ Or Pattern
+
| SumPat (XSumPat p) -- after typechecker, types of the alternative
(LPat p) -- Sum sub-pattern
ConTag -- Alternative (one-based)
=====================================
testsuite/tests/deSugar/should_run/Or5.hs → testsuite/tests/deSugar/should_run/Or4.hs
=====================================
=====================================
testsuite/tests/deSugar/should_run/Or5.stderr → testsuite/tests/deSugar/should_run/Or4.stderr
=====================================
@@ -1,3 +1,3 @@
-Or5: no backtracking
+Or4: no backtracking
CallStack (from HasCallStack):
- error, called at Or5.hs:42:8 in main:Main
+ error, called at Or4.hs:42:8 in main:Main
=====================================
testsuite/tests/deSugar/should_run/Or5.stdout → testsuite/tests/deSugar/should_run/Or4.stdout
=====================================
=====================================
testsuite/tests/deSugar/should_run/all.T
=====================================
@@ -75,4 +75,4 @@ test('T19680', normal, compile_and_run, [''])
test('T19680A', normal, compile_and_run, [''])
test('T20024', exit_code(1), compile_and_run, [''])
-test('Or5', exit_code(1), compile_and_run, [''])
+test('Or4', exit_code(1), compile_and_run, [''])
=====================================
testsuite/tests/parser/should_fail/Or1.hs
=====================================
@@ -1,4 +1,9 @@
module Main where
-main = case 1 of
- (one of 2, 3) -> True
\ No newline at end of file
+main = g 3 && h 1
+
+h y = case y of
+ (one of 2, 3) -> True
+
+g x = case x of
+ one of 4, 5 -> False
\ No newline at end of file
=====================================
testsuite/tests/parser/should_fail/Or1.stderr
=====================================
@@ -1,4 +1,6 @@
-Or1.hs:4:4: error: [GHC-29847]
+Or1.hs:6:4: error: [GHC-29847]
Illegal or-pattern: one of 2, 3
Suggested fix: Perhaps you intended to use OrPatterns
+
+Or1.hs:9:7: error: [GHC-58481] parse error on input ‘of’
=====================================
testsuite/tests/parser/should_fail/Or2.hs
=====================================
@@ -1,4 +1,6 @@
+{-# LANGUAGE OrPatterns #-}
+
module Main where
main = case 3 of
- one of 4, 5 -> False
\ No newline at end of file
+ (one of 4) -> False
\ No newline at end of file
=====================================
testsuite/tests/parser/should_fail/Or2.stderr
=====================================
@@ -1,2 +1,3 @@
-Or2.hs:4:7: error: [GHC-58481] parse error on input ‘of’
+Or2.hs:6:4: error: [GHC-96152]
+ Or-pattern needs at least two alternatives: one of 4
=====================================
testsuite/tests/parser/should_fail/Or3.hs deleted
=====================================
@@ -1,7 +0,0 @@
-{-# LANGUAGE OrPatterns #-}
-
-module Main where
-
-main = case 3 of
- (one of 4) -> False
- (one of x, _) -> x == 3
\ No newline at end of file
=====================================
testsuite/tests/parser/should_fail/Or3.stderr deleted
=====================================
@@ -1,3 +0,0 @@
-
-Or3.hs:6:4: error: [GHC-96152]
- Or-pattern needs at least two alternatives: one of 4
=====================================
testsuite/tests/parser/should_fail/all.T
=====================================
@@ -218,4 +218,3 @@ test('T21843f', normal, compile_fail, [''])
test('Or1', normal, compile_fail, [''])
test('Or2', normal, compile_fail, [''])
-test('Or3', normal, compile_fail, [''])
=====================================
testsuite/tests/rename/should_fail/Or4.stderr deleted
=====================================
@@ -1,131 +0,0 @@
-*** Core Lint errors : in result of Desugar (before optimization) ***
-Or4.hs:11:5: warning:
- Out of scope: $dNum_aDz :: Num a_aDq
- [LclId]
- In the RHS of foo :: forall a. a -> GADT a -> a
- In the body of lambda with binder a_aDq :: *
- In the body of lambda with binder x_aw0 :: a_aDq
- In the body of lambda with binder ds_dMh :: GADT a_aDq
- In the body of lambda with binder ds_dMt :: (# #)
- In an occurrence of $dNum_aDz :: Num a_aDq
- Substitution: <InScope = {a_aDq}
- IdSubst = []
- TvSubst = [aDq :-> a_aDq]
- CvSubst = []>
-*** Offending Program ***
-Rec {
-$tcGADT :: TyCon
-[LclIdX]
-$tcGADT
- = TyCon
- 7315894308497656774#Word64
- 13366801423186927574#Word64
- $trModule
- (TrNameS "GADT"#)
- 0#
- krep$*Arr*
-
-$tc'IsInt1 :: TyCon
-[LclIdX]
-$tc'IsInt1
- = TyCon
- 1090152040133353571#Word64
- 3950193049621776869#Word64
- $trModule
- (TrNameS "'IsInt1"#)
- 0#
- $krep_aLk
-
-$tc'IsInt2 :: TyCon
-[LclIdX]
-$tc'IsInt2
- = TyCon
- 838859291769359256#Word64
- 1629192201818783450#Word64
- $trModule
- (TrNameS "'IsInt2"#)
- 0#
- $krep_aLk
-
-$krep_aLk [InlPrag=[~]] :: KindRep
-[LclId]
-$krep_aLk
- = KindRepTyConApp $tcGADT (: @KindRep $krep_aLl ([] @KindRep))
-
-$krep_aLl [InlPrag=[~]] :: KindRep
-[LclId]
-$krep_aLl = KindRepTyConApp $tcInt ([] @KindRep)
-
-$trModule :: Module
-[LclIdX]
-$trModule = Module (TrNameS "main"#) (TrNameS "Main"#)
-
-foo :: forall a. a -> GADT a -> a
-[LclIdX]
-foo
- = \ (@a_aDq) (x_aw0 :: a_aDq) (ds_dMh :: GADT a_aDq) ->
- let {
- success_dMs :: (# #) -> a_aDq
- [LclId]
- success_dMs
- = \ (ds_dMt [OS=OneShot] :: (# #)) ->
- + @a_aDq
- $dNum_aDz
- x_aw0
- (fromInteger @a_aDq $dNum_aDB (IS 1#)) } in
- case ds_dMh of wild_00 {
- IsInt1 co_aDt -> success_dMs (##);
- IsInt2 co_aDv ->
- let {
- $dNum_aL2 :: Num Int
- [LclId]
- $dNum_aL2 = $fNumInt } in
- let {
- $dNum_aDB :: Num a_aDq
- [LclId]
- $dNum_aDB
- = $dNum_aL2
- `cast` (Sub (Sym (Num co_aDt)_N) :: Num Int ~R# Num a_aDq) } in
- let {
- $dNum_aDz :: Num a_aDq
- [LclId]
- $dNum_aDz
- = $dNum_aL2
- `cast` (Sub (Sym (Num co_aDt)_N) :: Num Int ~R# Num a_aDq) } in
- success_dMs (##)
- }
-
-main :: IO ()
-[LclIdX]
-main
- = let {
- $dNum_aKU :: Num Int
- [LclId]
- $dNum_aKU = $fNumInt } in
- let {
- $dShow_aKR :: Show Int
- [LclId]
- $dShow_aKR = $fShowInt } in
- letrec {
- main_aDF :: IO ()
- [LclId]
- main_aDF
- = $ @LiftedRep
- @Int
- @(IO ())
- (print @Int $dShow_aKR)
- (foo @Int (I# 3#) $WIsInt1); } in
- main_aDF
-
-main :: IO ()
-[LclIdX]
-main = runMainIO @() main
-end Rec }
-
-*** End of Offense ***
-
-
-<no location info>: error:
-Compilation had errors
-
-
=====================================
testsuite/tests/rename/should_fail/all.T
=====================================
@@ -179,6 +179,4 @@ test('T18138', normal, compile_fail, [''])
test('T20147', normal, compile_fail, [''])
test('RnEmptyStatementGroup1', normal, compile_fail, [''])
-test('RnImplicitBindInMdoNotation', normal, compile_fail, [''])
-
-test('Or4', normal, compile_fail, [''])
\ No newline at end of file
+test('RnImplicitBindInMdoNotation', normal, compile_fail, [''])
\ No newline at end of file
=====================================
testsuite/tests/rename/should_fail/Or4.hs → testsuite/tests/typecheck/should_fail/Or3.hs
=====================================
@@ -3,6 +3,14 @@
module Main where
+data G a where
+ G1 :: Num a => G a
+ G2 :: Num a => G a
+ G3 :: Num a => G a
+
+bar :: G a -> a
+bar (one of G2, G1) = 3
+
data GADT a where
IsInt1 :: GADT Int
IsInt2 :: GADT Int
@@ -10,4 +18,10 @@ data GADT a where
foo :: a -> GADT a -> a
foo x (one of IsInt1 {}, IsInt2 {}) = x + 1
+f x = case x of
+ (one of Left a, Right a) -> a
+
+g x = case x of
+ (one of _, (one of _, x)) -> x
+
main = print $ foo 3 IsInt1
\ No newline at end of file
=====================================
testsuite/tests/typecheck/should_fail/Or3.stderr
=====================================
@@ -0,0 +1,14 @@
+
+Or3.hs:12:6: error: [GHC-81303]
+ Or-pattern may not bind (type) variable, dictionary or equality constraints: one of G2,
+ G1
+
+Or3.hs:19:8: error: [GHC-81303]
+ Or-pattern may not bind (type) variable, dictionary or equality constraints: one of IsInt1 {},
+ IsInt2 {}
+
+Or3.hs:22:4: error: [GHC-81303]
+ Or-pattern may not bind variables: one of Left a, Right a
+
+Or3.hs:25:15: error: [GHC-81303]
+ Or-pattern may not bind variables: one of _, x
=====================================
testsuite/tests/typecheck/should_fail/all.T
=====================================
@@ -663,3 +663,4 @@ test('MissingDefaultMethodBinding', normal, compile_fail, [''])
test('T21447', normal, compile_fail, [''])
test('T21530a', normal, compile_fail, [''])
test('T21530b', normal, compile_fail, [''])
+test('Or3', normal, compile_fail, [''])
\ No newline at end of file
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/af12882574c359c39c3f63ac352933d5c6fa79ac
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/af12882574c359c39c3f63ac352933d5c6fa79ac
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/20221212/0593ffa8/attachment-0001.html>
More information about the ghc-commits
mailing list