Fix GHC's incomplete-uni-patterns warnings (#1175)

Add explicit errors for unexpected cases. Note

* For the IntMap changes, the error case gets removed completely after
  inlining and case-of-case optimization.
* For Sequence, the let has become a case, but there is no change in
  strictness since the result is strict in the matched value anyway.
  Unlike IntMap above, the error case remains (but, of course, is never
  executed as long as the implementation is correct).

Author: meooow25

containers/src/Data/IntMap/Internal.hs

@@ -11,7 +11,6 @@
 #endif
 
 {-# OPTIONS_HADDOCK not-home #-}
-{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
 
 #include "containers.h"
 
@@ -1227,7 +1226,10 @@ unionWith f m1 m2
 
 unionWithKey :: (Key -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
 unionWithKey f m1 m2
-  = mergeWithKey' Bin (\(Tip k1 x1) (Tip _k2 x2) -> Tip k1 (f k1 x1 x2)) id id m1 m2
+  = mergeWithKey' Bin f' id id m1 m2
+  where
+    f' (Tip k1 x1) (Tip _k2 x2) = Tip k1 (f k1 x1 x2)
+    f' _ _ = error "not Tip"
 
 {--------------------------------------------------------------------
   Difference
@@ -1401,7 +1403,10 @@ intersectionWith f m1 m2
 
 intersectionWithKey :: (Key -> a -> b -> c) -> IntMap a -> IntMap b -> IntMap c
 intersectionWithKey f m1 m2
-  = mergeWithKey' bin (\(Tip k1 x1) (Tip _k2 x2) -> Tip k1 (f k1 x1 x2)) (const Nil) (const Nil) m1 m2
+  = mergeWithKey' bin f' (const Nil) (const Nil) m1 m2
+  where
+    f' (Tip k1 x1) (Tip _k2 x2) = Tip k1 (f k1 x1 x2)
+    f' _ _ = error "not Tip"
 
 {--------------------------------------------------------------------
   Symmetric difference
@@ -1492,11 +1497,12 @@ symDiffTip !t1 !k1 = go
 mergeWithKey :: (Key -> a -> b -> Maybe c) -> (IntMap a -> IntMap c) -> (IntMap b -> IntMap c)
              -> IntMap a -> IntMap b -> IntMap c
 mergeWithKey f g1 g2 = mergeWithKey' bin combine g1 g2
-  where -- We use the lambda form to avoid non-exhaustive pattern matches warning.
-        combine = \(Tip k1 x1) (Tip _k2 x2) ->
+  where
+        combine (Tip k1 x1) (Tip _k2 x2) =
           case f k1 x1 x2 of
             Nothing -> Nil
             Just x -> Tip k1 x
+        combine _ _ = error "not Tip"
         {-# INLINE combine #-}
 {-# INLINE mergeWithKey #-}
 

containers/src/Data/IntMap/Strict/Internal.hs

@@ -2,8 +2,6 @@
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE PatternGuards #-}
 
-{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
-
 #include "containers.h"
 
 -----------------------------------------------------------------------------
@@ -665,7 +663,10 @@ unionWith f m1 m2
 
 unionWithKey :: (Key -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
 unionWithKey f m1 m2
-  = mergeWithKey' Bin (\(Tip k1 x1) (Tip _k2 x2) -> Tip k1 $! f k1 x1 x2) id id m1 m2
+  = mergeWithKey' Bin f' id id m1 m2
+  where
+    f' (Tip k1 x1) (Tip _k2 x2) = Tip k1 $! f k1 x1 x2
+    f' _ _ = error "not Tip"
 
 {--------------------------------------------------------------------
   Difference
@@ -717,7 +718,10 @@ intersectionWith f m1 m2
 
 intersectionWithKey :: (Key -> a -> b -> c) -> IntMap a -> IntMap b -> IntMap c
 intersectionWithKey f m1 m2
-  = mergeWithKey' bin (\(Tip k1 x1) (Tip _k2 x2) -> Tip k1 $! f k1 x1 x2) (const Nil) (const Nil) m1 m2
+  = mergeWithKey' bin f' (const Nil) (const Nil) m1 m2
+  where
+    f' (Tip k1 x1) (Tip _k2 x2) = Tip k1 $! f k1 x1 x2
+    f' _ _ = error "not Tip"
 
 {--------------------------------------------------------------------
   MergeWithKey
@@ -763,9 +767,11 @@ intersectionWithKey f m1 m2
 mergeWithKey :: (Key -> a -> b -> Maybe c) -> (IntMap a -> IntMap c) -> (IntMap b -> IntMap c)
              -> IntMap a -> IntMap b -> IntMap c
 mergeWithKey f g1 g2 = mergeWithKey' bin combine g1 g2
-  where -- We use the lambda form to avoid non-exhaustive pattern matches warning.
-        combine = \(Tip k1 x1) (Tip _k2 x2) -> case f k1 x1 x2 of Nothing -> Nil
-                                                                  Just !x -> Tip k1 x
+  where
+        combine (Tip k1 x1) (Tip _k2 x2) = case f k1 x1 x2 of
+          Nothing -> Nil
+          Just !x -> Tip k1 x
+        combine _ _ = error "not Tip"
         {-# INLINE combine #-}
 {-# INLINE mergeWithKey #-}
 

containers/src/Data/Sequence/Internal.hs

@@ -21,7 +21,6 @@
 {-# LANGUAGE PatternGuards #-}
 
 {-# OPTIONS_HADDOCK not-home #-}
-{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
 
 -----------------------------------------------------------------------------
 -- |
@@ -4082,8 +4081,10 @@ tailsTree f (Deep n pr m sf) =
         (tailsTree f' m)
         (fmap (f . digitToTree) (tailsDigit sf))
   where
-    f' ms = let ConsLTree node m' = viewLTree ms in
+    f' ms = case viewLTree ms of
+      ConsLTree node m' ->
         fmap (\ pr' -> f (deep pr' m' sf)) (tailsNode node)
+      EmptyLTree -> error "EmptyLTree"
 
 {-# SPECIALIZE initsTree :: (FingerTree (Elem a) -> Elem b) -> FingerTree (Elem a) -> FingerTree (Elem b) #-}
 {-# SPECIALIZE initsTree :: (FingerTree (Node a) -> Node b) -> FingerTree (Node a) -> FingerTree (Node b) #-}
@@ -4097,8 +4098,10 @@ initsTree f (Deep n pr m sf) =
         (initsTree f' m)
         (fmap (f . deep pr m) (initsDigit sf))
   where
-    f' ms =  let SnocRTree m' node = viewRTree ms in
+    f' ms = case viewRTree ms of
+      SnocRTree m' node ->
              fmap (\ sf' -> f (deep pr m' sf')) (initsNode node)
+      EmptyRTree -> error "EmptyRTree"
 
 {-# INLINE foldlWithIndex #-}
 -- | 'foldlWithIndex' is a version of 'foldl' that also provides access