Overhaul the Overhauled Pattern Match Checker

Overhaul the Overhauled Pattern Match Checker

* Changed the representation of Value Set Abstractions. Instead of
using a prefix tree, we now use a list of Value Vector Abstractions.
The set of constraints Delta for every Value Vector Abstraction is the
oracle state so that we solve everything only once.

* Instead of doing everything lazily, we prune at once (and in general
everything is much stricter). Hence, an example written with pattern
guards is checked in almost the same time as the equivalent with
pattern matching.

* Do not store the covered and the divergent sets at all. Since what we
only need is a yes/no (does this clause cover anything? Does it force
any thunk?) We just keep a boolean for each.

* Removed flags `-Wtoo-many-guards` and `-ffull-guard-reasoning`.
Replaced with `fmax-pmcheck-iterations=n`. Still debatable what should
the default `n` be.

* When a guard is for sure not going to contribute anything, we treat
it as such: The oracle is not called and cases `CGuard`, `UGuard` and
`DGuard` from the paper are not happening at all (the generation of a
fresh variable, the unfolding of the pattern list etc.). his combined
with the above seems to be enough to drop the memory increase for test
T783 down to 18.7%.

* Do not export function `dsPmWarn` (it is now called directly from
within `checkSingle` and `checkMatches`).

* Make `PmExprVar` hold a `Name` instead of an `Id`. The term oracle
does not handle type information so using `Id` was a waste of
time/space.

* Added testcases T11195, T11303b (data families) and T11374

The patch addresses at least the following:
Trac #11195, #11276, #11303, #11374, #11162

Test Plan: validate

Reviewers: goldfire, bgamari, hvr, austin

Subscribers: simonpj, thomie

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

8 files changed, 294 insertions, 18 deletions

