Skip to content
Snippets Groups Projects
Commit 2f846706 authored by Gergő Érdi's avatar Gergő Érdi Committed by Austin Seipp
Browse files

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
...@@ -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 -> MaybeT 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 -> MaybeT 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.
-- --
......
...@@ -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, [''])
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment