[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