9ac688d · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

on golang help sign in

Redundancy checking.

9ac688dnicodelpiano11 years ago

src/Language/PureScript/Errors.hs+7

compare with golang

unifiedsplit

@@ -121,6 +121,7 @@ data SimpleErrorMessage

121 | ShadowedName Ident

122 | WildcardInferredType Type

123 | NotExhaustivePattern [[Binder]] Bool

124+ | OverlappingPattern [[Binder]] Bool

124 | ClassOperator ProperName Ident

125 | ClassOperator ProperName Ident

125 deriving (Show)

126 deriving (Show)

126

127

@@ -231,6 +232,7 @@ errorCode em = case unwrapErrorMessage em of

231 (ShadowedName _) -> "ShadowedName"

232 (ShadowedName _) -> "ShadowedName"

232 (WildcardInferredType _) -> "WildcardInferredType"

233 (WildcardInferredType _) -> "WildcardInferredType"

233 (NotExhaustivePattern _ _) -> "NotExhaustivePattern"

234 (NotExhaustivePattern _ _) -> "NotExhaustivePattern"

235+ (OverlappingPattern _ _) -> "OverlappingPattern"

234 (ClassOperator _ _) -> "ClassOperator"

236 (ClassOperator _ _) -> "ClassOperator"

235

237

236-- |

238-- |

@@ -566,6 +568,11 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError

566 , line $ "The definition has the following uncovered cases:\n"

568 , line $ "The definition has the following uncovered cases:\n"

567 , Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs))

569 , Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs))

568 ] ++ if not b then [line "..."] else []

570 ] ++ if not b then [line "..."] else []

571+ goSimple (OverlappingPattern bs b) =

572+ indent $ paras $ [ line "Redundant cases have been detected."

573+ , line $ "The definition has the following redundant cases:\n"

574+ , Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs))

575+ ] ++ if not b then [line "..."] else []

569 go (NotYetDefined names err) =

576 go (NotYetDefined names err) =

