[commit: ghc] wip/gadtpm: Avoid generating guards for CoPats if possible (Addresses #11276) (42c5a13)
git at git.haskell.org
git at git.haskell.org
Sun Jan 3 22:17:39 UTC 2016
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/gadtpm
Link : http://ghc.haskell.org/trac/ghc/changeset/42c5a13d6c66ab2cf1133a103f192bf7c2c68efa/ghc
>---------------------------------------------------------------
commit 42c5a13d6c66ab2cf1133a103f192bf7c2c68efa
Author: George Karachalias <george.karachalias at gmail.com>
Date: Sun Jan 3 23:18:05 2016 +0100
Avoid generating guards for CoPats if possible (Addresses #11276)
>---------------------------------------------------------------
42c5a13d6c66ab2cf1133a103f192bf7c2c68efa
compiler/deSugar/Check.hs | 29 +++++-
testsuite/tests/pmcheck/should_compile/T11276.hs | 105 +++++++++++++++++++++
.../tests/pmcheck/should_compile/T11276.stderr | 0
testsuite/tests/pmcheck/should_compile/all.T | 1 +
4 files changed, 130 insertions(+), 5 deletions(-)
diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs
index fd0c6e0..5d8a171 100644
--- a/compiler/deSugar/Check.hs
+++ b/compiler/deSugar/Check.hs
@@ -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
diff --git a/testsuite/tests/pmcheck/should_compile/T11276.hs b/testsuite/tests/pmcheck/should_compile/T11276.hs
new file mode 100644
index 0000000..16e0155
--- /dev/null
+++ b/testsuite/tests/pmcheck/should_compile/T11276.hs
@@ -0,0 +1,105 @@
+{-# 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
diff --git a/libraries/base/tests/IO/misc001.stdout b/testsuite/tests/pmcheck/should_compile/T11276.stderr
similarity index 100%
copy from libraries/base/tests/IO/misc001.stdout
copy to testsuite/tests/pmcheck/should_compile/T11276.stderr
diff --git a/testsuite/tests/pmcheck/should_compile/all.T b/testsuite/tests/pmcheck/should_compile/all.T
index 292e9af..1f487ee 100644
--- a/testsuite/tests/pmcheck/should_compile/all.T
+++ b/testsuite/tests/pmcheck/should_compile/all.T
@@ -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', normal, compile, ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
# Other tests
test('pmc001', only_compiler_types(['ghc']), compile, ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
More information about the ghc-commits
mailing list