Commit 44640af7 authored by Matthew Pickering's avatar Matthew Pickering
Browse files

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
parent 8d954125
......@@ -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"
......@@ -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
......
{-# LANGUAGE PatternSynonyms #-}
module T9793 where
pattern P :: [a] -> [a]
pattern P x <- x@(_:_)
......@@ -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, [''])
{-# LANGUAGE PatternSynonyms #-}
module Foo where
pattern P :: [a] -> [a]
pattern P x <- x@(y:_)
T9793-fail.hs:6:16: error:
Pattern synonym definition cannot contain as-patterns (@) which contain free variables:
x@(y : _)
......@@ -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, [''])
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)
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment