Print five exhaustivity checking warnings for each definition instead the whole set.

nicodelpiano · nicodelpiano · commit f73a5ff71505 · 2015-07-18T13:47:31.000-03:00
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
@@ -120,7 +120,7 @@ data SimpleErrorMessage
   | TransitiveExportError DeclarationRef [DeclarationRef]
   | ShadowedName Ident
   | WildcardInferredType Type
-  | NotExhaustivePattern [[Binder]]
+  | NotExhaustivePattern [[Binder]] Bool
   | ClassOperator ProperName Ident
   deriving (Show)
 
@@ -230,7 +230,7 @@ errorCode em = case unwrapErrorMessage em of
   (TransitiveExportError _ _)   -> "TransitiveExportError"
   (ShadowedName _)              -> "ShadowedName"
   (WildcardInferredType _)      -> "WildcardInferredType"
-  (NotExhaustivePattern _)      -> "NotExhaustivePattern"
+  (NotExhaustivePattern _ _)    -> "NotExhaustivePattern"
   (ClassOperator _ _)           -> "ClassOperator"
 
 -- |
@@ -561,11 +561,11 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError
             ]
     goSimple (WildcardInferredType ty) =
       line $ "The wildcard type definition has the inferred type " ++ prettyPrintType ty
-    goSimple (NotExhaustivePattern bs) =
-      paras $ [ line "Pattern could not be determined to cover all cases."
+    goSimple (NotExhaustivePattern bs b) =
+      indent $ paras $ [ line "Pattern could not be determined to cover all cases."
               , line $ "The definition has the following uncovered cases:\n"
-              , indent $ Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs))
-              ]
+              , Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs))
+              ] ++ if not b then [line "..."] else []
     go (NotYetDefined names err) =
       paras [ line $ "The following are not yet defined here: " ++ intercalate ", " (map show names) ++ ":"
             , indent $ go err
diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs
@@ -31,6 +31,7 @@ import Data.Function (on)
 
 import Control.Monad (unless)
 import Control.Applicative
+import Control.Arrow (second)
 import Control.Monad.Writer.Class
 
 import Language.PureScript.AST.Binders
@@ -241,7 +242,7 @@ checkExhaustive env mn cas = makeResult . nub $ foldl' step [initial] cas
   makeResult :: [[Binder]] -> m ()
   makeResult bss = unless (null bss) tellWarning 
     where
-    tellWarning = tell . errorMessage $ NotExhaustivePattern bss
+    tellWarning = tell . errorMessage . uncurry NotExhaustivePattern . second null . splitAt 5 $ bss
 
 -- |
 -- Exhaustivity checking over a list of declarations
