From a7b2d289c6f679c50a5badaeaf7ee660d4d0b8c9 Mon Sep 17 00:00:00 2001 From: Jost Berthold Date: Thu, 27 Jun 2024 20:47:43 +1000 Subject: [PATCH] add cases for unevaluated keys to MAP hooks (#3964) Some of the `MAP` hooks were missing cases for an unevaluated key argument (they were assuming that the argument would already be fully evaluated when the hook is called). In these cases, the hooks should typically return `Nothing` instead of returning a result. --------- Co-authored-by: github-actions --- booster/library/Booster/Builtin/MAP.hs | 7 +++++++ booster/unit-tests/Test/Booster/Builtin.hs | 24 ++++++++++++++++++++++ 2 files changed, 31 insertions(+) diff --git a/booster/library/Booster/Builtin/MAP.hs b/booster/library/Booster/Builtin/MAP.hs index 5bbec86a11..7a2465ec6f 100644 --- a/booster/library/Booster/Builtin/MAP.hs +++ b/booster/library/Booster/Builtin/MAP.hs @@ -58,6 +58,8 @@ mapUpdateHook args pure Nothing -- have opaque part, no result | any (not . isConstructorLike_ . fst) pairs -> pure Nothing -- have unevaluated keys, no result + | not $ isConstructorLike_ key -> + pure Nothing -- unevaluated update key, no result | otherwise -> -- key certain to be absent, no rest: add pair pure $ Just $ KMap def ((key, newValue) : pairs) Nothing | [_other, _, _] <- args = @@ -126,6 +128,8 @@ mapRemoveHook args pure Nothing -- have opaque part, no result | any (not . isConstructorLike_ . fst) pairs -> pure Nothing -- have unevaluated keys, no result + | not $ isConstructorLike_ key -> + pure Nothing -- remove key unevaluated, no result | otherwise -> -- key certain to be absent, no rest: map unchanged pure $ Just m | [_other, _] <- args = @@ -166,6 +170,8 @@ mapLookupOrDefaultHook args pure Nothing -- have opaque part, no result | any (not . isConstructorLike_ . fst) pairs -> pure Nothing -- have unevaluated keys, no result + | not $ isConstructorLike_ key -> + pure Nothing -- lookup key unevaluated, no result | otherwise -> -- certain that the key is not in the map pure $ Just defaultValue | [_other, _, _] <- args = @@ -188,6 +194,7 @@ mapInKeysHook args pure $ Just $ boolTerm True (False, False) | Nothing <- mbRest -- no opaque rest + , isConstructorLike_ key -- key to search is evaluated , null uneval'edKeys -> -- no keys unevaluated pure $ Just $ boolTerm False | otherwise -> -- key could be present once evaluated diff --git a/booster/unit-tests/Test/Booster/Builtin.hs b/booster/unit-tests/Test/Booster/Builtin.hs index d06979524e..8ebc4d1082 100644 --- a/booster/unit-tests/Test/Booster/Builtin.hs +++ b/booster/unit-tests/Test/Booster/Builtin.hs @@ -260,6 +260,10 @@ testMapUpdateHook = result <- runUpdate [Fixture.functionKMapWithOneItemAndRest, keyG, value2] let expected = mapWith [(keyG, value2)] (Just restVar) Just expected @=? result + , testCase "cannot update map at unevaluated key if key not syntactically present" $ do + let keyG = [trm| g{}() |] + result <- runUpdate [Fixture.concreteKMapWithTwoItems, keyG, value2] + Nothing @=? result , testCase "cannot update map with symbolic rest if key not present" $ do result <- runUpdate [Fixture.concreteKMapWithOneItemAndRest, key2, value2] Nothing @=? result @@ -376,6 +380,9 @@ testMapRemoveHook = Just Fixture.emptyKMap @=? result result2 <- runRemove [Fixture.functionKMapWithOneItemAndRest, [trm| g{}() |]] Just restVar @=? result2 + , testCase "no result if removing non-concrete keys not syntactically equal" $ do + result <- runRemove [Fixture.concreteKMapWithTwoItems, [trm| g{}() |]] + Nothing @=? result , testCase "no result when map has non-concrete syntactically different keys" $ do result <- runRemove [Fixture.functionKMapWithOneItem, key] Nothing @=? result @@ -449,6 +456,10 @@ testMapLookupHook = , testCase "returns item for a non-evaluated key when present" $ do result <- runLookup [Fixture.functionKMapWithOneItemAndRest, [trm| g{}() |]] Just [trm| \dv{SortTestKMapItem{}}("value") |] @=? result + , testProperty "no result for an unevaluated key not syntactically present" . property $ do + assocs <- forAll $ genAssocs (Range.linear 0 10) + result <- runLookup [mapWith assocs Nothing, [trm| g{}() |]] + Nothing === result , testCase "no result if map has non-evaluated keys when key not found" $ do result <- runLookup [Fixture.functionKMapWithOneItem, notAKey] Nothing @=? result @@ -494,6 +505,10 @@ testMapLookupOrDefaultHook = , testCase "returns item for a non-evaluated key when present" $ do result <- runLookup [Fixture.functionKMapWithOneItemAndRest, [trm| g{}() |], defItem] Just [trm| \dv{SortTestKMapItem{}}("value") |] @=? result + , testProperty "no result for an unevaluated key not syntactically present" . property $ do + assocs <- forAll $ genAssocs (Range.linear 0 10) + result <- runLookup [mapWith assocs Nothing, [trm| g{}() |], defItem] + Nothing === result , testCase "no result if map has non-evaluated keys and key not found" $ do result <- runLookup [Fixture.functionKMapWithOneItemAndRest, notAKey, defItem] Nothing @=? result @@ -532,11 +547,20 @@ testMapInKeysHook = Just (Builtin.boolTerm True) === result result2 <- runInKeys [key, mapWith assocs (Just restVar)] Just (Builtin.boolTerm True) === result2 + , testCase "returns true when key syntactically present" $ do + result <- runInKeys [[trm| g{}() |], Fixture.functionKMapWithOneItem] + Just (Builtin.boolTerm True) @=? result + result2 <- runInKeys [[trm| g{}() |], Fixture.functionKMapWithOneItemAndRest] + Just (Builtin.boolTerm True) @=? result2 , testCase "no result if unevaluated map keys present" $ do result <- runInKeys [notAKey, Fixture.functionKMapWithOneItem] Nothing @=? result result2 <- runInKeys [notAKey, Fixture.functionKMapWithOneItemAndRest] Nothing @=? result2 + , testProperty "no result for an unevaluated key not present" . property $ do + assocs <- forAll $ genAssocs (Range.linear 0 42) + result <- runInKeys [[trm| g{}() |], mapWith assocs Nothing] + Nothing === result ] where runInKeys :: MonadFail m => [Term] -> m (Maybe Term)