diff --git a/testsuite/tests/pmcheck/should_compile/T11195.hs b/testsuite/tests/pmcheck/should_compile/T11195.hs
new file mode 100644
index 0000000000..593223f5fc
--- /dev/null
+++ b/testsuite/tests/pmcheck/should_compile/T11195.hs
@@ -0,0 +1,189 @@
+{-# OPTIONS_GHC -Woverlapping-patterns -Wincomplete-patterns #-}
+
+module T11195 where
+
+import TyCoRep
+import Coercion
+import Type hiding( substTyVarBndr, substTy, extendTCvSubst )
+import TcType       ( exactTyCoVarsOfType )
+import CoAxiom
+import VarSet
+import VarEnv
+import Pair
+import InstEnv
+
+type NormalCo    = Coercion
+type NormalNonIdCo = NormalCo  -- Extra invariant: not the identity
+type SymFlag = Bool
+type ReprFlag = Bool
+
+chooseRole :: ReprFlag -> Role -> Role
+chooseRole = undefined
+
+wrapRole :: ReprFlag -> Role -> Coercion -> Coercion
+wrapRole = undefined
+
+wrapSym :: SymFlag -> Coercion -> Coercion
+wrapSym = undefined
+
+optForAllCoBndr :: LiftingContext -> Bool
+                -> TyVar -> Coercion -> (LiftingContext, TyVar, Coercion)
+optForAllCoBndr = undefined
+
+opt_trans :: InScopeSet -> NormalCo -> NormalCo -> NormalCo
+opt_trans = undefined
+
+opt_univ :: LiftingContext -> SymFlag -> UnivCoProvenance -> Role
+         -> Type -> Type -> Coercion
+opt_univ = undefined
+
+opt_co3 :: LiftingContext -> SymFlag -> Maybe Role
+        -> Role -> Coercion -> NormalCo
+opt_co3 = undefined
+
+opt_co2 :: LiftingContext -> SymFlag -> Role -> Coercion -> NormalCo
+opt_co2 = undefined
+
+compatible_co :: Coercion -> Coercion -> Bool
+compatible_co = undefined
+
+etaTyConAppCo_maybe = undefined
+etaAppCo_maybe = undefined
+etaForAllCo_maybe = undefined
+
+matchAxiom = undefined
+checkAxInstCo = undefined
+isAxiom_maybe = undefined
+isCohLeft_maybe = undefined
+isCohRight_maybe = undefined
+
+opt_transList :: InScopeSet -> [NormalCo] -> [NormalCo] -> [NormalCo]
+opt_transList is = zipWith (opt_trans is)
+
+opt_trans_rule :: InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> Maybe NormalCo
+opt_trans_rule is in_co1@(NthCo d1 co1) in_co2@(NthCo d2 co2)
+  | d1 == d2
+  , co1 `compatible_co` co2 = undefined
+
+opt_trans_rule is in_co1@(LRCo d1 co1) in_co2@(LRCo d2 co2)
+  | d1 == d2
+  , co1 `compatible_co` co2 = undefined
+
+-- Push transitivity inside instantiation
+opt_trans_rule is in_co1@(InstCo co1 ty1) in_co2@(InstCo co2 ty2)
+  | ty1 `eqCoercion` ty2
+  , co1 `compatible_co` co2 = undefined
+
+opt_trans_rule is in_co1@(UnivCo p1 r1 tyl1 _tyr1)
+                  in_co2@(UnivCo p2 r2 _tyl2 tyr2)
+  | Just prov' <- opt_trans_prov p1 p2 = undefined
+  where
+    -- if the provenances are different, opt'ing will be very confusing
+    opt_trans_prov UnsafeCoerceProv UnsafeCoerceProv
+      = Just UnsafeCoerceProv
+    opt_trans_prov (PhantomProv kco1) (PhantomProv kco2)
+      = Just $ PhantomProv $ opt_trans is kco1 kco2
+    opt_trans_prov (ProofIrrelProv kco1) (ProofIrrelProv kco2)
+      = Just $ ProofIrrelProv $ opt_trans is kco1 kco2
+    opt_trans_prov (PluginProv str1) (PluginProv str2)
+      | str1 == str2 = Just p1
+    opt_trans_prov _ _ = Nothing
+
+-- Push transitivity down through matching top-level constructors.
+opt_trans_rule is in_co1@(TyConAppCo r1 tc1 cos1)
+                  in_co2@(TyConAppCo r2 tc2 cos2)
+  | tc1 == tc2 = undefined
+
+opt_trans_rule is in_co1@(AppCo co1a co1b) in_co2@(AppCo co2a co2b)
+  = undefined
+
+-- Eta rules
+opt_trans_rule is co1@(TyConAppCo r tc cos1) co2
+  | Just cos2 <- etaTyConAppCo_maybe tc co2 = undefined
+
+opt_trans_rule is co1 co2@(TyConAppCo r tc cos2)
+  | Just cos1 <- etaTyConAppCo_maybe tc co1 = undefined
+
+opt_trans_rule is co1@(AppCo co1a co1b) co2
+  | Just (co2a,co2b) <- etaAppCo_maybe co2 = undefined
+
+opt_trans_rule is co1 co2@(AppCo co2a co2b)
+  | Just (co1a,co1b) <- etaAppCo_maybe co1 = undefined
+
+-- Push transitivity inside forall
+opt_trans_rule is co1 co2
+  | ForAllCo tv1 eta1 r1 <- co1
+  , Just (tv2,eta2,r2) <- etaForAllCo_maybe co2 = undefined
+
+  | ForAllCo tv2 eta2 r2 <- co2
+  , Just (tv1,eta1,r1) <- etaForAllCo_maybe co1 = undefined
+
+  where
+  push_trans tv1 eta1 r1 tv2 eta2 r2 = undefined
+
+-- Push transitivity inside axioms
+opt_trans_rule is co1 co2
+  | Just (sym, con, ind, cos1) <- co1_is_axiom_maybe
+  , True <- sym
+  , Just cos2 <- matchAxiom sym con ind co2
+  , let newAxInst = AxiomInstCo con ind
+                      (opt_transList is (map mkSymCo cos2) cos1)
+  , Nothing <- checkAxInstCo newAxInst
+  = undefined
+
+  -- TrPushAxR
+  | Just (sym, con, ind, cos1) <- co1_is_axiom_maybe
+  , False <- sym
+  , Just cos2 <- matchAxiom sym con ind co2
+  , let newAxInst = AxiomInstCo con ind (opt_transList is cos1 cos2)
+  , Nothing <- checkAxInstCo newAxInst
+  = undefined
+
+  -- TrPushSymAxL
+  | Just (sym, con, ind, cos2) <- co2_is_axiom_maybe
+  , True <- sym
+  , Just cos1 <- matchAxiom (not sym) con ind co1
+  , let newAxInst = AxiomInstCo con ind
+                      (opt_transList is cos2 (map mkSymCo cos1))
+  , Nothing <- checkAxInstCo newAxInst
+  = undefined
+
+  -- TrPushAxL
+  | Just (sym, con, ind, cos2) <- co2_is_axiom_maybe
+  , False <- sym
+  , Just cos1 <- matchAxiom (not sym) con ind co1
+  , let newAxInst = AxiomInstCo con ind (opt_transList is cos1 cos2)
+  , Nothing <- checkAxInstCo newAxInst
+  = undefined
+
+  -- TrPushAxSym/TrPushSymAx
+  | Just (sym1, con1, ind1, cos1) <- co1_is_axiom_maybe
+  , Just (sym2, con2, ind2, cos2) <- co2_is_axiom_maybe
+  , con1 == con2
+  , ind1 == ind2
+  , sym1 == not sym2
+  , let branch = coAxiomNthBranch con1 ind1
+        qtvs = coAxBranchTyVars branch ++ coAxBranchCoVars branch
+        lhs  = coAxNthLHS con1 ind1
+        rhs  = coAxBranchRHS branch
+        pivot_tvs = exactTyCoVarsOfType (if sym2 then rhs else lhs)
+  , all (`elemVarSet` pivot_tvs) qtvs
+  = undefined
+  where
+    co1_is_axiom_maybe = isAxiom_maybe co1
+    co2_is_axiom_maybe = isAxiom_maybe co2
+    role = coercionRole co1 -- should be the same as coercionRole co2!
+
+opt_trans_rule is co1 co2
+  | Just (lco, lh) <- isCohRight_maybe co1
+  , Just (rco, rh) <- isCohLeft_maybe co2
+  , (coercionType lh) `eqType` (coercionType rh)
+  = undefined
+
+opt_trans_rule _ co1 co2        -- Identity rule
+  | (Pair ty1 _, r) <- coercionKindRole co1
+  , Pair _ ty2 <- coercionKind co2
+  , ty1 `eqType` ty2
+  = undefined
+
+opt_trans_rule _ _ _ = Nothing
diff --git a/testsuite/tests/pmcheck/should_compile/T11303b.hs b/testsuite/tests/pmcheck/should_compile/T11303b.hs
new file mode 100644
index 0000000000..f8c4917477
--- /dev/null
+++ b/testsuite/tests/pmcheck/should_compile/T11303b.hs
@@ -0,0 +1,25 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -Wincomplete-patterns -Woverlapping-patterns #-}
+
+module T11303b where
+
+data family Letter a
+
+data instance Letter a = A | B | C | D | E | F | G | H | I | J
+
+f :: [Letter a] -> Int
+f = foldl go 0
+  where
+    go n letter = n + n'
+      where
+        n' = case letter of
+                  A -> 0
+                  B -> 1
+                  C -> 2
+                  D -> 3
+                  E -> 4
+                  F -> 5
+                  G -> 6
+                  H -> 7
+                  I -> 8
+                  J -> 9
diff --git a/testsuite/tests/pmcheck/should_compile/T11374.hs b/testsuite/tests/pmcheck/should_compile/T11374.hs
new file mode 100644
index 0000000000..e68fbc88e9
--- /dev/null
+++ b/testsuite/tests/pmcheck/should_compile/T11374.hs
@@ -0,0 +1,59 @@
+{-# LANGUAGE Haskell2010 #-}
+{-# OPTIONS_GHC -Woverlapping-patterns -Wincomplete-patterns #-}
+
+module T11374 where
+
+data Type   = TCon TCon [Type]
+            | TUser String [Type] Type
+            | TRec [(String,Type)]
+            deriving (Show,Eq,Ord)
+
+data TCon   = TC TC
+            | TF TFun
+            deriving (Show,Eq,Ord)
+
+data TC     = TCNum Integer
+            | TCInf
+            | TCBit
+            | TCSeq
+            | TCFun
+            | TCTuple Int
+            deriving (Show,Eq,Ord)
+
+data TFun   = TCAdd
+            | TCSub
+            | TCMul
+            | TCDiv
+            | TCMod
+            | TCLg2
+            | TCExp
+            | TCWidth
+            | TCMin
+            | TCMax
+            | TCLenFromThen
+            | TCLenFromThenTo
+            deriving (Show, Eq, Ord, Bounded, Enum)
+
+simpFinTy :: Type -> Maybe [Type]
+simpFinTy ty = case ty of
+    TCon (TC (TCNum _)) _ -> Just []
+
+    TCon (TF tf) [t1]
+      | TCLg2    <- tf -> Just [t1]
+      | TCWidth  <- tf -> Just [t1]
+
+    TCon (TF tf) [t1,t2]
+      | TCAdd <- tf -> Just [t1, t2]
+      | TCSub <- tf -> Just [t1]
+      | TCMul <- tf -> Just [t1, t2]
+      | TCDiv <- tf -> Just [t1]
+      | TCMod <- tf -> Just []
+      | TCExp <- tf -> Just [t1, t2]
+      | TCMin <- tf -> Nothing
+      | TCMax <- tf -> Just [t1, t2]
+
+    TCon (TF tf) [_,_,_]
+      | TCLenFromThen   <- tf -> Just []
+      | TCLenFromThenTo <- tf -> Just []
+
+    _ -> Nothing
diff --git a/testsuite/tests/pmcheck/should_compile/T2204.stderr b/testsuite/tests/pmcheck/should_compile/T2204.stderr
index e6ad7cf9ae..d2e6e0a434 100644
--- a/testsuite/tests/pmcheck/should_compile/T2204.stderr
+++ b/testsuite/tests/pmcheck/should_compile/T2204.stderr
@@ -2,10 +2,10 @@ T2204.hs:6:1: warning:
     Pattern match(es) are non-exhaustive
     In an equation for ‘f’:
         Patterns not matched:
-            ('0':'1':_:_)
-            ('0':p:_) where p is not one of {'1'}
-            ['0']
+            []
             (p:_) where p is not one of {'0'}
+            ['0']
+            ('0':p:_) where p is not one of {'1'}
             ...
 
 T2204.hs:9:1: warning:
diff --git a/testsuite/tests/pmcheck/should_compile/T9951b.stderr b/testsuite/tests/pmcheck/should_compile/T9951b.stderr
index 6a9d0ce112..b998ce225b 100644
--- a/testsuite/tests/pmcheck/should_compile/T9951b.stderr
+++ b/testsuite/tests/pmcheck/should_compile/T9951b.stderr
@@ -2,8 +2,8 @@ T9951b.hs:7:1: warning:
     Pattern match(es) are non-exhaustive
     In an equation for ‘f’:
         Patterns not matched:
-            ('a':'b':_:_)
-            ('a':p:_) where p is not one of {'b'}
-            ['a']
+            []
             (p:_) where p is not one of {'a'}
+            ['a']
+            ('a':p:_) where p is not one of {'b'}
             ...
diff --git a/testsuite/tests/pmcheck/should_compile/all.T b/testsuite/tests/pmcheck/should_compile/all.T
index 521c221e1b..84c2d610f4 100644
--- a/testsuite/tests/pmcheck/should_compile/all.T
+++ b/testsuite/tests/pmcheck/should_compile/all.T
@@ -24,6 +24,9 @@ test('T9951b',only_compiler_types(['ghc']), compile, ['-fwarn-incomplete-pattern
 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'])
+test('T11303b', compile_timeout_multiplier(0.01), compile, ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns +RTS -M1G -RTS'])
+test('T11374', compile_timeout_multiplier(0.01), compile, ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns +RTS -M1G -RTS'])
+test('T11195', compile_timeout_multiplier(0.40), compile, ['-package ghc -fwarn-incomplete-patterns -fwarn-overlapping-patterns +RTS -M1G -RTS'])
 
 # Other tests
 test('pmc001', only_compiler_types(['ghc']), compile, ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
diff --git a/testsuite/tests/pmcheck/should_compile/pmc001.stderr b/testsuite/tests/pmcheck/should_compile/pmc001.stderr
index c6145432f0..eb0bd4bc56 100644
--- a/testsuite/tests/pmcheck/should_compile/pmc001.stderr
+++ b/testsuite/tests/pmcheck/should_compile/pmc001.stderr
@@ -2,16 +2,16 @@ pmc001.hs:14:1: warning:
     Pattern match(es) are non-exhaustive
     In an equation for ‘f’:
         Patterns not matched:
-            MkT3 (MkT2 _)
-            MkT3 MkT1
-            (MkT2 _) MkT3
             MkT1 MkT3
+            (MkT2 _) MkT3
+            MkT3 MkT1
+            MkT3 (MkT2 _)
 
 pmc001.hs:19:1: warning:
     Pattern match(es) are non-exhaustive
     In an equation for ‘g’:
         Patterns not matched:
-            MkT3 (MkT2 _)
-            MkT3 MkT1
-            (MkT2 _) MkT3
             MkT1 MkT3
+            (MkT2 _) MkT3
+            MkT3 MkT1
+            MkT3 (MkT2 _)
diff --git a/testsuite/tests/pmcheck/should_compile/pmc007.stderr b/testsuite/tests/pmcheck/should_compile/pmc007.stderr
index bb011be5aa..291fbdcde2 100644
--- a/testsuite/tests/pmcheck/should_compile/pmc007.stderr
+++ b/testsuite/tests/pmcheck/should_compile/pmc007.stderr
@@ -7,18 +7,18 @@ pmc007.hs:12:1: warning:
     Pattern match(es) are non-exhaustive
     In an equation for ‘g’:
         Patterns not matched:
-            ('a':'b':_:_)
-            ('a':'c':_:_)
-            ('a':p:_) where p is not one of {'c', 'b'}
+            []
+            (p:_) where p is not one of {'a'}
             ['a']
+            ('a':p:_) where p is not one of {'c', 'b'}
             ...
 
 pmc007.hs:18:11: warning:
     Pattern match(es) are non-exhaustive
     In a case alternative:
         Patterns not matched:
-            ('a':'b':_:_)
-            ('a':'c':_:_)
-            ('a':p:_) where p is not one of {'c', 'b'}
+            []
+            (p:_) where p is not one of {'a'}
             ['a']
+            ('a':p:_) where p is not one of {'c', 'b'}
             ...