Skip to content
GitLab
Explore
Sign in
Register
Primary navigation
Search or go to…
Project
GHC
Manage
Activity
Members
Labels
Plan
Issues
Issue boards
Milestones
Wiki
Requirements
Code
Merge requests
Repository
Branches
Commits
Tags
Repository graph
Compare revisions
Snippets
Locked files
Build
Pipelines
Jobs
Pipeline schedules
Test cases
Artifacts
Deploy
Releases
Package Registry
Model registry
Operate
Environments
Terraform modules
Monitor
Incidents
Analyze
Value stream analytics
Contributor analytics
CI/CD analytics
Repository analytics
Code review analytics
Issue analytics
Insights
Model experiments
Help
Help
Support
GitLab documentation
Compare GitLab plans
Community forum
Contribute to GitLab
Provide feedback
Terms and privacy
Keyboard shortcuts
?
Snippets
Groups
Projects
Show more breadcrumbs
Alexander Kaznacheev
GHC
Commits
2f846706
Commit
2f846706
authored
11 years ago
by
Gergő Érdi
Committed by
Austin Seipp
11 years ago
Browse files
Options
Downloads
Patches
Plain Diff
Split off pattern synonym definition checking from pattern inversion
(cherry picked from commit
c269b7e8
)
parent
a43d536b
No related branches found
No related tags found
No related merge requests found
Changes
2
Hide whitespace changes
Inline
Side-by-side
Showing
2 changed files
compiler/typecheck/TcPatSyn.lhs
+68
-42
68 additions, 42 deletions
compiler/typecheck/TcPatSyn.lhs
testsuite/tests/patsyn/should_fail/all.T
+1
-0
1 addition, 0 deletions
testsuite/tests/patsyn/should_fail/all.T
with
69 additions
and
42 deletions
compiler/typecheck/TcPatSyn.lhs
+
68
−
42
View file @
2f846706
...
@@ -16,7 +16,6 @@ import TysPrim
...
@@ -16,7 +16,6 @@ import TysPrim
import Name
import Name
import SrcLoc
import SrcLoc
import PatSyn
import PatSyn
import Maybes
import NameSet
import NameSet
import Panic
import Panic
import Outputable
import Outputable
...
@@ -65,6 +64,7 @@ tcPatSynDecl :: Located Name
...
@@ -65,6 +64,7 @@ tcPatSynDecl :: Located Name
-> TcM (PatSyn, LHsBinds Id)
-> TcM (PatSyn, LHsBinds Id)
tcPatSynDecl lname@(L _ name) details lpat dir
tcPatSynDecl lname@(L _ name) details lpat dir
= do { traceTc "tcPatSynDecl {" $ ppr name $$ ppr lpat
= do { traceTc "tcPatSynDecl {" $ ppr name $$ ppr lpat
; tcCheckPatSynPat lpat
; pat_ty <- newFlexiTyVarTy openTypeKind
; pat_ty <- newFlexiTyVarTy openTypeKind
; let (arg_names, is_infix) = case details of
; let (arg_names, is_infix) = case details of
...
@@ -240,8 +240,7 @@ tcPatSynWrapper :: Located Name
...
@@ -240,8 +240,7 @@ tcPatSynWrapper :: Located Name
-> TcM (Maybe (Id, LHsBinds Id))
-> TcM (Maybe (Id, LHsBinds Id))
tcPatSynWrapper lname lpat dir args univ_tvs ex_tvs theta pat_ty
tcPatSynWrapper lname lpat dir args univ_tvs ex_tvs theta pat_ty
= do { let argNames = mkNameSet (map Var.varName args)
= do { let argNames = mkNameSet (map Var.varName args)
; m_expr <- runMaybeT $ tcPatToExpr argNames lpat
; case (dir, tcPatToExpr argNames lpat) of
; case (dir, m_expr) of
(Unidirectional, _) ->
(Unidirectional, _) ->
return Nothing
return Nothing
(ImplicitBidirectional, Nothing) ->
(ImplicitBidirectional, Nothing) ->
...
@@ -291,13 +290,9 @@ tc_pat_syn_wrapper_from_expr (L loc name) lexpr args univ_tvs ex_tvs theta pat_t
...
@@ -291,13 +290,9 @@ tc_pat_syn_wrapper_from_expr (L loc name) lexpr args univ_tvs ex_tvs theta pat_t
Note [As-patterns in pattern synonym definitions]
Note [As-patterns in pattern synonym definitions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Beside returning the inverted pattern (when injectivity holds), we
The rationale for rejecting as-patterns in pattern synonym definitions
also check the pattern on its own here. In particular, we reject
is that an as-pattern would introduce nonindependent pattern synonym
as-patterns.
arguments, e.g. given a pattern synonym like:
The rationale for that is that an as-pattern would introduce
nonindependent pattern synonym arguments, e.g. given a pattern synonym
like:
pattern K x y = x@(Just y)
pattern K x y = x@(Just y)
...
@@ -309,51 +304,90 @@ or
...
@@ -309,51 +304,90 @@ or
g (K (Just True) False) = ...
g (K (Just True) False) = ...
\begin{code}
\begin{code}
tcPatToExpr :: NameSet -> LPat Name -> MaybeT TcM (LHsExpr Name)
tcCheckPatSynPat :: LPat Name -> TcM ()
tcCheckPatSynPat = go
where
go :: LPat Name -> TcM ()
go = addLocM go1
go1 :: Pat Name -> TcM ()
go1 (ConPatIn _ info) = mapM_ go (hsConPatArgs info)
go1 VarPat{} = return ()
go1 WildPat{} = return ()
go1 p@(AsPat _ _) = asPatInPatSynErr p
go1 (LazyPat pat) = go pat
go1 (ParPat pat) = go pat
go1 (BangPat pat) = go pat
go1 (PArrPat pats _) = mapM_ go pats
go1 (ListPat pats _ _) = mapM_ go pats
go1 (TuplePat pats _ _) = mapM_ go pats
go1 (LitPat lit) = return ()
go1 (NPat n _ _) = return ()
go1 (SigPatIn pat _) = go pat
go1 (ViewPat _ pat _) = go pat
go1 p@SplicePat{} = thInPatSynErr p
go1 p@QuasiQuotePat{} = thInPatSynErr p
go1 p@NPlusKPat{} = nPlusKPatInPatSynErr p
go1 ConPatOut{} = panic "ConPatOut in output of renamer"
go1 SigPatOut{} = panic "SigPatOut in output of renamer"
go1 CoPat{} = panic "CoPat in output of renamer"
asPatInPatSynErr :: OutputableBndr name => Pat name -> TcM a
asPatInPatSynErr pat
= failWithTc $
hang (ptext (sLit "Pattern synonym definition cannot contain as-patterns (@):"))
2 (ppr pat)
thInPatSynErr :: OutputableBndr name => Pat name -> TcM a
thInPatSynErr pat
= failWithTc $
hang (ptext (sLit "Pattern synonym definition cannot contain Template Haskell:"))
2 (ppr pat)
nPlusKPatInPatSynErr :: OutputableBndr name => Pat name -> TcM a
nPlusKPatInPatSynErr pat
= failWithTc $
hang (ptext (sLit "Pattern synonym definition cannot contain n+k-pattern:"))
2 (ppr pat)
tcPatToExpr :: NameSet -> LPat Name -> Maybe (LHsExpr Name)
tcPatToExpr lhsVars = go
tcPatToExpr lhsVars = go
where
where
go :: LPat Name -> Maybe
T TcM
(LHsExpr Name)
go :: LPat Name -> Maybe (LHsExpr Name)
go (L loc (ConPatIn conName info))
go (L loc (ConPatIn conName info))
=
MaybeT . setSrcSpan loc . runMaybeT $
do
= do
{ let con = L loc (HsVar (unLoc conName))
{ let con = L loc (HsVar (unLoc conName))
; exprs <- mapM go (hsConPatArgs info)
; exprs <- mapM go (hsConPatArgs info)
; return $ foldl (\x y -> L loc (HsApp x y)) con exprs }
; return $ foldl (\x y -> L loc (HsApp x y)) con exprs }
go
p = withLoc
go1 p
go
(L loc p) = fmap (L loc) $
go1 p
go1 :: Pat Name -> Maybe
T TcM
(HsExpr Name)
go1 :: Pat Name -> Maybe (HsExpr Name)
go1 (VarPat var)
go1 (VarPat var)
| var `elemNameSet` lhsVars = return (HsVar var)
| var `elemNameSet` lhsVars = return $ HsVar var
| otherwise = tcNothing
| otherwise = Nothing
go1 p@(AsPat _ _) = asPatInPatSynErr p
go1 (LazyPat pat) = fmap HsPar $ go pat
go1 (LazyPat pat) = fmap HsPar (go pat)
go1 (ParPat pat) = fmap HsPar $ go pat
go1 (ParPat pat) = fmap HsPar (go pat)
go1 (BangPat pat) = fmap HsPar $ go pat
go1 (BangPat pat) = fmap HsPar (go pat)
go1 (PArrPat pats ptt)
go1 (PArrPat pats ptt)
= do { exprs <- mapM go pats
= do { exprs <- mapM go pats
; return
(
ExplicitPArr ptt exprs
)
}
; return
$
ExplicitPArr ptt exprs }
go1 (ListPat pats ptt reb)
go1 (ListPat pats ptt reb)
= do { exprs <- mapM go pats
= do { exprs <- mapM go pats
; return
(
ExplicitList ptt (fmap snd reb) exprs
)
}
; return
$
ExplicitList ptt (fmap snd reb) exprs }
go1 (TuplePat pats box _)
go1 (TuplePat pats box _)
= do { exprs <- mapM go pats
= do { exprs <- mapM go pats
; return (ExplicitTuple (map Present exprs) box)
; return (ExplicitTuple (map Present exprs) box)
}
}
go1 (LitPat lit) = return
(
HsLit lit
)
go1 (LitPat lit)
= return
$
HsLit lit
go1 (NPat n Nothing _) = return
(
HsOverLit n
)
go1 (NPat n Nothing _) = return
$
HsOverLit n
go1 (NPat n (Just neg) _) = return
(
noLoc neg `HsApp` noLoc (HsOverLit n)
)
go1 (NPat n (Just neg) _) = return
$
noLoc neg `HsApp` noLoc (HsOverLit n)
go1 (SigPatIn pat (HsWB ty _ _))
go1 (SigPatIn pat (HsWB ty _ _))
= do { expr <- go pat
= do { expr <- go pat
; return
(
ExprWithTySig expr ty
)
}
; return
$
ExprWithTySig expr ty }
go1 (ConPatOut{}) = panic "ConPatOut in output of renamer"
go1 (ConPatOut{}) = panic "ConPatOut in output of renamer"
go1 (SigPatOut{}) = panic "SigPatOut in output of renamer"
go1 (SigPatOut{}) = panic "SigPatOut in output of renamer"
go1 (CoPat{}) = panic "CoPat in output of renamer"
go1 (CoPat{}) = panic "CoPat in output of renamer"
go1 _ = tcNothing
go1 _ = Nothing
asPatInPatSynErr :: OutputableBndr name => Pat name -> MaybeT TcM a
asPatInPatSynErr pat
= MaybeT . failWithTc $
hang (ptext (sLit "Pattern synonym definition cannot contain as-patterns (@):"))
2 (ppr pat)
cannotInvertPatSynErr :: OutputableBndr name => LPat name -> TcM a
cannotInvertPatSynErr :: OutputableBndr name => LPat name -> TcM a
cannotInvertPatSynErr (L loc pat)
cannotInvertPatSynErr (L loc pat)
...
@@ -361,14 +395,6 @@ cannotInvertPatSynErr (L loc pat)
...
@@ -361,14 +395,6 @@ cannotInvertPatSynErr (L loc pat)
hang (ptext (sLit "Right-hand side of bidirectional pattern synonym cannot be used as an expression"))
hang (ptext (sLit "Right-hand side of bidirectional pattern synonym cannot be used as an expression"))
2 (ppr pat)
2 (ppr pat)
tcNothing :: MaybeT TcM a
tcNothing = MaybeT (return Nothing)
withLoc :: (a -> MaybeT TcM b) -> Located a -> MaybeT TcM (Located b)
withLoc fn (L loc x) = MaybeT $ setSrcSpan loc $
do { y <- runMaybeT $ fn x
; return (fmap (L loc) y) }
-- Walk the whole pattern and for all ConPatOuts, collect the
-- Walk the whole pattern and for all ConPatOuts, collect the
-- existentially-bound type variables and evidence binding variables.
-- existentially-bound type variables and evidence binding variables.
--
--
...
...
This diff is collapsed.
Click to expand it.
testsuite/tests/patsyn/should_fail/all.T
+
1
−
0
View file @
2f846706
...
@@ -3,3 +3,4 @@ test('mono', normal, compile_fail, [''])
...
@@ -3,3 +3,4 @@ test('mono', normal, compile_fail, [''])
test
('
unidir
',
normal
,
compile_fail
,
[''])
test
('
unidir
',
normal
,
compile_fail
,
[''])
test
('
local
',
normal
,
compile_fail
,
[''])
test
('
local
',
normal
,
compile_fail
,
[''])
test
('
T8961
',
normal
,
multimod_compile_fail
,
['
T8961
',''])
test
('
T8961
',
normal
,
multimod_compile_fail
,
['
T8961
',''])
test
('
as-pattern
',
normal
,
compile_fail
,
[''])
This diff is collapsed.
Click to expand it.
Preview
0%
Loading
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Save comment
Cancel
Please
register
or
sign in
to comment