Skip to content

Commit d48883e

Browse files
gilramirgilramir
committed
Re-do the unit tests to call checkPattern. Add a 2nd test case.
Test the original reported case, and the case which failed after an incorrect fix was attempted. This unit test now takes the [Error] returned by checkPattern, and converts it into a [[String]], making it very easy to test.
1 parent 4f2ff0d commit d48883e

File tree

2 files changed

+222
-104
lines changed

2 files changed

+222
-104
lines changed

‎compiler/src/Nitpick/PatternMatches.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -7,6 +7,7 @@ module Nitpick.PatternMatches
77
Context (..),
88
Pattern (..),
99
Literal (..),
10+
checkPatterns,
1011
)
1112
where
1213

‎tests/Nitpick/PatternMatchesSpec.hs‎

Lines changed: 221 additions & 104 deletions
Original file line numberDiff line numberDiff line change
@@ -1,19 +1,36 @@
11
module Nitpick.PatternMatchesSpec (spec) where
22

33
import AST.Canonical qualified as Can
4-
import AST.Source qualified as Src
4+
import AST.Canonical (Pattern_)
55
import Data.Index qualified as Index
6+
import Data.List (intercalate)
67
import Data.Map qualified as Map
78
import Data.Name qualified as N
8-
import Data.NonEmptyList qualified as NE
99
import Data.Utf8 qualified as Utf8
1010
import Gren.ModuleName qualified as ModuleName
1111
import Gren.Package qualified as Pkg
1212
import Reporting.Annotation qualified as A
1313

14-
import Nitpick.PatternMatches (check, Error (..))
14+
import Nitpick.PatternMatches (Pattern(..), Literal(..), Context(..), Error(..),
15+
checkPatterns)
1516

16-
import Test.Hspec (Spec, describe, it)
17+
import Test.Hspec (Spec, describe, it, shouldBe)
18+
19+
-- Create a Pkg.Name
20+
packageName :: String -> String -> Pkg.Name
21+
packageName pkgName authorName =
22+
Pkg.Name
23+
{ Pkg._author = Utf8.fromChars authorName
24+
, Pkg._project = Utf8.fromChars pkgName
25+
}
26+
27+
-- Create a ModuleName.Canonical
28+
moduleNameCanonical :: String -> String -> String -> ModuleName.Canonical
29+
moduleNameCanonical pkgName authorName modName =
30+
ModuleName.Canonical
31+
{ ModuleName._package = packageName pkgName authorName
32+
, ModuleName._module = N.fromChars modName
33+
}
1734

1835
-- Create a Can.Union for Bool
1936
boolUnion :: Can.Union
@@ -28,124 +45,224 @@ boolUnion =
2845
, Can._u_opts = Can.Enum
2946
}
3047

31-
emptyUnions :: Map.Map N.Name Can.Union
32-
emptyUnions = Map.empty
48+
-- Create a Can.Union for Maybe
49+
maybeUnion :: Can.Union
50+
maybeUnion =
51+
Can.Union
52+
{ Can._u_vars = [(N.fromChars "a")]
53+
, Can._u_alts =
54+
[ Can.Ctor (N.fromChars "Just") (Index.first) 1 [Can.TVar (N.fromChars "a")]
55+
, Can.Ctor (N.fromChars "Nothing") (Index.next (Index.first)) 0 []
56+
]
57+
, Can._u_numAlts = 2
58+
, Can._u_opts = Can.Normal
59+
}
3360

34-
emptyAliases :: Map.Map N.Name Can.Alias
35-
emptyAliases = Map.empty
61+
-- Create a Pattern_ that is a PCtor for Maybe
62+
maybePCtor :: Bool -> [Can.PatternCtorArg] -> Pattern_
63+
maybePCtor isJust args =
64+
Can.PCtor
65+
{ Can._p_home = moduleNameCanonical "core" "gren-lang" "Maybe"
66+
, Can._p_type = (N.fromChars "Maybe")
67+
, Can._p_union = maybeUnion
68+
, Can._p_name = if isJust then (N.fromChars "Just") else (N.fromChars "Nothing")
69+
, Can._p_index = if isJust then Index.first else (Index.next (Index.first))
70+
, Can._p_args = args
71+
}
3672

