From a3ef05f4970db808dc61b506b5ff12581c83ac8b Mon Sep 17 00:00:00 2001
From: Brian Hempel <bnhempel@mtu.edu>
Date: Mon, 22 Aug 2016 18:57:33 -0500
Subject: [PATCH] Speed up exhaustiveness checker.
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

Results in 5x faster builds on our app.

Successive patterns on data constructors like tuples can cause the list
of unhandled patterns to grow exponentially.

This commit de-duplicates entries in the unhandled patterns list. This
tames the exponential growth considerably.

The proper solution is to create a real union type for nitpicking
patterns. There’s still quite a bit of speed improvement available.

Build times (app: Sketch-n-Sketch):

Elm 0.16:                                  2:32.4
Elm 0.16 with this commit:                 0:27.8
Elm 0.16 with no exhaustiveness checking:  0:11.3
---
 src/Nitpick/Pattern.hs         |  2 +-
 src/Nitpick/PatternMatches.hs  | 23 ++++++++++++-----------
 src/Reporting/Error/Pattern.hs |  7 ++++---
 3 files changed, 17 insertions(+), 15 deletions(-)

diff --git a/src/Nitpick/Pattern.hs b/src/Nitpick/Pattern.hs
index a66bb5b44..27f05f883 100644
--- a/src/Nitpick/Pattern.hs
+++ b/src/Nitpick/Pattern.hs
@@ -17,7 +17,7 @@ data Pattern
     | Anything
     | Literal L.Literal
     | AnythingBut (Set.Set L.Literal)
-    deriving (Eq)
+    deriving (Eq, Ord)
 
 
 fromCanonicalPattern :: P.Canonical -> Pattern
diff --git a/src/Nitpick/PatternMatches.hs b/src/Nitpick/PatternMatches.hs
index 62cc03132..069d154a9 100644
--- a/src/Nitpick/PatternMatches.hs
+++ b/src/Nitpick/PatternMatches.hs
@@ -209,25 +209,25 @@ checkExpression tagDict (A.A region expression) =
 
 checkPatterns :: TagDict -> Region.Region -> Error.Origin -> [Pattern.Canonical] -> Result wrn ()
 checkPatterns tagDict region origin patterns =
-  checkPatternsHelp tagDict region origin [Anything] patterns
+  checkPatternsHelp tagDict region origin (Set.singleton Anything) patterns
 
 
 checkPatternsHelp
     :: TagDict
     -> Region.Region
     -> Error.Origin
-    -> [Pattern]
+    -> Set.Set Pattern
     -> [Pattern.Canonical]
     -> Result wrn ()
 checkPatternsHelp tagDict region origin unhandled patterns =
-  case (unhandled, patterns) of
-    ([], []) ->
-        return ()
-
-    (_:_, []) ->
-        Result.throw region (Error.Incomplete origin unhandled)
+  case patterns of
+    [] ->
+        if Set.size unhandled == 0 then
+          return ()
+        else
+          Result.throw region (Error.Incomplete origin unhandled)
 
-    (_, pattern@(A.A localRegion _) : remainingPatterns) ->
+    pattern@(A.A localRegion _) : remainingPatterns ->
         do  newUnhandled <- filterPatterns tagDict localRegion pattern unhandled
             checkPatternsHelp tagDict region origin newUnhandled remainingPatterns
 
@@ -236,8 +236,8 @@ filterPatterns
     :: TagDict
     -> Region.Region
     -> Pattern.Canonical
-    -> [Pattern]
-    -> Result wrn [Pattern]
+    -> Set.Set Pattern
+    -> Result wrn (Set.Set Pattern)
 filterPatterns tagDict region pattern unhandled =
   let
     nitPattern =
@@ -252,6 +252,7 @@ filterPatterns tagDict region pattern unhandled =
     else
       do  let complementPatterns = complement tagDict nitPattern
           return $
+            Set.fromList $
             concatMap
               (\p -> Maybe.mapMaybe (intersection p) complementPatterns)
               unhandled
diff --git a/src/Reporting/Error/Pattern.hs b/src/Reporting/Error/Pattern.hs
index 72a583ad2..5e5f37385 100644
--- a/src/Reporting/Error/Pattern.hs
+++ b/src/Reporting/Error/Pattern.hs
@@ -1,6 +1,7 @@
 {-# OPTIONS_GHC -Wall #-}
 module Reporting.Error.Pattern where
 
+import qualified Data.Set as Set
 import Text.PrettyPrint.ANSI.Leijen (text)
 
 import qualified Nitpick.Pattern as Pattern
@@ -11,7 +12,7 @@ import qualified Reporting.Report as Report
 
 
 data Error
-    = Incomplete Origin [Pattern.Pattern]
+    = Incomplete Origin (Set.Set Pattern.Pattern)
     | Redundant
 
 
@@ -57,11 +58,11 @@ toReport _localizer err =
           (text "Any value with this shape will be handled by a previous pattern.")
 
 
-unhandledError :: [Pattern.Pattern] -> String -> String
+unhandledError :: Set.Set Pattern.Pattern -> String -> String
 unhandledError unhandledPatterns relevantMessage =
   let
     (visiblePatterns, rest) =
-      splitAt 4 unhandledPatterns
+        splitAt 4 (Set.toList unhandledPatterns)
 
     patternList =
         map (Pattern.toString False) visiblePatterns