diff options
| -rw-r--r-- | compiler/typecheck/TcPatSyn.hs | 32 | ||||
| -rw-r--r-- | docs/users_guide/8.4.1-notes.rst | 14 | ||||
| -rw-r--r-- | docs/users_guide/glasgow_exts.rst | 17 | ||||
| -rw-r--r-- | testsuite/tests/patsyn/should_fail/T14112.hs | 5 | ||||
| -rw-r--r-- | testsuite/tests/patsyn/should_fail/T14112.stderr | 7 | ||||
| -rw-r--r-- | testsuite/tests/patsyn/should_fail/all.T | 1 | ||||
| -rw-r--r-- | testsuite/tests/patsyn/should_fail/unidir.stderr | 4 |
7 files changed, 72 insertions, 8 deletions
diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs index 67e031aeaa..fe9ad18a92 100644 --- a/compiler/typecheck/TcPatSyn.hs +++ b/compiler/typecheck/TcPatSyn.hs @@ -574,7 +574,7 @@ tcPatSynBuilderBind (PSB { psb_id = L loc name, psb_def = lpat mb_match_group = case dir of ExplicitBidirectional explicit_mg -> Right explicit_mg - ImplicitBidirectional -> fmap mk_mg (tcPatToExpr args lpat) + ImplicitBidirectional -> fmap mk_mg (tcPatToExpr name args lpat) Unidirectional -> panic "tcPatSynBuilderBind" mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn) @@ -621,7 +621,8 @@ add_void need_dummy_arg ty | need_dummy_arg = mkFunTy voidPrimTy ty | otherwise = ty -tcPatToExpr :: [Located Name] -> LPat GhcRn -> Either MsgDoc (LHsExpr GhcRn) +tcPatToExpr :: Name -> [Located Name] -> LPat GhcRn + -> Either MsgDoc (LHsExpr GhcRn) -- Given a /pattern/, return an /expression/ that builds a value -- that matches the pattern. E.g. if the pattern is (Just [x]), -- the expression is (Just [x]). They look the same, but the @@ -630,7 +631,7 @@ tcPatToExpr :: [Located Name] -> LPat GhcRn -> Either MsgDoc (LHsExpr GhcRn) -- -- Returns (Left r) if the pattern is not invertible, for reason r. -- See Note [Builder for a bidirectional pattern synonym] -tcPatToExpr args pat = go pat +tcPatToExpr name args pat = go pat where lhsVars = mkNameSet (map unLoc args) @@ -667,8 +668,6 @@ tcPatToExpr args pat = go pat | otherwise = Left (quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym") go1 (ParPat pat) = fmap HsPar $ go pat - go1 (LazyPat pat) = go1 (unLoc pat) - go1 (BangPat pat) = go1 (unLoc pat) go1 (PArrPat pats ptt) = do { exprs <- mapM go pats ; return $ ExplicitPArr ptt exprs } go1 (ListPat pats ptt reb) = do { exprs <- mapM go pats @@ -689,7 +688,28 @@ tcPatToExpr args pat = go pat go1 (SplicePat (HsSpliced _ (HsSplicedPat pat))) = go1 pat go1 (SplicePat (HsSpliced{})) = panic "Invalid splice variety" - go1 p = Left (text "pattern" <+> quotes (ppr p) <+> text "is not invertible") + + -- The following patterns are not invertible. + go1 p@(BangPat {}) = notInvertible p -- #14112 + go1 p@(LazyPat {}) = notInvertible p + go1 p@(WildPat {}) = notInvertible p + go1 p@(AsPat {}) = notInvertible p + go1 p@(ViewPat {}) = notInvertible p + go1 p@(NPlusKPat {}) = notInvertible p + go1 p@(SplicePat (HsTypedSplice {})) = notInvertible p + go1 p@(SplicePat (HsUntypedSplice {})) = notInvertible p + go1 p@(SplicePat (HsQuasiQuote {})) = notInvertible p + + notInvertible p = Left $ + text "Pattern" <+> quotes (ppr p) <+> text "is not invertible" + $+$ hang (text "Suggestion: instead use an explicitly bidirectional" + <+> text "pattern synonym, e.g.") + 2 (hang (text "pattern" <+> pp_name <+> pp_args <+> larrow + <+> ppr pat <+> text "where") + 2 (pp_name <+> pp_args <+> equals <+> text "...")) + where + pp_name = ppr name + pp_args = hsep (map ppr args) {- Note [Builder for a bidirectional pattern synonym] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/docs/users_guide/8.4.1-notes.rst b/docs/users_guide/8.4.1-notes.rst index 8a6d4048b4..8f61ef86fe 100644 --- a/docs/users_guide/8.4.1-notes.rst +++ b/docs/users_guide/8.4.1-notes.rst @@ -27,6 +27,20 @@ Language wish to; this is quite like how regular datatypes with a kind signature can omit some type variables. +- Implicitly bidirectional pattern synonyms no longer allow bang patterns + (``!``) or irrefutable patterns (``~``) on the right-hand side. Previously, + this was allowed, although the bang patterns and irrefutable patterns would + be silently ignored when used in an expression context. This is now a proper + error, and explicitly bidirectional pattern synonyms should be used in their + stead. That is, instead of using this (which is an error): :: + + data StrictJust a = Just !a + + Use this: :: + + data StrictJust a <- Just !a where + StrictJust !a = Just a + Compiler ~~~~~~~~ diff --git a/docs/users_guide/glasgow_exts.rst b/docs/users_guide/glasgow_exts.rst index 59d5934616..bd11360acc 100644 --- a/docs/users_guide/glasgow_exts.rst +++ b/docs/users_guide/glasgow_exts.rst @@ -5096,6 +5096,21 @@ We can then use ``HeadC`` in both expression and pattern contexts. In a pattern context it will match the head of any list with length at least one. In an expression context it will construct a singleton list. +Explicitly bidirectional pattern synonyms offer greater flexibility than +implicitly bidirectional ones in terms of the syntax that is permitted. For +instance, the following is not a legal implicitly bidirectional pattern +synonym: :: + + pattern StrictJust a = Just !a + +This is illegal because the use of :ghc-flag:`-XBangPatterns` on the right-hand +sides prevents it from being a well formed expression. However, constructing a +strict pattern synonym is quite possible with an explicitly bidirectional +pattern synonym: :: + + pattern StrictJust a <- Just !a where + StrictJust !a = Just a + The table below summarises where each kind of pattern synonym can be used. +---------------+----------------+---------------+---------------------------+ @@ -7158,7 +7173,7 @@ Unlike with ordinary data definitions, the result kind of a data family does not need to be ``*``: it can alternatively be a kind variable (with :ghc-flag:`-XPolyKinds`). Data instances' kinds must end in ``*``, however. - + .. _data-instance-declarations: Data instance declarations diff --git a/testsuite/tests/patsyn/should_fail/T14112.hs b/testsuite/tests/patsyn/should_fail/T14112.hs new file mode 100644 index 0000000000..3e28644480 --- /dev/null +++ b/testsuite/tests/patsyn/should_fail/T14112.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE PatternSynonyms #-} +module T14112 where + +pattern MyJust1 a = Just !a diff --git a/testsuite/tests/patsyn/should_fail/T14112.stderr b/testsuite/tests/patsyn/should_fail/T14112.stderr new file mode 100644 index 0000000000..bd0b9543af --- /dev/null +++ b/testsuite/tests/patsyn/should_fail/T14112.stderr @@ -0,0 +1,7 @@ + +T14112.hs:5:21: error: + Invalid right-hand side of bidirectional pattern synonym ‘MyJust1’: + Pattern ‘!a’ is not invertible + Suggestion: instead use an explicitly bidirectional pattern synonym, e.g. + pattern MyJust1 a <- Just !a where MyJust1 a = ... + RHS pattern: Just !a diff --git a/testsuite/tests/patsyn/should_fail/all.T b/testsuite/tests/patsyn/should_fail/all.T index 92989cf060..8a098d9d1f 100644 --- a/testsuite/tests/patsyn/should_fail/all.T +++ b/testsuite/tests/patsyn/should_fail/all.T @@ -36,4 +36,5 @@ test('T12819', normal, compile_fail, ['']) test('UnliftedPSBind', normal, compile_fail, ['']) test('T13349', normal, compile_fail, ['']) test('T13470', normal, compile_fail, ['']) +test('T14112', normal, compile_fail, ['']) test('T14114', normal, compile_fail, ['']) diff --git a/testsuite/tests/patsyn/should_fail/unidir.stderr b/testsuite/tests/patsyn/should_fail/unidir.stderr index 39193dffd1..ba3799d201 100644 --- a/testsuite/tests/patsyn/should_fail/unidir.stderr +++ b/testsuite/tests/patsyn/should_fail/unidir.stderr @@ -1,5 +1,7 @@ unidir.hs:4:18: error: Invalid right-hand side of bidirectional pattern synonym ‘Head’: - pattern ‘_’ is not invertible + Pattern ‘_’ is not invertible + Suggestion: instead use an explicitly bidirectional pattern synonym, e.g. + pattern Head x <- x : _ where Head x = ... RHS pattern: x : _ |