37-
emptyBinops :: Map.Map N.Name Can.Binop
38-
emptyBinops = Map.empty
3973

40-
packageName :: String -> String -> Pkg.Name
41-
packageName pkgName authorName =
42-
Pkg.Name
43-
{ Pkg._author = Utf8.fromChars authorName
44-
, Pkg._project = Utf8.fromChars pkgName
45-
}
74+
{-
75+
Test 1: Incomplete Bool Records
4676
47-
moduleNameCanonical :: String -> String -> String -> ModuleName.Canonical
48-
moduleNameCanonical pkgName authorName modName =
49-
ModuleName.Canonical
50-
{ ModuleName._package = packageName pkgName authorName
51-
, ModuleName._module = N.fromChars modName
52-
}
77+
This is the original case reported by marias. It exercises
78+
a bug in the compiler.
5379
54-
-- Create a Module from Decls
55-
-- We use A.zero to give an empty Region for exports and docs, as we don't
56-
-- care about their values
57-
makeModule :: Can.Decls -> Can.Module
58-
makeModule decls =
59-
Can.Module
60-
{ Can._name = moduleNameCanonical "TestPkg" "gren-devs" "TestModule"
61-
, Can._exports = Can.ExportEverything A.zero
62-
, Can._docs = Src.NoDocs A.zero
63-
, Can._decls = decls
64-
, Can._unions = emptyUnions
65-
, Can._aliases = emptyAliases
66-
, Can._binops = emptyBinops
67-
, Can._effects = Can.NoEffects
68-
}
80+
fn r =
81+
when r is
82+
{ a = False, b = True } -> 1
83+
{ a = True, b = False } -> 2
84+
-}
85+
86+
-- These are the Can.Patterns produced by the parser and checkCases
87+
test1InputCanPatterns :: [Can.Pattern]
88+
test1InputCanPatterns =
89+
[ (A.At A.zero (Can.PRecord
90+
[ A.At A.zero (Can.PRFieldPattern (N.fromChars "a") (A.At A.zero (Can.PBool boolUnion False)))
91+
, A.At A.zero (Can.PRFieldPattern (N.fromChars "b") (A.At A.zero (Can.PBool boolUnion True)))
92+
]))
93+
, (A.At A.zero (Can.PRecord
94+
[ A.At A.zero (Can.PRFieldPattern (N.fromChars "a") (A.At A.zero (Can.PBool boolUnion True)))
95+
, A.At A.zero (Can.PRFieldPattern (N.fromChars "b") (A.At A.zero (Can.PBool boolUnion False)))
96+
]))
97+
]
98+
99+
-- We expect isExhaustive to find these patterns as missing:
100+
-- It finds 1 Error, which has 2 strings, one for each missing pattern
101+
test1Expectation :: [[String]]
102+
test1Expectation =
103+
[
104+
[ "a : True, b : True"
105+
, "a : False, b : False"
106+
]
107+
]
69108

70-
-- In the unit test we may need to induce a failure just to appease
71-
-- the compiler. Use this Region when doing so.
72-
failedRegion :: A.Region
73-
failedRegion =
74-
A.Region (A.Position 99 99) (A.Position 99 99)
75109

76110

