|
| 1 | +module Nitpick.PatternMatchesSpec (spec) where |
| 2 | + |
| 3 | +import AST.Canonical (Pattern_) |
| 4 | +import AST.Canonical qualified as Can |
| 5 | +import Data.Index qualified as Index |
| 6 | +import Data.List (intercalate) |
| 7 | +import Data.Map qualified as Map |
| 8 | +import Data.Name qualified as N |
| 9 | +import Data.Utf8 qualified as Utf8 |
| 10 | +import Gren.ModuleName qualified as ModuleName |
| 11 | +import Gren.Package qualified as Pkg |
| 12 | +import Nitpick.PatternMatches |
| 13 | + ( Context (..), |
| 14 | + Error (..), |
| 15 | + Literal (..), |
| 16 | + Pattern (..), |
| 17 | + checkPatterns, |
| 18 | + ) |
| 19 | +import Reporting.Annotation qualified as A |
| 20 | +import Test.Hspec (Spec, describe, it, shouldBe) |
| 21 | + |
| 22 | +-- Create a Can.Union for Bool |
| 23 | +boolUnion :: Can.Union |
| 24 | +boolUnion = |
| 25 | + Can.Union |
| 26 | + { Can._u_vars = [], |
| 27 | + Can._u_alts = |
| 28 | + [ Can.Ctor (N.fromChars "True") (Index.first) 0 [], |
| 29 | + Can.Ctor (N.fromChars "False") (Index.next (Index.first)) 0 [] |
| 30 | + ], |
| 31 | + Can._u_numAlts = 2, |
| 32 | + Can._u_opts = Can.Enum |
| 33 | + } |
| 34 | + |
| 35 | +-- Create a Can.Union for Maybe |
| 36 | +maybeUnion :: Can.Union |
| 37 | +maybeUnion = |
| 38 | + Can.Union |
| 39 | + { Can._u_vars = [(N.fromChars "a")], |
| 40 | + Can._u_alts = |
| 41 | + [ Can.Ctor (N.fromChars "Just") (Index.first) 1 [Can.TVar (N.fromChars "a")], |
| 42 | + Can.Ctor (N.fromChars "Nothing") (Index.next (Index.first)) 0 [] |
| 43 | + ], |
| 44 | + Can._u_numAlts = 2, |
| 45 | + Can._u_opts = Can.Normal |
| 46 | + } |
| 47 | + |
| 48 | +-- Create a Pattern_ that is a PCtor for Maybe |
| 49 | +maybePCtor :: Bool -> [Can.PatternCtorArg] -> Pattern_ |
| 50 | +maybePCtor isJust args = |
| 51 | + Can.PCtor |
| 52 | + { Can._p_home = |
| 53 | + ModuleName.Canonical |
| 54 | + (Pkg.Name (Utf8.fromChars "core") (Utf8.fromChars "gren-lang")) |
| 55 | + (Utf8.fromChars "Maybe"), |
| 56 | + Can._p_type = (N.fromChars "Maybe"), |
| 57 | + Can._p_union = maybeUnion, |
| 58 | + Can._p_name = if isJust then (N.fromChars "Just") else (N.fromChars "Nothing"), |
| 59 | + Can._p_index = if isJust then Index.first else (Index.next (Index.first)), |
| 60 | + Can._p_args = args |
| 61 | + } |
| 62 | + |
| 63 | +{- |
| 64 | +Test 1: Incomplete Bool Records |
| 65 | +
|
| 66 | +This is the original case reported by marias. It exercises |
| 67 | +a bug in the compiler. |
| 68 | +
|
| 69 | +fn r = |
| 70 | + when r is |
| 71 | + { a = False, b = True } -> 1 |
| 72 | + { a = True, b = False } -> 2 |
| 73 | +-} |
| 74 | + |
| 75 | +-- These are the Can.Patterns produced by the parser and checkCases |
| 76 | +test1InputCanPatterns :: [Can.Pattern] |
| 77 | +test1InputCanPatterns = |
| 78 | + [ ( A.At |
| 79 | + A.zero |
| 80 | + ( Can.PRecord |
| 81 | + [ A.At A.zero (Can.PRFieldPattern (N.fromChars "a") (A.At A.zero (Can.PBool boolUnion False))), |
| 82 | + A.At A.zero (Can.PRFieldPattern (N.fromChars "b") (A.At A.zero (Can.PBool boolUnion True))) |
| 83 | + ] |
| 84 | + ) |
| 85 | + ), |
| 86 | + ( A.At |
| 87 | + A.zero |
| 88 | + ( Can.PRecord |
| 89 | + [ A.At A.zero (Can.PRFieldPattern (N.fromChars "a") (A.At A.zero (Can.PBool boolUnion True))), |
| 90 | + A.At A.zero (Can.PRFieldPattern (N.fromChars "b") (A.At A.zero (Can.PBool boolUnion False))) |
| 91 | + ] |
| 92 | + ) |
| 93 | + ) |
| 94 | + ] |
| 95 | + |
| 96 | +-- We expect isExhaustive to find these patterns as missing: |
| 97 | +-- It finds 1 Error, which has 2 strings, one for each missing pattern |
| 98 | +test1Expectation :: [[String]] |
| 99 | +test1Expectation = |
| 100 | + [ [ "a : True, b : True", |
| 101 | + "a : False, b : False" |
| 102 | + ] |
| 103 | + ] |
| 104 | + |
| 105 | +{- |
| 106 | +Test 2: Record destructuring, as seen in core.git's Dict.gren |
| 107 | +
|
| 108 | +After an incorrect fix for test1 by gilbertr, this case was found |
| 109 | +to need extra handling. It *is* exhaustive, but the incorrect fix |
| 110 | +found it to be non-exhaustive. |
| 111 | +
|
| 112 | +fn r = |
| 113 | + when r is |
| 114 | + Nothing -> "Nothing" |
| 115 | + Just { first = { key = lKey, value = lValue }, rest } -> lKey |
| 116 | +-} |
| 117 | + |
| 118 | +-- These are the Can.Patterns produced by the parser and checkCases |
| 119 | +test2InputCanPatterns :: [Can.Pattern] |
| 120 | +test2InputCanPatterns = |
| 121 | + [ (A.At A.zero (maybePCtor False [])), |
| 122 | + ( A.At |
| 123 | + A.zero |
| 124 | + ( maybePCtor |
| 125 | + True |
| 126 | + [ Can.PatternCtorArg |
| 127 | + { Can._index = Index.first, |
| 128 | + Can._type = Can.TVar (N.fromChars "a"), |
| 129 | + Can._arg = |
| 130 | + ( A.At |
| 131 | + A.zero |
| 132 | + ( Can.PRecord |
| 133 | + [ A.At |
| 134 | + A.zero |
| 135 | + ( Can.PRFieldPattern |
| 136 | + (N.fromChars "first") |
| 137 | + ( A.At |
| 138 | + A.zero |
| 139 | + ( Can.PRecord |
| 140 | + [ A.At |
| 141 | + A.zero |
| 142 | + ( Can.PRFieldPattern |
| 143 | + (N.fromChars "key") |
| 144 | + (A.At A.zero (Can.PVar (N.fromChars "lKey"))) |
| 145 | + ), |
| 146 | + A.At |
| 147 | + A.zero |
| 148 | + ( Can.PRFieldPattern |
| 149 | + (N.fromChars "value") |
| 150 | + (A.At A.zero (Can.PVar (N.fromChars "lValue"))) |
| 151 | + ) |
| 152 | + ] |
| 153 | + ) |
| 154 | + ) |
| 155 | + ), |
| 156 | + A.At |
| 157 | + A.zero |
| 158 | + ( Can.PRFieldPattern |
| 159 | + (N.fromChars "rest") |
| 160 | + ( A.At A.zero (Can.PVar (N.fromChars "rest")) |
| 161 | + ) |
| 162 | + ) |
| 163 | + ] |
| 164 | + ) -- Can.PRecord |
| 165 | + ) |
| 166 | + } |
| 167 | + ] -- Can.PatternCtorArg |
| 168 | + ) |
| 169 | + ) |
| 170 | + ] |
| 171 | + |
| 172 | +-- We expect isExhaustive to find *no* patterns to be missing: |
| 173 | +test2Expectation :: [[String]] |
| 174 | +test2Expectation = |
| 175 | + [] |
| 176 | + |
| 177 | +-- Small helper for the unit tests. |
| 178 | +-- This takes the input [Can.Pattern] and runs |
| 179 | +-- checkPatterns on it. |
| 180 | +runCheckPatterns :: [Can.Pattern] -> [Error] |
| 181 | +runCheckPatterns patterns = |
| 182 | + checkPatterns A.zero BadCase patterns [] |
| 183 | + |
| 184 | +-- checkPatterns returns an [Error], |
| 185 | +-- which can have [Pattern] in it. |
| 186 | +-- This is cumbersome to test in the unit tests. |
| 187 | +-- We convert each Error (and thus, [Pattern]) to a [String], |
| 188 | +-- making it a lot easier to assert on in the unit tests. |
| 189 | +-- |
| 190 | +-- E.g., this [Error] |
| 191 | +-- [ Incomplete A.Region Context [Pattern] ] |
| 192 | +-- |
| 193 | +-- in test 1 has this [Pattern] |
| 194 | +-- [ Record (fromList |
| 195 | +-- [("a",Ctor boolUnion "True" []) |
| 196 | +-- ,("b",Ctor boolUnion "True" []) |
| 197 | +-- ]) |
| 198 | +-- , Record (fromList |
| 199 | +-- [("a",Ctor boolUnion "False" []) |
| 200 | +-- ,("b",Ctor boolUnion "False" []) |
| 201 | +-- ]) |
| 202 | +-- ] |
| 203 | +-- |
| 204 | +-- which we convert into: |
| 205 | +-- [ |
| 206 | +-- [ "a: True, b: True", |
| 207 | +-- , "b: False, b: False" |
| 208 | +-- ] |
| 209 | +-- ] |
| 210 | + |
| 211 | +-- Convert a list of Error into a matrix of Strings |
| 212 | +errorsToTestableStrings :: [Error] -> [[String]] |
| 213 | +errorsToTestableStrings errors = |
| 214 | + map |
| 215 | + ( \err -> |
| 216 | + case err of |
| 217 | + Incomplete _ _ patterns -> (map (\pattern -> patternToTestableString pattern)) patterns |
| 218 | + Redundant _ _ _ -> ["redundant"] |
| 219 | + ) |
| 220 | + errors |
| 221 | + |
| 222 | +-- Given a list of Patterns, return a string representation |
| 223 | +patternsToTestableString :: [Pattern] -> String |
| 224 | +patternsToTestableString patterns = |
| 225 | + "[ " ++ (intercalate ", " (map patternToTestableString patterns)) ++ " ]" |
| 226 | + |
| 227 | +-- Convert a single Pattern into a String |
| 228 | +patternToTestableString :: Pattern -> String |
| 229 | +patternToTestableString pat = |
| 230 | + case pat of |
| 231 | + Anything -> "anything" |
| 232 | + Literal (Chr c) -> Utf8.toChars c |
| 233 | + Literal (Str s) -> Utf8.toChars s |
| 234 | + Literal (Int n) -> show n -- convert Int to String |
| 235 | + Array patterns -> patternsToTestableString patterns |
| 236 | + Ctor _ vName patterns -> |
| 237 | + if null patterns |
| 238 | + then N.toChars vName |
| 239 | + else (N.toChars vName) ++ (patternsToTestableString patterns) |
| 240 | + Record patternMap -> |
| 241 | + let -- Make a new map with String values |
| 242 | + newValuesMap = Map.map (\vPattern -> patternToTestableString vPattern) patternMap |
| 243 | + |
| 244 | + -- Transform the keys into Strings |
| 245 | + -- (++) here is a combiner function in case of key collisions |
| 246 | + newMap = Map.mapKeysWith (++) (\kName -> (N.toChars kName)) newValuesMap |
| 247 | + |
| 248 | + -- Convert to sorted list of (key, value) pairs |
| 249 | + -- Maps are balanced trees in Haskell, so walking them gives us |
| 250 | + -- sorted already |
| 251 | + pairs = Map.toList newMap |
| 252 | + |
| 253 | + -- Map each pair to a single "k : v" string |
| 254 | + formattedPairs = map (\(k, v) -> k ++ " : " ++ v) pairs |
| 255 | + in -- Join them all into one string |
| 256 | + intercalate ", " formattedPairs |
| 257 | + |
| 258 | +-- The unit tests |
| 259 | +spec :: Spec |
| 260 | +spec = do |
| 261 | + describe "PatternMatches tests" $ do |
| 262 | + it "Test 1 bool matrix is not exhaustive" $ do |
| 263 | + let errors = runCheckPatterns test1InputCanPatterns |
| 264 | + errorStrings = errorsToTestableStrings errors |
| 265 | + in errorStrings `shouldBe` test1Expectation |
| 266 | + |
| 267 | + it "Test 2 record destructruting is exhaustive" $ do |
| 268 | + let errors = runCheckPatterns test2InputCanPatterns |
| 269 | + errorStrings = errorsToTestableStrings errors |
| 270 | + in errorStrings `shouldBe` test2Expectation |
0 commit comments