570 paras [ line $ "The following are not yet defined here: " ++ intercalate ", " (map show names) ++ ":"

577 paras [ line $ "The following are not yet defined here: " ++ intercalate ", " (map show names) ++ ":"

571 , indent $ go err

578 , indent $ go err

src/Language/PureScript/Linter/Exhaustive.hs+43−34

@@ -31,7 +31,7 @@ import Data.Function (on)

32import Control.Monad (unless)

33import Control.Applicative

34−import Control.Arrow (second)

34+import Control.Arrow (first, second)

35import Control.Monad.Writer.Class

37import Language.PureScript.AST.Binders

@@ -108,31 +108,30 @@ genericMerge f bsl@((s, b):bs) bsr@((s', b'):bs')

108

109-- |

110-- Find the uncovered set between two binders:

111−-- the first binder is the case we are trying to cover the second one is the matching binder

111+-- the first binder is the case we are trying to cover, the second one is the matching binder

112--

113−missingCasesSingle :: Environment -> ModuleName -> Binder -> Binder -> [Binder]

113+missingCasesSingle :: Environment -> ModuleName -> Binder -> Binder -> ([Binder], Maybe Bool)

114−missingCasesSingle _ _ _ NullBinder = []

114+missingCasesSingle _ _ _ NullBinder = ([], Just True)

115−missingCasesSingle _ _ _ (VarBinder _) = []

115+missingCasesSingle _ _ _ (VarBinder _) = ([], Just True)

116missingCasesSingle env mn (VarBinder _) b = missingCasesSingle env mn NullBinder b

117missingCasesSingle env mn br (NamedBinder _ bl) = missingCasesSingle env mn br bl

118missingCasesSingle env mn NullBinder cb@(ConstructorBinder con _) =

119− concatMap (\cp -> missingCasesSingle env mn cp cb) allPatterns

119+ (concatMap (\cp -> fst $ missingCasesSingle env mn cp cb) allPatterns, Just True)

120 where

121 allPatterns = map (\(p, t) -> ConstructorBinder (qualifyName p mn con) (initialize $ length t))

122 $ getConstructors env mn con

123missingCasesSingle env mn cb@(ConstructorBinder con bs) (ConstructorBinder con' bs')

124− | con == con' = map (ConstructorBinder con) (missingCasesMultiple env mn bs bs')

124+ | con == con' = let (bs'', pr) = missingCasesMultiple env mn bs bs' in (map (ConstructorBinder con) bs'', pr)

125− | otherwise = [cb]

125+ | otherwise = ([cb], Just False)

126−missingCasesSingle _ _ NullBinder (ArrayBinder bs)

127− | null bs = []

128− | otherwise = []

129missingCasesSingle env mn NullBinder (ObjectBinder bs) =

126missingCasesSingle env mn NullBinder (ObjectBinder bs) =

130− map (ObjectBinder . zip (map fst bs)) allMisses

127+ (map (ObjectBinder . zip (map fst bs)) allMisses, pr)

131 where

128 where

132− allMisses = missingCasesMultiple env mn (initialize $ length bs) (map snd bs)

129+ (allMisses, pr) = missingCasesMultiple env mn (initialize $ length bs) (map snd bs)

133missingCasesSingle env mn (ObjectBinder bs) (ObjectBinder bs') =

130missingCasesSingle env mn (ObjectBinder bs) (ObjectBinder bs') =

134− map (ObjectBinder . zip sortedNames) $ uncurry (missingCasesMultiple env mn) (unzip binders)

131+ (map (ObjectBinder . zip sortedNames) allMisses, pr)

135 where

132 where

133+ (allMisses, pr) = uncurry (missingCasesMultiple env mn) (unzip binders)

134+

136 sortNames = sortBy (compare `on` fst)

135 sortNames = sortBy (compare `on` fst)

137

136

138 (sbs, sbs') = (sortNames bs, sortNames bs')

137 (sbs, sbs') = (sortNames bs, sortNames bs')

@@ -146,12 +145,12 @@ missingCasesSingle env mn (ObjectBinder bs) (ObjectBinder bs') =

146 compBS e s b b' = (s, compB e b b')

145 compBS e s b b' = (s, compB e b b')

147

146

148 (sortedNames, binders) = unzip $ genericMerge (compBS NullBinder) sbs sbs'

147 (sortedNames, binders) = unzip $ genericMerge (compBS NullBinder) sbs sbs'

149−missingCasesSingle _ _ NullBinder (BooleanBinder b) = [BooleanBinder $ not b]

148+missingCasesSingle _ _ NullBinder (BooleanBinder b) = ([BooleanBinder $ not b], Just True)

150missingCasesSingle _ _ (BooleanBinder bl) (BooleanBinder br)

149missingCasesSingle _ _ (BooleanBinder bl) (BooleanBinder br)

151− | bl == br = []

150+ | bl == br = ([], Just True)

152− | otherwise = [BooleanBinder bl]

151+ | otherwise = ([BooleanBinder bl], Just False)

153missingCasesSingle env mn b (PositionedBinder _ _ cb) = missingCasesSingle env mn b cb

152missingCasesSingle env mn b (PositionedBinder _ _ cb) = missingCasesSingle env mn b cb

154−missingCasesSingle _ _ b _ = [b]

153+missingCasesSingle _ _ b _ = ([b], Nothing)

155

154

156-- |

155-- |

157-- Returns the uncovered set of binders

156-- Returns the uncovered set of binders

@@ -179,15 +178,14 @@ missingCasesSingle _ _ b _ = [b]

179-- redundant or not, but uncovered at least. If we use `y` instead, we'll need to have a redundancy checker

178-- redundant or not, but uncovered at least. If we use `y` instead, we'll need to have a redundancy checker

180-- (which ought to be available soon), or increase the complexity of the algorithm.

179-- (which ought to be available soon), or increase the complexity of the algorithm.

181--

180--

182−missingCasesMultiple :: Environment -> ModuleName -> [Binder] -> [Binder] -> [[Binder]]

181+missingCasesMultiple :: Environment -> ModuleName -> [Binder] -> [Binder] -> ([[Binder]], Maybe Bool)

183missingCasesMultiple env mn = go

182missingCasesMultiple env mn = go

184 where

183 where

185− go [] _ = []

184+ go [] [] = ([], pure True)

186− go (x:xs) (y:ys)

185+ go (x:xs) (y:ys) = (map (: xs) miss1 ++ map (x :) miss2, liftA2 (&&) pr1 pr2)

187− | null miss = map (x :) (go xs ys)

188− | otherwise = map (: xs) miss ++ map (x :) (go xs ys)

189 where

186 where

190− miss = missingCasesSingle env mn x y

187+ (miss1, pr1) = missingCasesSingle env mn x y

188+ (miss2, pr2) = go xs ys

191 go _ _ = error "Argument lengths did not match in missingCasesMultiple."

189 go _ _ = error "Argument lengths did not match in missingCasesMultiple."

192

190

193-- |

191-- |

@@ -214,13 +212,15 @@ isExhaustiveGuard (Right _) = True

214-- |

212-- |

215-- Returns the uncovered set of case alternatives

213-- Returns the uncovered set of case alternatives

216--

214--

217−missingCases :: Environment -> ModuleName -> [Binder] -> CaseAlternative -> [[Binder]]

215+missingCases :: Environment -> ModuleName -> [Binder] -> CaseAlternative -> ([[Binder]], Maybe Bool)

218missingCases env mn uncovered ca = missingCasesMultiple env mn uncovered (caseAlternativeBinders ca)

216missingCases env mn uncovered ca = missingCasesMultiple env mn uncovered (caseAlternativeBinders ca)

219

217

220−missingAlternative :: Environment -> ModuleName -> CaseAlternative -> [Binder] -> [[Binder]]

218+missingAlternative :: Environment -> ModuleName -> CaseAlternative -> [Binder] -> ([[Binder]], Maybe Bool)

221missingAlternative env mn ca uncovered

219missingAlternative env mn ca uncovered

222− | isExhaustiveGuard (caseAlternativeResult ca) = missingCases env mn uncovered ca

220+ | isExhaustiveGuard (caseAlternativeResult ca) = mcases

223− | otherwise = [uncovered]

221+ | otherwise = ([uncovered], snd mcases)

222+ where

223+ mcases = missingCases env mn uncovered ca

224

225-- |

226-- Main exhaustivity checking function

@@ -229,20 +229,29 @@ missingAlternative env mn ca uncovered

229-- Then, returns the uncovered set of case alternatives.

230--

231checkExhaustive :: forall m. (MonadWriter MultipleErrors m) => Environment -> ModuleName -> [CaseAlternative] -> m ()

232−checkExhaustive env mn cas = makeResult . nub $ foldl' step [initial] cas

232+checkExhaustive env mn cas = makeResult . first nub $ foldl' step ([initial], (pure True, [])) cas

233 where

234− step :: [[Binder]] -> CaseAlternative -> [[Binder]]

234+ step :: ([[Binder]], (Maybe Bool, [[Binder]])) -> CaseAlternative -> ([[Binder]], (Maybe Bool, [[Binder]]))

235+ step (uncovered, (nec, redundant)) ca =

235− step uncovered ca = concatMap (missingAlternative env mn ca) uncovered

236+ let (missed, pr) = unzip (map (missingAlternative env mn ca) uncovered)

237+ cond = or <$> sequenceA pr

238+ in (concat missed, (liftA2 (&&) cond nec,

239+ if fromMaybe True cond then redundant else caseAlternativeBinders ca : redundant))

240+ where

241+ sequenceA = foldr (liftA2 (:)) (pure [])

236

242

237 initial :: [Binder]

243 initial :: [Binder]

238 initial = initialize numArgs

244 initial = initialize numArgs

239 where

245 where

240 numArgs = length . caseAlternativeBinders . head $ cas

246 numArgs = length . caseAlternativeBinders . head $ cas

241

247

242− makeResult :: [[Binder]] -> m ()

248+ makeResult :: ([[Binder]], (Maybe Bool, [[Binder]])) -> m ()

243− makeResult bss = unless (null bss) tellWarning

249+ makeResult (bss, (_, bss')) =

250+ do unless (null bss) tellExhaustive

251+ unless (null bss') tellRedundant

244 where

252 where

245− tellWarning = tell . errorMessage . uncurry NotExhaustivePattern . second null . splitAt 5 $ bss

253+ tellExhaustive = tell . errorMessage . uncurry NotExhaustivePattern . second null . splitAt 5 $ bss

254+ tellRedundant = tell . errorMessage . uncurry OverlappingPattern . second null . splitAt 5 $ bss'

246

255

247-- |

256-- |

248-- Exhaustivity checking over a list of declarations

257-- Exhaustivity checking over a list of declarations