[commit: ghc] master: Allow as-patterns in pattern synonym declarations. (44640af)
git at git.haskell.org
git at git.haskell.org
Sun Dec 20 23:47:48 UTC 2015
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/44640af7afa1a01ff2e2357f7c1436b4804866fc/ghc
>---------------------------------------------------------------
commit 44640af7afa1a01ff2e2357f7c1436b4804866fc
Author: Matthew Pickering <matthewtpickering at gmail.com>
Date: Sun Dec 20 23:46:40 2015 +0000
Allow as-patterns in pattern synonym declarations.
We can allow them if they contain no free variables. This patch just allows
them in one direction and not to be used as builders as the original ticket
suggests.
Test Plan: ./validate
Reviewers: austin, bgamari
Reviewed By: bgamari
Subscribers: thomie
Differential Revision: https://phabricator.haskell.org/D1666
GHC Trac Issues: #9739
Conflicts:
testsuite/tests/patsyn/should_fail/all.T
>---------------------------------------------------------------
44640af7afa1a01ff2e2357f7c1436b4804866fc
compiler/hsSyn/HsPat.hs | 32 ++++++++++++++++++++++
compiler/typecheck/TcPatSyn.hs | 7 +++--
testsuite/tests/patsyn/should_compile/T9793.hs | 5 ++++
testsuite/tests/patsyn/should_compile/all.T | 1 +
testsuite/tests/patsyn/should_fail/T9793-fail.hs | 6 ++++
.../tests/patsyn/should_fail/T9793-fail.stderr | 4 +++
testsuite/tests/patsyn/should_fail/all.T | 1 +
.../tests/patsyn/should_fail/as-pattern.stderr | 4 +--
8 files changed, 56 insertions(+), 4 deletions(-)
diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs
index 0f65e4b..38f0626 100644
--- a/compiler/hsSyn/HsPat.hs
+++ b/compiler/hsSyn/HsPat.hs
@@ -34,6 +34,8 @@ module HsPat (
collectEvVarsPats,
+ hasFreeVarsLPat, hasFreeVarsPat,
+
pprParendLPat, pprConArgs
) where
@@ -656,3 +658,33 @@ collectEvVarsPat pat =
ConPatIn _ _ -> panic "foldMapPatBag: ConPatIn"
SigPatIn _ _ -> panic "foldMapPatBag: SigPatIn"
_other_pat -> emptyBag
+
+hasFreeVarsLPat :: LPat id -> Bool
+hasFreeVarsLPat (L _ pat) = hasFreeVarsPat pat
+
+-- | Checks whether a pattern contains any unbound variables from
+-- `VarPat`s or `AsPat`s.
+hasFreeVarsPat :: Pat id -> Bool
+hasFreeVarsPat pat =
+ case pat of
+ VarPat {} -> True
+ AsPat {} -> True
+ NPlusKPat {} -> True
+ NPat {} -> False
+ LitPat {} -> False
+ WildPat {} -> False
+ ViewPat _ p _ -> hasFreeVarsLPat p
+ LazyPat p -> hasFreeVarsLPat p
+ ParPat p -> hasFreeVarsLPat p
+ BangPat p -> hasFreeVarsLPat p
+ ListPat ps _ _ -> any hasFreeVarsLPat ps
+ TuplePat ps _ _ -> any hasFreeVarsLPat ps
+ PArrPat ps _ -> any hasFreeVarsLPat ps
+ ConPatOut {pat_args = ps}
+ -> any hasFreeVarsLPat (hsConPatArgs ps)
+ SigPatOut p _ -> hasFreeVarsLPat p
+ CoPat _ p _ -> hasFreeVarsPat p
+ ConPatIn _ p -> any hasFreeVarsLPat (hsConPatArgs p)
+ SigPatIn p _ -> hasFreeVarsLPat p
+
+ SplicePat {} -> panic "hasFreVarsPat: SplicePat"
diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs
index 5480ab8..61b54fd 100644
--- a/compiler/typecheck/TcPatSyn.hs
+++ b/compiler/typecheck/TcPatSyn.hs
@@ -558,7 +558,10 @@ tcCheckPatSynPat = go
go1 (ConPatIn _ info) = mapM_ go (hsConPatArgs info)
go1 VarPat{} = return ()
go1 WildPat{} = return ()
- go1 p@(AsPat _ _) = asPatInPatSynErr p
+ go1 pat@(AsPat _ p) =
+ if hasFreeVarsLPat p
+ then asPatInPatSynErr pat
+ else go p
go1 (LazyPat pat) = go pat
go1 (ParPat pat) = go pat
go1 (BangPat pat) = go pat
@@ -578,7 +581,7 @@ tcCheckPatSynPat = go
asPatInPatSynErr :: OutputableBndr name => Pat name -> TcM a
asPatInPatSynErr pat
= failWithTc $
- hang (ptext (sLit "Pattern synonym definition cannot contain as-patterns (@):"))
+ hang (ptext (sLit "Pattern synonym definition cannot contain as-patterns (@) which contain free variables:"))
2 (ppr pat)
thInPatSynErr :: OutputableBndr name => Pat name -> TcM a
diff --git a/testsuite/tests/patsyn/should_compile/T9793.hs b/testsuite/tests/patsyn/should_compile/T9793.hs
new file mode 100644
index 0000000..230c861
--- /dev/null
+++ b/testsuite/tests/patsyn/should_compile/T9793.hs
@@ -0,0 +1,5 @@
+{-# LANGUAGE PatternSynonyms #-}
+module T9793 where
+
+pattern P :: [a] -> [a]
+pattern P x <- x@(_:_)
diff --git a/testsuite/tests/patsyn/should_compile/all.T b/testsuite/tests/patsyn/should_compile/all.T
index 7ab5ac7..3793c0d 100644
--- a/testsuite/tests/patsyn/should_compile/all.T
+++ b/testsuite/tests/patsyn/should_compile/all.T
@@ -44,3 +44,4 @@ test('export-record-selector', normal, compile, [''])
test('T10897', expect_broken(10897), multi_compile, ['T10897', [
('T10897a.hs','-c')
,('T10897b.hs', '-c')], ''])
+test('T9793', normal, compile, [''])
diff --git a/testsuite/tests/patsyn/should_fail/T9793-fail.hs b/testsuite/tests/patsyn/should_fail/T9793-fail.hs
new file mode 100644
index 0000000..2787a8d
--- /dev/null
+++ b/testsuite/tests/patsyn/should_fail/T9793-fail.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE PatternSynonyms #-}
+
+module Foo where
+
+pattern P :: [a] -> [a]
+pattern P x <- x@(y:_)
diff --git a/testsuite/tests/patsyn/should_fail/T9793-fail.stderr b/testsuite/tests/patsyn/should_fail/T9793-fail.stderr
new file mode 100644
index 0000000..62713dc
--- /dev/null
+++ b/testsuite/tests/patsyn/should_fail/T9793-fail.stderr
@@ -0,0 +1,4 @@
+
+T9793-fail.hs:6:16: error:
+ Pattern synonym definition cannot contain as-patterns (@) which contain free variables:
+ x@(y : _)
diff --git a/testsuite/tests/patsyn/should_fail/all.T b/testsuite/tests/patsyn/should_fail/all.T
index 6ef64ae..6163da1 100644
--- a/testsuite/tests/patsyn/should_fail/all.T
+++ b/testsuite/tests/patsyn/should_fail/all.T
@@ -27,3 +27,4 @@ test('export-type-synonym', normal, compile_fail, [''])
test('export-ps-rec-sel', normal, compile_fail, [''])
test('T11053', normal, compile, ['-fwarn-missing-pat-syn-sigs'])
test('T10426', normal, compile_fail, [''])
+test('T9793-fail', normal, compile_fail, [''])
diff --git a/testsuite/tests/patsyn/should_fail/as-pattern.stderr b/testsuite/tests/patsyn/should_fail/as-pattern.stderr
index 62db28f..caabd47 100644
--- a/testsuite/tests/patsyn/should_fail/as-pattern.stderr
+++ b/testsuite/tests/patsyn/should_fail/as-pattern.stderr
@@ -1,4 +1,4 @@
-as-pattern.hs:4:18:
- Pattern synonym definition cannot contain as-patterns (@):
+as-pattern.hs:4:18: error:
+ Pattern synonym definition cannot contain as-patterns (@) which contain free variables:
x@(Just y)
More information about the ghc-commits
mailing list