diff --git a/compiler/src/Gren/Package.hs b/compiler/src/Gren/Package.hs index 0265f82b..d4e318d2 100644 --- a/compiler/src/Gren/Package.hs +++ b/compiler/src/Gren/Package.hs @@ -50,7 +50,7 @@ import Parse.Primitives qualified as P import Reporting.Suggest qualified as Suggest import System.FilePath (()) --- PACKGE NAMES +-- PACKAGE NAMES data Name = Name { _author :: !Author, diff --git a/compiler/src/Nitpick/PatternMatches.hs b/compiler/src/Nitpick/PatternMatches.hs index 0fd0d90c..456104e9 100644 --- a/compiler/src/Nitpick/PatternMatches.hs +++ b/compiler/src/Nitpick/PatternMatches.hs @@ -7,6 +7,7 @@ module Nitpick.PatternMatches Context (..), Pattern (..), Literal (..), + checkPatterns, ) where @@ -252,21 +253,20 @@ isExhaustive matrix n = (:) Anything <$> isExhaustive (Maybe.mapMaybe specializeRowByAnything matrix) (n - 1) Just baseRecord -> - let fieldNames = Map.keys baseRecord - - isAltExhaustive fieldName = - map (asRecordPattern fieldName) $ - isExhaustive - (Maybe.mapMaybe (specializeRowByRecordField fieldName) matrix) - n - - asRecordPattern fieldName ptn = - case ptn of - firstValue : _ -> - [Record $ Map.singleton fieldName firstValue] - _ -> - ptn - in concatMap isAltExhaustive fieldNames + -- Treat records as a product of fields (cartesian combination), + -- not each field independently. + let fieldCount = Map.size baseRecord + baseFieldsInOrder = Map.keys baseRecord + + -- Rebuild a record from the first `fieldCount` patterns in a counterexample row + recoverRecord :: [Pattern] -> [Pattern] + recoverRecord patterns = + let (fieldPats, rest) = splitAt fieldCount patterns + in Record (Map.fromList (zip baseFieldsInOrder fieldPats)) : rest + in map recoverRecord $ + isExhaustive + (Maybe.mapMaybe (specializeRowByRecord baseRecord) matrix) + (fieldCount + n - 1) else let alts@(Can.Union _ altList numAlts _) = snd (Map.findMin ctors) in if numSeen < numAlts @@ -429,29 +429,6 @@ specializeRowByRecord baseMap row = [] -> error "Compiler error! Empty matrices should not get specialized." --- INVARIANT: (length row == N) ==> (length result == arity + N - 1) -specializeRowByRecordField :: Name.Name -> [Pattern] -> Maybe [Pattern] -specializeRowByRecordField fieldName row = - case row of - Ctor _ _ _ : _ -> - Nothing - Anything : patterns -> - Just (Anything : patterns) - Array _ : _ -> - Nothing - Record namedPatterns : patterns -> - case Map.lookup fieldName namedPatterns of - Just pattern -> - Just (pattern : patterns) - Nothing -> - Nothing - Literal _ : _ -> - error $ - "Compiler bug! After type checking, constructors and literals\ - \ should never align in pattern match exhaustiveness checks." - [] -> - error "Compiler error! Empty matrices should not get specialized." - -- INVARIANT: (length row == N) ==> (length result == N-1) specializeRowByLiteral :: Literal -> [Pattern] -> Maybe [Pattern] specializeRowByLiteral literal row = diff --git a/gren.cabal b/gren.cabal index af55bd25..112f9c7d 100644 --- a/gren.cabal +++ b/gren.cabal @@ -248,6 +248,7 @@ Test-Suite gren-tests -- tests Generate.VLQSpec + Nitpick.PatternMatchesSpec Parse.AliasSpec Parse.RecordUpdateSpec Parse.SpaceSpec @@ -258,6 +259,7 @@ Test-Suite gren-tests Build-Depends: gren:common, base >= 4.19 && <5, + containers >= 0.6 && < 0.7, utf8-string, bytestring >= 0.11 && < 0.12, hspec >= 2.7.10 && < 3 diff --git a/tests/Nitpick/PatternMatchesSpec.hs b/tests/Nitpick/PatternMatchesSpec.hs new file mode 100644 index 00000000..699aac9f --- /dev/null +++ b/tests/Nitpick/PatternMatchesSpec.hs @@ -0,0 +1,270 @@ +module Nitpick.PatternMatchesSpec (spec) where + +import AST.Canonical (Pattern_) +import AST.Canonical qualified as Can +import Data.Index qualified as Index +import Data.List (intercalate) +import Data.Map qualified as Map +import Data.Name qualified as N +import Data.Utf8 qualified as Utf8 +import Gren.ModuleName qualified as ModuleName +import Gren.Package qualified as Pkg +import Nitpick.PatternMatches + ( Context (..), + Error (..), + Literal (..), + Pattern (..), + checkPatterns, + ) +import Reporting.Annotation qualified as A +import Test.Hspec (Spec, describe, it, shouldBe) + +-- Create a Can.Union for Bool +boolUnion :: Can.Union +boolUnion = + Can.Union + { Can._u_vars = [], + Can._u_alts = + [ Can.Ctor (N.fromChars "True") (Index.first) 0 [], + Can.Ctor (N.fromChars "False") (Index.next (Index.first)) 0 [] + ], + Can._u_numAlts = 2, + Can._u_opts = Can.Enum + } + +-- Create a Can.Union for Maybe +maybeUnion :: Can.Union +maybeUnion = + Can.Union + { Can._u_vars = [(N.fromChars "a")], + Can._u_alts = + [ Can.Ctor (N.fromChars "Just") (Index.first) 1 [Can.TVar (N.fromChars "a")], + Can.Ctor (N.fromChars "Nothing") (Index.next (Index.first)) 0 [] + ], + Can._u_numAlts = 2, + Can._u_opts = Can.Normal + } + +-- Create a Pattern_ that is a PCtor for Maybe +maybePCtor :: Bool -> [Can.PatternCtorArg] -> Pattern_ +maybePCtor isJust args = + Can.PCtor + { Can._p_home = + ModuleName.Canonical + (Pkg.Name (Utf8.fromChars "core") (Utf8.fromChars "gren-lang")) + (Utf8.fromChars "Maybe"), + Can._p_type = (N.fromChars "Maybe"), + Can._p_union = maybeUnion, + Can._p_name = if isJust then (N.fromChars "Just") else (N.fromChars "Nothing"), + Can._p_index = if isJust then Index.first else (Index.next (Index.first)), + Can._p_args = args + } + +{- +Test 1: Incomplete Bool Records + +This is the original case reported by marias. It exercises +a bug in the compiler. + +fn r = + when r is + { a = False, b = True } -> 1 + { a = True, b = False } -> 2 +-} + +-- These are the Can.Patterns produced by the parser and checkCases +test1InputCanPatterns :: [Can.Pattern] +test1InputCanPatterns = + [ ( A.At + A.zero + ( Can.PRecord + [ A.At A.zero (Can.PRFieldPattern (N.fromChars "a") (A.At A.zero (Can.PBool boolUnion False))), + A.At A.zero (Can.PRFieldPattern (N.fromChars "b") (A.At A.zero (Can.PBool boolUnion True))) + ] + ) + ), + ( A.At + A.zero + ( Can.PRecord + [ A.At A.zero (Can.PRFieldPattern (N.fromChars "a") (A.At A.zero (Can.PBool boolUnion True))), + A.At A.zero (Can.PRFieldPattern (N.fromChars "b") (A.At A.zero (Can.PBool boolUnion False))) + ] + ) + ) + ] + +-- We expect isExhaustive to find these patterns as missing: +-- It finds 1 Error, which has 2 strings, one for each missing pattern +test1Expectation :: [[String]] +test1Expectation = + [ [ "a : True, b : True", + "a : False, b : False" + ] + ] + +{- +Test 2: Record destructuring, as seen in core.git's Dict.gren + +After an incorrect fix for test1 by gilbertr, this case was found +to need extra handling. It *is* exhaustive, but the incorrect fix +found it to be non-exhaustive. + +fn r = + when r is + Nothing -> "Nothing" + Just { first = { key = lKey, value = lValue }, rest } -> lKey +-} + +-- These are the Can.Patterns produced by the parser and checkCases +test2InputCanPatterns :: [Can.Pattern] +test2InputCanPatterns = + [ (A.At A.zero (maybePCtor False [])), + ( A.At + A.zero + ( maybePCtor + True + [ Can.PatternCtorArg + { Can._index = Index.first, + Can._type = Can.TVar (N.fromChars "a"), + Can._arg = + ( A.At + A.zero + ( Can.PRecord + [ A.At + A.zero + ( Can.PRFieldPattern + (N.fromChars "first") + ( A.At + A.zero + ( Can.PRecord + [ A.At + A.zero + ( Can.PRFieldPattern + (N.fromChars "key") + (A.At A.zero (Can.PVar (N.fromChars "lKey"))) + ), + A.At + A.zero + ( Can.PRFieldPattern + (N.fromChars "value") + (A.At A.zero (Can.PVar (N.fromChars "lValue"))) + ) + ] + ) + ) + ), + A.At + A.zero + ( Can.PRFieldPattern + (N.fromChars "rest") + ( A.At A.zero (Can.PVar (N.fromChars "rest")) + ) + ) + ] + ) -- Can.PRecord + ) + } + ] -- Can.PatternCtorArg + ) + ) + ] + +-- We expect isExhaustive to find *no* patterns to be missing: +test2Expectation :: [[String]] +test2Expectation = + [] + +-- Small helper for the unit tests. +-- This takes the input [Can.Pattern] and runs +-- checkPatterns on it. +runCheckPatterns :: [Can.Pattern] -> [Error] +runCheckPatterns patterns = + checkPatterns A.zero BadCase patterns [] + +-- checkPatterns returns an [Error], +-- which can have [Pattern] in it. +-- This is cumbersome to test in the unit tests. +-- We convert each Error (and thus, [Pattern]) to a [String], +-- making it a lot easier to assert on in the unit tests. +-- +-- E.g., this [Error] +-- [ Incomplete A.Region Context [Pattern] ] +-- +-- in test 1 has this [Pattern] +-- [ Record (fromList +-- [("a",Ctor boolUnion "True" []) +-- ,("b",Ctor boolUnion "True" []) +-- ]) +-- , Record (fromList +-- [("a",Ctor boolUnion "False" []) +-- ,("b",Ctor boolUnion "False" []) +-- ]) +-- ] +-- +-- which we convert into: +-- [ +-- [ "a: True, b: True", +-- , "b: False, b: False" +-- ] +-- ] + +-- Convert a list of Error into a matrix of Strings +errorsToTestableStrings :: [Error] -> [[String]] +errorsToTestableStrings errors = + map + ( \err -> + case err of + Incomplete _ _ patterns -> (map (\pattern -> patternToTestableString pattern)) patterns + Redundant _ _ _ -> ["redundant"] + ) + errors + +-- Given a list of Patterns, return a string representation +patternsToTestableString :: [Pattern] -> String +patternsToTestableString patterns = + "[ " ++ (intercalate ", " (map patternToTestableString patterns)) ++ " ]" + +-- Convert a single Pattern into a String +patternToTestableString :: Pattern -> String +patternToTestableString pat = + case pat of + Anything -> "anything" + Literal (Chr c) -> Utf8.toChars c + Literal (Str s) -> Utf8.toChars s + Literal (Int n) -> show n -- convert Int to String + Array patterns -> patternsToTestableString patterns + Ctor _ vName patterns -> + if null patterns + then N.toChars vName + else (N.toChars vName) ++ (patternsToTestableString patterns) + Record patternMap -> + let -- Make a new map with String values + newValuesMap = Map.map (\vPattern -> patternToTestableString vPattern) patternMap + + -- Transform the keys into Strings + -- (++) here is a combiner function in case of key collisions + newMap = Map.mapKeysWith (++) (\kName -> (N.toChars kName)) newValuesMap + + -- Convert to sorted list of (key, value) pairs + -- Maps are balanced trees in Haskell, so walking them gives us + -- sorted already + pairs = Map.toList newMap + + -- Map each pair to a single "k : v" string + formattedPairs = map (\(k, v) -> k ++ " : " ++ v) pairs + in -- Join them all into one string + intercalate ", " formattedPairs + +-- The unit tests +spec :: Spec +spec = do + describe "PatternMatches tests" $ do + it "Test 1 bool matrix is not exhaustive" $ do + let errors = runCheckPatterns test1InputCanPatterns + errorStrings = errorsToTestableStrings errors + in errorStrings `shouldBe` test1Expectation + + it "Test 2 record destructruting is exhaustive" $ do + let errors = runCheckPatterns test2InputCanPatterns + errorStrings = errorsToTestableStrings errors + in errorStrings `shouldBe` test2Expectation