@@ -29,6 +29,9 @@ import qualified Data.Map as M
2929import Data.Maybe (fromMaybe)
3030import Data.List (foldl', sortBy, nub)
3131import Data.Function (on)
32+#if __GLASGOW_HASKELL__ < 710
33+import Data.Traversable (sequenceA)
34+#endif
3235
3336import Control.Monad (unless)
3437import Control.Applicative
@@ -45,6 +48,14 @@ import Language.PureScript.Errors
4548
4649import Language.PureScript.AST.Traversals (everywhereOnValuesTopDownM)
4750
51+-- | There are two modes of failure for the redudancy check:
52+--
53+-- 1. Exhaustivity was incomeplete due to too many cases, so we couldn't determine redundancy.
54+-- 2. We didn't attempt to determine redundancy for a binder, e.g. an integer binder.
55+--
56+-- We want to warn the user in the first case.
57+data RedudancyError = Incomplete | Unknown
58+
4859-- |
4960-- Qualifies a propername from a given qualified propername and a default module name
5061--
@@ -59,20 +70,20 @@ qualifyName n defmn qn = Qualified (Just mn) n
5970-- where: - ProperName is the name of the constructor (for example, "Nothing" in Maybe)
6071-- - [Type] is the list of arguments, if it has (for example, "Just" has [TypeVar "a"])
6172--
62−getConstructors :: Environment -> ModuleName -> (Qualified ProperName) -> [(ProperName, [Type])]
73+getConstructors :: Environment -> ModuleName -> Qualified ProperName -> [(ProperName, [Type])]
6374getConstructors env defmn n = extractConstructors lnte
6475 where
6576 qpn :: Qualified ProperName
6677 qpn = getConsDataName n
6778
68− getConsDataName :: (Qualified ProperName) -> (Qualified ProperName)
79+ getConsDataName :: Qualified ProperName -> Qualified ProperName
6980 getConsDataName con = qualifyName nm defmn con
7081 where
7182 nm = case getConsInfo con of
7283 Nothing -> error $ "Constructor " ++ showQualified runProperName con ++ " not in the scope of the current environment in getConsDataName."
7384 Just (_, pm, _, _) -> pm
7485
75− getConsInfo :: (Qualified ProperName) -> Maybe (DataDeclType, ProperName, Type, [Ident])
86+ getConsInfo :: Qualified ProperName -> Maybe (DataDeclType, ProperName, Type, [Ident])
7687 getConsInfo con = M.lookup con dce
7788 where
7889 dce :: M.Map (Qualified ProperName) (DataDeclType, ProperName, Type, [Ident])
@@ -103,27 +114,27 @@ genericMerge _ [] [] = []
103114genericMerge f bs [] = map (\(s, b) -> f s (Just b) Nothing) bs
104115genericMerge f [] bs = map (\(s, b) -> f s Nothing (Just b)) bs
105116genericMerge f bsl@((s, b):bs) bsr@((s', b'):bs')
106− | s < s' = (f s (Just b) Nothing) : genericMerge f bs bsr
107− | s > s' = (f s' Nothing (Just b')) : genericMerge f bsl bs'
108− | otherwise = (f s (Just b) (Just b')) : genericMerge f bs bs'
117+ | s < s' = f s (Just b) Nothing : genericMerge f bs bsr
118+ | s > s' = f s' Nothing (Just b') : genericMerge f bsl bs'
119+ | otherwise = f s (Just b) (Just b') : genericMerge f bs bs'
109120
110121-- |
111122-- Find the uncovered set between two binders:
112123-- the first binder is the case we are trying to cover, the second one is the matching binder
113124--
114−missingCasesSingle :: Environment -> ModuleName -> Binder -> Binder -> ([Binder], Maybe Bool)
115−missingCasesSingle _ _ _ NullBinder = ([], Just True)
116−missingCasesSingle _ _ _ (VarBinder _) = ([], Just True)
125+missingCasesSingle :: Environment -> ModuleName -> Binder -> Binder -> ([Binder], Either RedudancyError Bool)
126+missingCasesSingle _ _ _ NullBinder = ([], return True)
127+missingCasesSingle _ _ _ (VarBinder _) = ([], return True)
117128missingCasesSingle env mn (VarBinder _) b = missingCasesSingle env mn NullBinder b
118129missingCasesSingle env mn br (NamedBinder _ bl) = missingCasesSingle env mn br bl
119130missingCasesSingle env mn NullBinder cb@(ConstructorBinder con _) =
120− (concatMap (\cp -> fst $ missingCasesSingle env mn cp cb) allPatterns, Just True)
131+ (concatMap (\cp -> fst $ missingCasesSingle env mn cp cb) allPatterns, return True)
121132 where
122133 allPatterns = map (\(p, t) -> ConstructorBinder (qualifyName p mn con) (initialize $ length t))
123134 $ getConstructors env mn con
124135missingCasesSingle env mn cb@(ConstructorBinder con bs) (ConstructorBinder con' bs')
125136 | con == con' = let (bs'', pr) = missingCasesMultiple env mn bs bs' in (map (ConstructorBinder con) bs'', pr)
126− | otherwise = ([cb], Just False)
137+ | otherwise = ([cb], return False)
127138missingCasesSingle env mn NullBinder (ObjectBinder bs) =
128139 (map (ObjectBinder . zip (map fst bs)) allMisses, pr)
129140 where
@@ -146,12 +157,12 @@ missingCasesSingle env mn (ObjectBinder bs) (ObjectBinder bs') =
146157 compBS e s b b' = (s, compB e b b')
147158
148159 (sortedNames, binders) = unzip $ genericMerge (compBS NullBinder) sbs sbs'
149−missingCasesSingle _ _ NullBinder (BooleanBinder b) = ([BooleanBinder $ not b], Just True)
160+missingCasesSingle _ _ NullBinder (BooleanBinder b) = ([BooleanBinder $ not b], return True)
150161missingCasesSingle _ _ (BooleanBinder bl) (BooleanBinder br)
151− | bl == br = ([], Just True)
152− | otherwise = ([BooleanBinder bl], Just False)
162+ | bl == br = ([], return True)
163+ | otherwise = ([BooleanBinder bl], return False)
153164missingCasesSingle env mn b (PositionedBinder _ _ cb) = missingCasesSingle env mn b cb
154−missingCasesSingle _ _ b _ = ([b], Nothing)
165+missingCasesSingle _ _ b _ = ([b], Left Unknown)
155166
156167-- |
157168-- Returns the uncovered set of binders
@@ -179,7 +190,7 @@ missingCasesSingle _ _ b _ = ([b], Nothing)
179190-- redundant or not, but uncovered at least. If we use `y` instead, we'll need to have a redundancy checker
180191-- (which ought to be available soon), or increase the complexity of the algorithm.
181192--
182−missingCasesMultiple :: Environment -> ModuleName -> [Binder] -> [Binder] -> ([[Binder]], Maybe Bool)
193+missingCasesMultiple :: Environment -> ModuleName -> [Binder] -> [Binder] -> ([[Binder]], Either RedudancyError Bool)
183194missingCasesMultiple env mn = go
184195 where
185196 go [] [] = ([], pure True)
@@ -213,10 +224,10 @@ isExhaustiveGuard (Right _) = True
213224-- |
214225-- Returns the uncovered set of case alternatives
215226--
216−missingCases :: Environment -> ModuleName -> [Binder] -> CaseAlternative -> ([[Binder]], Maybe Bool)
227+missingCases :: Environment -> ModuleName -> [Binder] -> CaseAlternative -> ([[Binder]], Either RedudancyError Bool)
217228missingCases env mn uncovered ca = missingCasesMultiple env mn uncovered (caseAlternativeBinders ca)
218229
219−missingAlternative :: Environment -> ModuleName -> CaseAlternative -> [Binder] -> ([[Binder]], Maybe Bool)
230+missingAlternative :: Environment -> ModuleName -> CaseAlternative -> [Binder] -> ([[Binder]], Either RedudancyError Bool)
220231missingAlternative env mn ca uncovered
221232 | isExhaustiveGuard (caseAlternativeResult ca) = mcases
222233 | otherwise = ([uncovered], snd mcases)
@@ -232,24 +243,31 @@ missingAlternative env mn ca uncovered
232243checkExhaustive :: forall m. (MonadWriter MultipleErrors m) => Environment -> ModuleName -> Int -> [CaseAlternative] -> m ()
233244checkExhaustive env mn numArgs cas = makeResult . first nub $ foldl' step ([initialize numArgs], (pure True, [])) cas
234245 where
235− step :: ([[Binder]], (Maybe Bool, [[Binder]])) -> CaseAlternative -> ([[Binder]], (Maybe Bool, [[Binder]]))
246+ step :: ([[Binder]], (Either RedudancyError Bool, [[Binder]])) -> CaseAlternative -> ([[Binder]], (Either RedudancyError Bool, [[Binder]]))
236247 step (uncovered, (nec, redundant)) ca =
237248 let (missed, pr) = unzip (map (missingAlternative env mn ca) uncovered)
238− cond = or <$> sequenceA pr
239− in (concat missed, (liftA2 (&&) cond nec,
240− if fromMaybe True cond then redundant else caseAlternativeBinders ca : redundant))
241−#if __GLASGOW_HASKELL__ < 710
242− where
243− sequenceA = foldr (liftA2 (:)) (pure [])
244−#endif
249+ (missed', approx) = splitAt 10000 (concat missed)
250+ cond = liftA2 (&&) (or <$> sequenceA pr) nec
251+ in (missed', ( if null approx
252+ then cond
253+ else Left Incomplete
254+ , if either (const True) id cond
255+ then redundant
256+ else caseAlternativeBinders ca : redundant
257+ )
258+ )
245259
246− makeResult :: ([[Binder]], (Maybe Bool, [[Binder]])) -> m ()
247− makeResult (bss, (_, bss')) =
260+ makeResult :: ([[Binder]], (Either RedudancyError Bool, [[Binder]])) -> m ()
261+ makeResult (bss, (rr, bss')) =
248262 do unless (null bss) tellExhaustive
249263 unless (null bss') tellRedundant
264+ case rr of
265+ Left Incomplete -> tellIncomplete
266+ _ -> return ()
250267 where
251268 tellExhaustive = tell . errorMessage . uncurry NotExhaustivePattern . second null . splitAt 5 $ bss
252269 tellRedundant = tell . errorMessage . uncurry OverlappingPattern . second null . splitAt 5 $ bss'
270+ tellIncomplete = tell . errorMessage $ IncompleteExhaustivityCheck
253271
254272-- |
255273-- Exhaustivity checking over a list of declarations