77-
-- Incomplete Bool Records
78111
{-
112+
Test 2: Record destructuring, as seen in core.git's Dict.gren
113+
114+
After an incorrect fix for test1 by gilbertr, this case was found
115+
to need extra handling. It *is* exhaustive, but the incorrect fix
116+
found it to be non-exhaustive.
117+
79118
fn r =
80119
when r is
81-
{ a = False, b = True } -> 1
82-
{ a = True, b = False } -> 2
120+
Nothing -> "Nothing"
121+
Just { first = { key = lKey, value = lValue }, rest } -> lKey
83122
-}
84-
-- The AST
85-
-- Debug.Trace trace was used to show the decls during "check",
86-
-- and this function was entered into "gren repl".
87-
-- The result was used to create this AST
88-
--
89-
-- Since we don't care about the true column/row range of each token
90-
-- in the source code, we use A.zero for each Region.
91-
incompleteBoolRecordsDecls :: Can.Decls
92-
incompleteBoolRecordsDecls =
93-
Can.Declare
94-
(Can.Def (A.At A.zero (N.fromChars "fn"))
95-
[ A.At A.zero (Can.PVar (N.fromChars "r")) ]
96-
(A.At A.zero
97-
(Can.Case (A.At A.zero (Can.VarLocal (N.fromChars "r")))
98-
[ Can.CaseBranch
99-
(A.At A.zero
100-
(Can.PRecord
101-
[ A.At A.zero (Can.PRFieldPattern (N.fromChars "a") (A.At A.zero (Can.PBool boolUnion False)))
102-
, A.At A.zero (Can.PRFieldPattern (N.fromChars "b") (A.At A.zero (Can.PBool boolUnion True)))
103-
]
104-
)
105-
)
106-
(A.At A.zero (Can.Int 1))
107-
, Can.CaseBranch
108-
(A.At A.zero
109-
(Can.PRecord
110-
[ A.At A.zero (Can.PRFieldPattern (N.fromChars "a") (A.At A.zero (Can.PBool boolUnion True)))
111-
, A.At A.zero (Can.PRFieldPattern (N.fromChars "b") (A.At A.zero (Can.PBool boolUnion False)))
112-
]
113-
)
114-
)
115-
(A.At A.zero (Can.Int 2))
116-
]
117-
)
123+
124+
-- These are the Can.Patterns produced by the parser and checkCases
125+
test2InputCanPatterns :: [Can.Pattern]
126+
test2InputCanPatterns =
127+
[ (A.At A.zero (maybePCtor False []))
128+
, (A.At A.zero (maybePCtor True
129+
[ Can.PatternCtorArg
130+
{ Can._index = Index.first
131+
, Can._type = Can.TVar (N.fromChars "a")
132+
, Can._arg = (A.At A.zero (
133+
Can.PRecord
134+
[ A.At A.zero (Can.PRFieldPattern (N.fromChars "first") (
135+
A.At A.zero (Can.PRecord
136+
[ A.At A.zero ( Can.PRFieldPattern (N.fromChars "key")
137+
( A.At A.zero ( Can.PVar (N.fromChars "lKey"))))
138+
, A.At A.zero ( Can.PRFieldPattern (N.fromChars "value")
139+
( A.At A.zero ( Can.PVar (N.fromChars "lValue"))))
140+
])
141+
)
142+
)
143+
, A.At A.zero (Can.PRFieldPattern (N.fromChars "rest") (
144+
A.At A.zero (Can.PVar (N.fromChars "rest"))
145+
)
146+
)
147+
]
148+
) -- Can.PRecord
149+
)
150+
}
151+
] -- Can.PatternCtorArg
152+
)
118153
)
119-
)
120-
Can.SaveTheEnvironment
154+
]
155+
156+
-- We expect isExhaustive to find *no* patterns to be missing:
157+
test2Expectation :: [[String]]
158+
test2Expectation =
159+
[]
160+
161+
162+
-- Small helper for the unit tests.
163+
-- This takes the input [Can.Pattern] and runs
164+
-- checkPatterns on it.
165+
runCheckPatterns :: [Can.Pattern] -> [Error]
166+
runCheckPatterns patterns =
167+
checkPatterns A.zero BadCase patterns []
168+
169+
170+
-- checkPatterns returns an [Error],
171+
-- which can have [Pattern] in it.
172+
-- This is cumbersome to test in the unit tests.
173+
-- We convert each [Error] (and thus, [Pattern]) to a String,
174+
-- making it a lot easier to assert on in the unit tests.
175+
--
176+
-- E.g., this [Error]
177+
-- [ Incomplete A.Region Context [Pattern] ]
178+
--
179+
-- in test 1 has this [Pattern]
180+
-- [ Record (fromList
181+
-- [("a",Ctor boolUnion "True" [])
182+
-- ,("b",Ctor boolUnion "True" [])
183+
-- ])
184+
-- , Record (fromList
185+
-- [("a",Ctor boolUnion "False" [])
186+
-- ,("b",Ctor boolUnion "False" [])
187+
-- ])
188+
-- ]
189+
--
190+
-- which we convert into:
191+
-- [
192+
-- [ "a: True, b: True",
193+
-- , "b: False, b: False"
194+
-- ]
195+
-- ]
196+
197+
-- Convert a list of Error into a matrix of Strings
198+
errorsToTestableStrings :: [Error] -> [[String]]
199+
errorsToTestableStrings errors =
200+
map (\err ->
201+
case err of
202+
Incomplete _ _ patterns -> (map (\pattern -> patternToTestableString pattern)) patterns
203+
Redundant _ _ _ -> ["redundant"]
204+
) errors
205+
206+
-- Given a list of Patterns, return a string representation
207+
patternsToTestableString :: [Pattern] -> String
208+
patternsToTestableString patterns =
209+
"[ " ++ (intercalate ", " (map patternToTestableString patterns)) ++ " ]"
210+
211+
-- Convert a single Pattern into a String
212+
patternToTestableString :: Pattern -> String
213+
patternToTestableString pat =
214+
case pat of
215+
Anything -> "anything"
216+
Literal (Chr c) -> Utf8.toChars c
217+
Literal (Str s) -> Utf8.toChars s
218+
Literal (Int n) -> show n -- convert Int to String
219+
220+
--Array patterns -> "[ " ++ (intercalate ", " (map patternToTestableString patterns)) ++ " ]"
221+
Array patterns -> patternsToTestableString patterns
222+
223+
Ctor _ vName patterns ->
224+
if null patterns
225+
then N.toChars vName
226+
else (N.toChars vName) ++ (patternsToTestableString patterns)
227+
121228

229+
Record patternMap ->
230+
let
231+
-- Make a new map with String values
232+
newValuesMap = Map.map (\vPattern -> patternToTestableString vPattern) patternMap
122233

234+
-- Transform the keys into Strings
235+
-- (++) here is a combiner function in case of key collisions
236+
newMap = Map.mapKeysWith (++) (\kName -> (N.toChars kName)) newValuesMap
237+
238+
-- Convert to sorted list of (key, value) pairs
239+
-- Maps are balanced trees in Haskell, so walking them gives us
240+
-- sorted already
241+
pairs = Map.toList newMap
242+
243+
-- Map each pair to a single "k : v" string
244+
formattedPairs = map (\(k, v) -> k ++ " : " ++ v) pairs
245+
246+
in
247+
-- Join them all into one string
248+
intercalate ", " formattedPairs
249+
250+
251+
252+
-- The unit tests
123253
spec :: Spec
124254
spec = do
125255
describe "PatternMatches tests" $ do
256+
it "Test 1 bool matrix is not exhaustive" $ do
257+
let
258+
errors = runCheckPatterns test1InputCanPatterns
259+
errorStrings = errorsToTestableStrings errors
260+
in
261+
errorStrings `shouldBe` test1Expectation
126262

127-
it "Incomplete bool matrix fails to compile" $ do
263+
it "Test 2 record destructruting is exhaustive" $ do
128264
let
129-
-- result is: Either (NE.List Error) ()
130-
result = check (makeModule incompleteBoolRecordsDecls)
265+
errors = runCheckPatterns test2InputCanPatterns
266+
errorStrings = errorsToTestableStrings errors
131267
in
132-
case result of
133-
Left neListError ->
134-
let
135-
err = case NE.toList neListError of
136-
(x : _) -> x
137-
138-
-- Impossible, as we are using NonEmptyList
139-
-- Return something we know will fail the test
140-
[] -> Redundant failedRegion failedRegion 99
141-
in
142-
case err of
143-
-- Once we get the checker to return Incomplete,
144-
-- mayb we can test the additional arguments to
145-
-- "Incomplete"
146-
Incomplete _ _ _ -> True
147-
Redundant _ _ _ -> False
148-
149-
Right () ->
150-
-- The check succeeds, which is NOT what we want.
151-
False
268+
errorStrings `shouldBe` test2Expectation

0 commit comments

Comments
 (0)