Commit 0acdcf24 authored by Georgios Karachalias's avatar Georgios Karachalias Committed by Ben Gamari

Avoid generating guards for CoPats if possible (Addresses #11276)

When translating a `CoPat` to `PmPat` check whether the wrapper
is just a hole or a cast with refl. In these cases we can safely
drop the wrapper and generate less guard patterns. Fixes T11276.

Test Plan: validate

Reviewers: bgamari, austin

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D1729

GHC Trac Issues: #11276
parent 4c56ad36
......@@ -52,6 +52,8 @@ import DsGRHSs -- isTrueLHsExpr
import Data.List -- find
import Data.Maybe -- isNothing, isJust, fromJust
import Control.Monad -- liftM3, forM
import Coercion
import TcEvidence
{-
This module checks pattern matches for:
......@@ -281,11 +283,15 @@ translatePat pat = case pat of
SigPatOut p _ty -> translatePat (unLoc p)
CoPat wrapper p ty -> do
ps <- translatePat p
(xp,xe) <- mkPmId2FormsSM ty
let g = mkGuard ps (HsWrap wrapper (unLoc xe))
return [xp,g]
-- See Note [Translate CoPats]
CoPat wrapper p ty
| isIdHsWrapper wrapper -> translatePat p
| WpCast co <- wrapper, isReflexiveCo co -> translatePat p
| otherwise -> do
ps <- translatePat p
(xp,xe) <- mkPmId2FormsSM ty
let g = mkGuard ps (HsWrap wrapper (unLoc xe))
return [xp,g]
-- (n + k) ===> x (True <- x >= k) (n <- x-k)
NPlusKPat (L _ n) k ge minus -> do
......@@ -616,6 +622,19 @@ Additionally, top-level guard translation (performed by @translateGuards@)
replaces guards that cannot be reasoned about (like the ones we described in
1-4) with a single @fake_pat@ to record the possibility of failure to match.
Note [Translate CoPats]
~~~~~~~~~~~~~~~~~~~~~~~
The pattern match checker did not know how to handle coerced patterns `CoPat`
efficiently, which gave rise to #11276. The original approach translated
`CoPat`s:
pat |> co ===> x (pat <- (e |> co))
Instead, we now check whether the coercion is a hole or if it is just refl, in
which case we can drop it. Unfortunately, data families generate useful
coercions so guards are still generated in these cases and checking data
families is not really efficient.
%************************************************************************
%* *
Main Pattern Matching Check
......
{-# LANGUAGE RankNTypes #-}
module Hang where
import Control.Monad
import Data.Char
data Event
= EventBeginDocument
| EventEndDocument
| EventBeginDoctype
| EventEndDoctype
| EventInstruction
| EventBeginElement
| EventEndElement
| EventContent Content
| EventComment
| EventCDATA
data Content
= ContentText String
| ContentEntity String
peek :: Monad m => Consumer a m (Maybe a)
peek = undefined
type Consumer i m r = forall o. ConduitM i o m r
tag :: forall m a b c o . Monad m =>
ConduitM Event o m (Maybe c)
tag = do
_ <- dropWS
return undefined
where
-- Add this and it works
-- dropWS :: Monad m => ConduitM Event o m (Maybe Event)
dropWS = do
-- Swap these two lines and it works
-- let x = undefined
x <- peek
let isWS =
case x of
-- Remove some of these and it works
Just EventBeginDocument -> True
Just EventEndDocument -> True
Just EventBeginDoctype{} -> True
Just EventEndDoctype -> True
Just EventInstruction{} -> True
Just EventBeginElement{} -> False
Just EventEndElement{} -> False
Just (EventContent (ContentText t))
| all isSpace t -> True
| otherwise -> False
Just (EventContent ContentEntity{}) -> False
Just EventComment{} -> True
Just EventCDATA{} -> False
Nothing -> False
if isWS then dropWS else return x
-- Inlined Instances
instance Functor (ConduitM i o m) where
fmap f (ConduitM c) = ConduitM $ \rest -> c (rest . f)
instance Applicative (ConduitM i o m) where
pure x = ConduitM ($ x)
{-# INLINE pure #-}
(<*>) = ap
{-# INLINE (<*>) #-}
instance Monad (ConduitM i o m) where
return = pure
ConduitM f >>= g = ConduitM $ \h -> f $ \a -> unConduitM (g a) h
instance Monad m => Functor (Pipe l i o u m) where
fmap = liftM
{-# INLINE fmap #-}
instance Monad m => Applicative (Pipe l i o u m) where
pure = Done
{-# INLINE pure #-}
(<*>) = ap
{-# INLINE (<*>) #-}
instance Monad m => Monad (Pipe l i o u m) where
return = pure
{-# INLINE return #-}
HaveOutput p c o >>= fp = HaveOutput (p >>= fp) c o
NeedInput p c >>= fp = NeedInput (p >=> fp) (c >=> fp)
Done x >>= fp = fp x
PipeM mp >>= fp = PipeM ((>>= fp) `liftM` mp)
Leftover p i >>= fp = Leftover (p >>= fp) i
newtype ConduitM i o m r = ConduitM
{ unConduitM :: forall b.
(r -> Pipe i i o () m b) -> Pipe i i o () m b
}
data Pipe l i o u m r =
HaveOutput (Pipe l i o u m r) (m ()) o
| NeedInput (i -> Pipe l i o u m r) (u -> Pipe l i o u m r)
| Done r
| PipeM (m (Pipe l i o u m r))
| Leftover (Pipe l i o u m r) l
......@@ -23,6 +23,7 @@ test('T8970', only_compiler_types(['ghc']), compile, ['-fwarn-incomplete-pattern
test('T9951b',only_compiler_types(['ghc']), compile, ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
test('T9951', only_compiler_types(['ghc']), compile, ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
test('T11303', normal, compile, ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns +RTS -M1G -RTS'])
test('T11276', compile_timeout_multiplier(0.01), compile, ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns +RTS -M1G -RTS'])
# Other tests
test('pmc001', only_compiler_types(['ghc']), compile, ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
......
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