@@ -31,13 +31,13 @@ import Language.PureScript.Kinds
31import Language.PureScript.Types as P
31import Language.PureScript.Types as P
32import Language.PureScript.Errors
32import Language.PureScript.Errors
34−-- | There are two modes of failure for the redudancy check:
34+-- | There are two modes of failure for the redundancy check:
36-- 1. Exhaustivity was incomplete due to too many cases, so we couldn't determine redundancy.
36-- 1. Exhaustivity was incomplete due to too many cases, so we couldn't determine redundancy.
37-- 2. We didn't attempt to determine redundancy for a binder, e.g. an integer binder.
37-- 2. We didn't attempt to determine redundancy for a binder, e.g. an integer binder.
39-- We want to warn the user in the first case.
39-- We want to warn the user in the first case.
40−data RedudancyError = Incomplete | Unknown
40+data RedundancyError = Incomplete | Unknown
43-- Qualifies a propername from a given qualified propername and a default module name
43-- Qualifies a propername from a given qualified propername and a default module name
@@ -106,7 +106,7 @@ genericMerge f bsl@((s, b):bs) bsr@((s', b'):bs')
106-- Find the uncovered set between two binders:
106-- Find the uncovered set between two binders:
107-- the first binder is the case we are trying to cover, the second one is the matching binder
107-- the first binder is the case we are trying to cover, the second one is the matching binder
109−missingCasesSingle :: Environment -> ModuleName -> Binder -> Binder -> ([Binder], Either RedudancyError Bool)
109+missingCasesSingle :: Environment -> ModuleName -> Binder -> Binder -> ([Binder], Either RedundancyError Bool)
110missingCasesSingle _ _ _ NullBinder = ([], return True)
110missingCasesSingle _ _ _ NullBinder = ([], return True)
111missingCasesSingle _ _ _ (VarBinder _) = ([], return True)
111missingCasesSingle _ _ _ (VarBinder _) = ([], return True)
112missingCasesSingle env mn (VarBinder _) b = missingCasesSingle env mn NullBinder b
112missingCasesSingle env mn (VarBinder _) b = missingCasesSingle env mn NullBinder b
@@ -175,7 +175,7 @@ missingCasesSingle _ _ b _ = ([b], Left Unknown)
175-- redundant or not, but uncovered at least. If we use `y` instead, we'll need to have a redundancy checker
175-- redundant or not, but uncovered at least. If we use `y` instead, we'll need to have a redundancy checker
176-- (which ought to be available soon), or increase the complexity of the algorithm.
176-- (which ought to be available soon), or increase the complexity of the algorithm.
178−missingCasesMultiple :: Environment -> ModuleName -> [Binder] -> [Binder] -> ([[Binder]], Either RedudancyError Bool)
178+missingCasesMultiple :: Environment -> ModuleName -> [Binder] -> [Binder] -> ([[Binder]], Either RedundancyError Bool)
179missingCasesMultiple env mn = go
179missingCasesMultiple env mn = go
181 go [] [] = ([], pure True)
181 go [] [] = ([], pure True)
@@ -210,10 +210,10 @@ isExhaustiveGuard (Right _) = True
211-- Returns the uncovered set of case alternatives
211-- Returns the uncovered set of case alternatives
213−missingCases :: Environment -> ModuleName -> [Binder] -> CaseAlternative -> ([[Binder]], Either RedudancyError Bool)
213+missingCases :: Environment -> ModuleName -> [Binder] -> CaseAlternative -> ([[Binder]], Either RedundancyError Bool)
214missingCases env mn uncovered ca = missingCasesMultiple env mn uncovered (caseAlternativeBinders ca)
214missingCases env mn uncovered ca = missingCasesMultiple env mn uncovered (caseAlternativeBinders ca)
216−missingAlternative :: Environment -> ModuleName -> CaseAlternative -> [Binder] -> ([[Binder]], Either RedudancyError Bool)
216+missingAlternative :: Environment -> ModuleName -> CaseAlternative -> [Binder] -> ([[Binder]], Either RedundancyError Bool)
217missingAlternative env mn ca uncovered
217missingAlternative env mn ca uncovered
218 | isExhaustiveGuard (caseAlternativeResult ca) = mcases
218 | isExhaustiveGuard (caseAlternativeResult ca) = mcases
219 | otherwise = ([uncovered], snd mcases)
219 | otherwise = ([uncovered], snd mcases)
@@ -229,13 +229,13 @@ missingAlternative env mn ca uncovered
229checkExhaustive :: forall m. (MonadWriter MultipleErrors m) => Bool -> Environment -> ModuleName -> Int -> [CaseAlternative] -> m ()
229checkExhaustive :: forall m. (MonadWriter MultipleErrors m) => Bool -> Environment -> ModuleName -> Int -> [CaseAlternative] -> m ()
230checkExhaustive hasConstraint env mn numArgs cas = makeResult . first nub $ foldl' step ([initialize numArgs], (pure True, [])) cas
230checkExhaustive hasConstraint env mn numArgs cas = makeResult . first nub $ foldl' step ([initialize numArgs], (pure True, [])) cas
232− step :: ([[Binder]], (Either RedudancyError Bool, [[Binder]])) -> CaseAlternative -> ([[Binder]], (Either RedudancyError Bool, [[Binder]]))
232+ step :: ([[Binder]], (Either RedundancyError Bool, [[Binder]])) -> CaseAlternative -> ([[Binder]], (Either RedundancyError Bool, [[Binder]]))
233 step (uncovered, (nec, redundant)) ca =
233 step (uncovered, (nec, redundant)) ca =
234 let (missed, pr) = unzip (map (missingAlternative env mn ca) uncovered)
234 let (missed, pr) = unzip (map (missingAlternative env mn ca) uncovered)
235 (missed', approx) = splitAt 10000 (nub (concat missed))
235 (missed', approx) = splitAt 10000 (nub (concat missed))
236− cond = liftA2 (&&) (or <$> sequenceA pr) nec
236+ cond = or <$> sequenceA pr
237 in (missed', ( if null approx
237 in (missed', ( if null approx
238− then cond
238+ then liftA2 (&&) cond nec
239 else Left Incomplete
239 else Left Incomplete
240 , if either (const True) id cond
240 , if either (const True) id cond
241 then redundant
241 then redundant
@@ -243,7 +243,7 @@ checkExhaustive hasConstraint env mn numArgs cas = makeResult . first nub $ fold
246− makeResult :: ([[Binder]], (Either RedudancyError Bool, [[Binder]])) -> m ()
246+ makeResult :: ([[Binder]], (Either RedundancyError Bool, [[Binder]])) -> m ()
247 makeResult (bss, (rr, bss')) =
247 makeResult (bss, (rr, bss')) =
248 do unless (hasConstraint || null bss) tellNonExhaustive
248 do unless (hasConstraint || null bss) tellNonExhaustive
249 unless (null bss') tellRedundant
249 unless (null bss') tellRedundant