git.iko.soy/elk
on 7dd0bbd help sign in
elk/src/Nitpick/PatternMatches.hs
458 lines 11 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Nitpick.PatternMatches (patternMatches) where
5{- The algorithm used here comes from "Warnings for Pattern Matching"
6by Luc Maranget. Check it out for more information!
8http://moscova.inria.fr/~maranget/papers/warn/warn.pdf
10-}
12import Control.Arrow ((***), second)
13import qualified Data.Foldable as F
14import qualified Data.List as List
15import qualified Data.Map as Map
16import qualified Data.Maybe as Maybe
17import qualified Data.Set as Set
18import qualified Data.Text as Text
19import Data.Text (Text)
21import qualified AST.Expression.Canonical as C
22import qualified AST.Helpers as Help
23import qualified AST.Literal as L
24import qualified AST.Module as Module
25import qualified AST.Module.Name as ModuleName
26import qualified AST.Pattern as Pattern
27import qualified AST.Variable as Var
28import Elm.Utils ((|>))
29import Nitpick.Pattern (Pattern(..), fromCanonicalPattern)
30import qualified Optimize.DecisionTree as DT
31import qualified Reporting.Annotation as A
32import qualified Reporting.Error.Pattern as Error
33import qualified Reporting.Region as Region
34import qualified Reporting.Result as Result
38-- NITPICK PATTERN MATCHES
41type Result warning a =
42 Result.Result () warning Error.Error a
45patternMatches :: Module.Interfaces -> Module.Canonical -> Result wrn DT.VariantDict
46patternMatches interfaces (Module.Module name _ info) =
47 let
48 arityDict =
49 toArityDict interfaces name (Module.unions info)
51 variantDict =
52 Map.map (Map.map _size) arityDict
53 in
54 pure variantDict
55 <* checkExpression arityDict (Module.program info)
58checkExpression :: ArityDict -> C.Expr -> Result wrn ()
59checkExpression arityDict (A.A region expression) =
60 let
61 go =
62 checkExpression arityDict
64 go2 a b =
65 go a <* go b
66 in
67 case expression of
68 C.Literal _ ->
69 Result.ok ()
71 C.Var _ ->
72 Result.ok ()
74 C.List listExprs ->
75 F.traverse_ go listExprs
77 C.Binop _ leftExpr rightExpr ->
78 go2 leftExpr rightExpr
80 C.Lambda pattern@(A.A patRegion _) body ->
81 checkPatterns arityDict patRegion Error.Arg [pattern]
82 <* go body
84 C.App func arg ->
85 go2 func arg
87 C.If branches finally ->
88 F.traverse_ (uncurry go2) branches
89 <* go finally
91 C.Let defs body ->
92 go body
93 <* F.traverse_ goDef defs
94 where
95 goDef (C.Def _ pattern@(A.A patRegion _) expr _) =
96 checkPatterns arityDict patRegion Error.LetBound [pattern]
97 <* go expr
99 C.Case expr branches ->
100 go expr
101 <* checkPatterns arityDict region Error.Case (map fst branches)
102 <* F.traverse_ (go . snd) branches
104 C.Ctor _ctor exprs ->
105 F.traverse_ go exprs
107 C.Access record _field ->
108 go record
110 C.Update record fields ->
111 go record
112 <* F.traverse_ (go . snd) fields
114 C.Record fields ->
115 F.traverse_ (go . snd) fields
117 C.Cmd _ ->
118 Result.ok ()
120 C.Sub _ ->
121 Result.ok ()
123 C.OutgoingPort _ _ ->
124 Result.ok ()
126 C.IncomingPort _ _ ->
127 Result.ok ()
129 C.Program _ _ ->
130 error "DANGER - Program AST nodes should not be in Nitpick.PatternMatches."
132 C.SaveEnv _ _ ->
133 Result.ok ()
135 C.GLShader _ _ _ ->
136 Result.ok ()
140-- CHECK PATTERNS
143checkPatterns :: ArityDict -> Region.Region -> Error.Origin -> [Pattern.Canonical] -> Result wrn ()
144checkPatterns arityDict region origin patterns =
145 do matrix <- checkRedundant arityDict region [] patterns
146 case isExhaustive arityDict matrix 1 of
147 [] ->
148 Result.ok ()
150 badPatterns ->
151 Result.throw region (Error.Incomplete origin (map head badPatterns))
155-- EXHAUSTIVE PATTERNS
158isExhaustive :: ArityDict -> [[Pattern]] -> Int -> [[Pattern]]
159isExhaustive arityDict matrix n =
160 case (matrix, n) of
161 ([], _) ->
162 [replicate n Anything]
164 (_, 0) ->
165 []
167 (_, _) ->
168 let
169 ctorSet =
170 List.foldl' isCompleteHelp Set.empty matrix
172 actual =
173 Set.size ctorSet
174 in
175 if actual == 0 then
176 (:) Anything
177 <$> isExhaustive arityDict (Maybe.mapMaybe toDefault matrix) (n - 1)
179 else
180 let
181 (ArityInfo expected info) =
182 getArityInfo (Set.findMin ctorSet) arityDict
183 in
184 if actual < expected then
185 (:)
186 <$> Maybe.mapMaybe (isMissing ctorSet) info
187 <*> isExhaustive arityDict (Maybe.mapMaybe toDefault matrix) (n - 1)
189 else
190 let
191 isExhaustiveHelp (name, arity) =
192 recoverCtor name arity <$>
193 isExhaustive
194 arityDict
195 (Maybe.mapMaybe (specialize name arity) matrix)
196 (arity + n - 1)
197 in
198 concatMap isExhaustiveHelp info
201isMissing :: Set.Set Var.Canonical -> (Var.Canonical, Int) -> Maybe Pattern
202isMissing ctorSet (name, arity) =
203 if Set.member name ctorSet then
204 Nothing
206 else
207 Just (Ctor name (replicate arity Anything))
210recoverCtor :: Var.Canonical -> Int -> [Pattern] -> [Pattern]
211recoverCtor name arity patterns =
212 let
213 (args, rest) =
214 splitAt arity patterns
215 in
216 Ctor name args : rest
220-- REDUNDANT PATTERNS
223checkRedundant
224 :: ArityDict
225 -> Region.Region
226 -> [[Pattern]]
227 -> [Pattern.Canonical]
228 -> Result wrn [[Pattern]]
229checkRedundant arityDict region checked unchecked =
230 case unchecked of
231 [] ->
232 Result.ok checked
234 nextPattern@(A.A patRegion _) : rest ->
235 let
236 next =
237 [fromCanonicalPattern nextPattern]
238 in
239 if isUseful arityDict checked next then
240 checkRedundant arityDict region (next : checked) rest
241 else
242 Result.throw region (Error.Redundant patRegion (length checked + 1))
245isUseful :: ArityDict -> [[Pattern]] -> [Pattern] -> Bool
246isUseful arityDict matrix vector =
247 case (matrix, vector) of
248 ([], _) ->
249 True
251 (_, []) ->
252 False
254 (_, firstPattern : patterns) ->
255 case firstPattern of
256 Ctor name args ->
257 let
258 newMatrix =
259 Maybe.mapMaybe (specialize name (length args)) matrix
260 in
261 isUseful arityDict newMatrix (args ++ patterns)
263 Anything ->
264 case isComplete arityDict matrix of
265 Nothing ->
266 isUseful arityDict (Maybe.mapMaybe toDefault matrix) patterns
268 Just arityInfo ->
269 let
270 isUsefulHelp (ctor, arity) =
271 isUseful
272 arityDict
273 (Maybe.mapMaybe (specialize ctor arity) matrix)
274 (replicate arity Anything ++ patterns)
275 in
276 any isUsefulHelp arityInfo
278 Literal literal ->
279 let
280 newMatrix =
281 Maybe.mapMaybe (specializeLiteral literal) matrix
282 in
283 isUseful arityDict newMatrix patterns
287-- SPECIALIZE MATRICES
290specialize :: Var.Canonical -> Int -> [Pattern] -> Maybe [Pattern]
291specialize ctorName arity row =
292 case row of
293 [] ->
294 error "Compiler error! Empty matrices should not get specialized."
296 firstPattern : patterns ->
297 case firstPattern of
298 Ctor name args ->
299 if name == ctorName then Just (args ++ patterns) else Nothing
301 Anything ->
302 Just (replicate arity Anything ++ patterns)
304 Literal _ ->
305 error $
306 "Compiler bug! After type checking, constructors and literals\
307 \ should never align in pattern match exhaustiveness checks."
310specializeLiteral :: L.Literal -> [Pattern] -> Maybe [Pattern]
311specializeLiteral literal row =
312 case row of
313 [] ->
314 error "Compiler error! Empty matrices should not get specialized."
316 firstPattern : patterns ->
317 case firstPattern of
318 Literal lit ->
319 if lit == literal then Just patterns else Nothing
321 Anything ->
322 Just patterns
324 Ctor _ _ ->
325 error $
326 "Compiler bug! After type checking, constructors and literals\
327 \ should never align in pattern match exhaustiveness checks."
330toDefault :: [Pattern] -> Maybe [Pattern]
331toDefault row =
332 case row of
333 [] ->
334 Nothing
336 Ctor _ _ : _ ->
337 Nothing
339 Anything : patterns ->
340 Just patterns
342 Literal _ : _ ->
343 Nothing
347-- ALL CONSTRUCTORS ARE PRESENT?
350isComplete :: ArityDict -> [[Pattern]] -> Maybe [(Var.Canonical, Int)]
351isComplete arityDict matrix =
352 let
353 ctorSet =
354 List.foldl' isCompleteHelp Set.empty matrix
356 actual =
357 Set.size ctorSet
358 in
359 if actual == 0 then
360 Nothing
362 else
363 let
364 (ArityInfo expected info) =
365 getArityInfo (Set.findMin ctorSet) arityDict
366 in
367 if expected == actual then Just info else Nothing
370isCompleteHelp :: Set.Set Var.Canonical -> [Pattern] -> Set.Set Var.Canonical
371isCompleteHelp ctors row =
372 case row of
373 Ctor name _ : _ ->
374 Set.insert name ctors
376 _ ->
377 ctors
381-- ARITY DICT
384type ArityDict =
385 Map.Map Var.Home (Map.Map Text ArityInfo)
388data ArityInfo =
389 ArityInfo
390 { _size :: !Int
391 , _info :: [(Var.Canonical, Int)]
392 }
395toArityDict :: Module.Interfaces -> ModuleName.Canonical -> Module.Unions -> ArityDict
396toArityDict interfaces localName localUnions =
397 interfaces
398 |> Map.mapWithKey (\name iface -> toArityEntry name (Module.iUnions iface))
399 |> Map.mapKeysMonotonic Var.Module
400 |> Map.insert (Var.Module localName) (toArityEntry localName localUnions)
401 |> Map.union builtinDict
404builtinDict :: ArityDict
405builtinDict =
406 let
407 listInfo =
408 ArityInfo 2 [ (Var.builtin "::", 2), (Var.builtin "[]", 0) ]
410 boolInfo =
411 ArityInfo 2 [ (Var.builtin "True", 0), (Var.builtin "False", 0) ]
412 in
413 Map.singleton Var.BuiltIn $ Map.fromList $
414 [ ("::", listInfo)
415 , ("[]", listInfo)
416 , ("True", boolInfo)
417 , ("False", boolInfo)
418 ]
419 ++ map makeTupleInfo [0..8]
422makeTupleInfo :: Int -> ( Text, ArityInfo )
423makeTupleInfo n =
424 let
425 name =
426 Text.pack ("_Tuple" ++ show n)
427 in
428 ( name, ArityInfo 1 [ (Var.builtin name, n) ] )
431toArityEntry :: ModuleName.Canonical -> Module.Unions -> Map.Map Text ArityInfo
432toArityEntry name unions =
433 Map.fromList (concatMap (toArityEntryHelp name) (Map.elems unions))
436toArityEntryHelp :: ModuleName.Canonical -> Module.UnionInfo Text -> [(Text, ArityInfo)]
437toArityEntryHelp name (_tvars, ctors) =
438 let
439 arityInfo =
440 ArityInfo (length ctors) (map (Var.fromModule name *** length) ctors)
441 in
442 map (second (\_ -> arityInfo)) ctors
445getArityInfo :: Var.Canonical -> ArityDict -> ArityInfo
446getArityInfo var@(Var.Canonical home name) arityDict =
447 case Map.lookup name =<< Map.lookup home arityDict of
448 Just arityInfo ->
449 arityInfo
451 Nothing ->
452 if Help.isTuple name then
453 ArityInfo 1 [ (var, read (drop 6 (Text.unpack name))) ]
454 else
455 error
456 "Since the Nitpick phase happens after canonicalization and type\
457 \ inference, it is impossible that a pattern in a case cannot be\
458 \ found."