From 99a13f46b652ca69ffff585be6ab18ef55f9615b Mon Sep 17 00:00:00 2001 From: Li-yao Xia Date: Tue, 15 Nov 2022 20:38:13 +0000 Subject: [PATCH 01/12] Silence QuickCheck --- test/src/Data/Edison/Test/Utils.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/test/src/Data/Edison/Test/Utils.hs b/test/src/Data/Edison/Test/Utils.hs index d20fa18..3e87fbc 100644 --- a/test/src/Data/Edison/Test/Utils.hs +++ b/test/src/Data/Edison/Test/Utils.hs @@ -16,6 +16,7 @@ qcTest x = TestCase $ do stdArgs { maxSuccess = 100 , maxSize = 20 + , chatty = False } res <- quickCheckWithResult args x From 2ccdcfc2b29c772d83cb7fa5d794b1a7b619740d Mon Sep 17 00:00:00 2001 From: Li-yao Xia Date: Tue, 15 Nov 2022 22:37:35 +0000 Subject: [PATCH 02/12] test: Improve error reporting, run tests for longer --- test/src/Data/Edison/Test/Utils.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/test/src/Data/Edison/Test/Utils.hs b/test/src/Data/Edison/Test/Utils.hs index 3e87fbc..d942201 100644 --- a/test/src/Data/Edison/Test/Utils.hs +++ b/test/src/Data/Edison/Test/Utils.hs @@ -8,13 +8,14 @@ import Data.List (intersperse) import Test.QuickCheck import Test.QuickCheck.Test import Test.HUnit (runTestTT, Test(..),assertFailure) +import GHC.Stack (HasCallStack) -- | Turn a QuickCheck 'Testable' into an HUnit 'Test' -qcTest :: Testable a => a -> Test +qcTest :: (Testable a, HasCallStack) => a -> Test qcTest x = TestCase $ do let args = stdArgs - { maxSuccess = 100 + { maxSuccess = 1000 , maxSize = 20 , chatty = False } From f6a2a87959bcaecc501327f05c6febc6485a4af3 Mon Sep 17 00:00:00 2001 From: Li-yao Xia Date: Wed, 16 Nov 2022 00:31:55 +0000 Subject: [PATCH 03/12] test: Make prop_delete more likely to find a counterexample --- test/src/Data/Edison/Test/FM.hs | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/test/src/Data/Edison/Test/FM.hs b/test/src/Data/Edison/Test/FM.hs index c9eba8a..8303f34 100644 --- a/test/src/Data/Edison/Test/FM.hs +++ b/test/src/Data/Edison/Test/FM.hs @@ -11,6 +11,7 @@ import qualified Data.List as L import Data.Maybe import Test.QuickCheck hiding (elements, (===)) +import qualified Test.QuickCheck as QC import Test.HUnit (Test(..)) import Data.Edison.Test.Utils @@ -339,12 +340,15 @@ prop_unionSeq fm xss = keysList (unionSeq xss) == keysList (L.foldr union empty xss) prop_delete :: FMTest k Int fm => - fm Int -> k -> fm Int -> Bool -prop_delete fm k xs = + fm Int -> fm Int -> Property +prop_delete fm xs = forAll genKey $ \k -> L.sort (keysList (delete k xs)) == L.sort (L.filter (/=k) (keysList xs)) && delete k xs === deleteAll k xs + where + genKey | null xs = arbitrary + | otherwise = frequency [(1, arbitrary), (10, QC.elements (keysList xs))] prop_deleteSeq :: FMTest k Int fm => fm Int -> [k] -> fm Int -> Bool From de4dc26b3393be065df93c6b38388ce86893f128 Mon Sep 17 00:00:00 2001 From: Li-yao Xia Date: Wed, 16 Nov 2022 00:34:13 +0000 Subject: [PATCH 04/12] test: Simplify a constraint --- test/src/Data/Edison/Test/FM.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/test/src/Data/Edison/Test/FM.hs b/test/src/Data/Edison/Test/FM.hs index 8303f34..5490ea8 100644 --- a/test/src/Data/Edison/Test/FM.hs +++ b/test/src/Data/Edison/Test/FM.hs @@ -25,8 +25,7 @@ import qualified Data.Edison.Assoc.PatriciaLoMap as PLM -- A utility class to propagate class contexts down -- to the quick check properties -class (Ord k, Show k, Arbitrary k, - Arbitrary (fm a), Show (fm a), +class (Ord k, Show k, Arbitrary k, Show (fm a), Eq (fm a), FiniteMap fm k) => FMTest k a fm | fm -> k From 3c2c771b3334b260b26bea28472c9682805da60e Mon Sep 17 00:00:00 2001 From: Li-yao Xia Date: Wed, 16 Nov 2022 00:35:29 +0000 Subject: [PATCH 05/12] Tweak Arbitrary (TernaryTrie.FM k v) The goal is to increase the likelihood of finding bugs caused by a wrong balance factor by generating balanced trees directly instead of via fromSeq --- .../src/Data/Edison/Assoc/TernaryTrie.hs | 79 +++++++++++++++++-- 1 file changed, 72 insertions(+), 7 deletions(-) diff --git a/edison-core/src/Data/Edison/Assoc/TernaryTrie.hs b/edison-core/src/Data/Edison/Assoc/TernaryTrie.hs index adddaa4..3c0c6c1 100644 --- a/edison-core/src/Data/Edison/Assoc/TernaryTrie.hs +++ b/edison-core/src/Data/Edison/Assoc/TernaryTrie.hs @@ -60,12 +60,13 @@ import qualified Data.Edison.Seq as S import qualified Data.List as L import qualified Control.Monad.Fail as Fail import Control.Monad +import Data.Coerce (coerce) import Data.Monoid import Data.Semigroup as SG import Data.Maybe (isNothing) import Data.Edison.Assoc.Defaults -import Test.QuickCheck (Arbitrary(..), CoArbitrary(..), Gen(), variant) +import Test.QuickCheck (Arbitrary(..), CoArbitrary(..), Gen(), NonNegative(..), variant, sized, resize, choose, oneof) -- signatures for exported functions @@ -165,9 +166,11 @@ data FM k a data FMB k v = E | I !Int !k !(Maybe v) !(FMB k v) !(FMB' k v) !(FMB k v) + deriving Show newtype FMB' k v = FMB' (FMB k v) + deriving Show balance :: Int balance = 6 @@ -1132,8 +1135,11 @@ structuralInvariantFMB fmb@(I size k _ l (FMB' m) r) && keyInvariantFMB (k) r && actualSizeFMB fmb == size - && (sizel + sizer < 2 - || (sizel <= balance * sizer && sizer <= balance * sizel)) + && isBalanced l r + +isBalanced :: FMB k a -> FMB k a -> Bool +isBalanced l r = sizel + sizer <= 1 + || (sizel <= balance * sizer && sizer <= balance * sizel) where sizel = sizeFMB l sizer = sizeFMB r @@ -1141,10 +1147,13 @@ structuralInvariantFMB fmb@(I size k _ l (FMB' m) r) structuralInvariant :: Ord k => FM k a -> Bool structuralInvariant (FM _ fmb) = structuralInvariantFMB fmb - -instance (Ord k,Arbitrary k,Arbitrary a) => Arbitrary (FM k a) where - arbitrary = do (xs::[([k],a)]) <- arbitrary - return (Prelude.foldr (uncurry insert) empty xs) +-- | Generate weight-balanced trees either by direct recursion or via +-- 'fromSeq'. The former is much more likely to hit counterexamples to wrong +-- @balance@ coefficients. We keep the latter generator around just in case, +-- because it generates a more realistic distribution. +instance (Integral k, Arbitrary k, Arbitrary a) => Arbitrary (FM k a) where + arbitrary = oneof [genFM, fromSeq <$> (arbitrary :: Gen [([k], a)])] + shrink (FM v m) = [FM v m | (v, FMB' m) <- shrinkTuple shrink shrinkFMB' (v, FMB' m)] instance (Ord k,CoArbitrary k,CoArbitrary a) => CoArbitrary (FM k a) where coarbitrary (FM x fmb) = coarbitrary_maybe x . coarbitrary_fmb fmb @@ -1168,3 +1177,59 @@ instance Ord k => Monoid (FM k a) where mappend = (SG.<>) mconcat = unionSeq +-- Testing + +genFM :: (Integral k, Arbitrary a) => Gen (FM k a) +genFM = do + FM <$> arbitrary <*> genFMB_ + +-- Choose the number of elements in the top layer upfront, +-- and distribute it while recursing down. +genFMB_ :: (Integral k, Arbitrary a) => Gen (FMB k a) +genFMB_ = sized $ \sz -> do + n <- choose (0, sz) + resize (sz - n) (genFMB 0 n) + +-- Distribute the size @sz@ to generate the middle children of the nodes in the +-- top layer. +genFMB :: (Integral k, Arbitrary a) => Int -> Int -> Gen (FMB k a) +genFMB i 0 = pure E +genFMB i n = sized $ \sz -> do + let b = if n <= 2 then 0 else (n-1+balance) `div` (balance+1) + l <- choose (b, n-1-b) + z <- choose (0, sz) + let k = fromIntegral (i+l) + I n k + -- Ensure leaves (nodes with both E children) are nonempty. + <$> (if n == 1 then Just <$> arbitrary else arbitrary) + <*> resize z (genFMB i l) + <*> (FMB' <$> resize (min z (sz-z)) genFMB_) + <*> resize (sz - z) (genFMB (i+l+1) (n-l-1)) + +-- Be careful to preserve balance during shrinking. +shrinkFMB :: Arbitrary a => FMB k a -> [FMB k a] +shrinkFMB E = [] +shrinkFMB (I s k v l m r) = E : l : r : do + let (*-) = shrinkTuple ; infixr 3 *- + (v, (l, (m, r))) <- (shrinkJust *- shrinkFMB *- shrinkFMB' *- shrinkFMB) (v, (l, (m, r))) + let s = sizeFMB l + sizeFMB r + 1 + t = I s k v l m r + guard (isBalanced l r) + pure t + +shrinkFMB' :: Arbitrary a => FMB' k a -> [FMB' k a] +shrinkFMB' (FMB' m) = coerce $ + tailsFMB m ++ shrinkFMB m + +-- List the middle children of the top layer. +tailsFMB :: FMB k a -> [FMB k a] +tailsFMB E = [] +tailsFMB (I _ _ _ l (FMB' m) r) = m : tailsFMB l ++ tailsFMB r + +-- Don't remove elements +shrinkJust :: Arbitrary a => Maybe a -> [Maybe a] +shrinkJust Nothing = [] +shrinkJust (Just x) = Just <$> shrink x + +shrinkTuple :: (a -> [a]) -> (b -> [b]) -> (a, b) -> [(a, b)] +shrinkTuple sa sb (a, b) = [(a', b) | a' <- sa a] ++ [(a, b') | b' <- sb b] From c915c1c5a407801dd3285addaa0d6868c813b18d Mon Sep 17 00:00:00 2001 From: Li-yao Xia Date: Wed, 16 Nov 2022 00:39:59 +0000 Subject: [PATCH 06/12] Fix the balance factor for ternary tries --- edison-core/src/Data/Edison/Assoc/TernaryTrie.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/edison-core/src/Data/Edison/Assoc/TernaryTrie.hs b/edison-core/src/Data/Edison/Assoc/TernaryTrie.hs index 3c0c6c1..1510892 100644 --- a/edison-core/src/Data/Edison/Assoc/TernaryTrie.hs +++ b/edison-core/src/Data/Edison/Assoc/TernaryTrie.hs @@ -172,8 +172,11 @@ newtype FMB' k v = FMB' (FMB k v) deriving Show +-- | The balance factor must be either 3 or 4. +-- With other factors, the invariant gets broken by delete, minViewWithKey and maxViewWithKey. +-- (cf. Section 4 of the paper linked above) balance :: Int -balance = 6 +balance = 4 sizeFMB :: FMB k v -> Int sizeFMB E = 0 From 554938d09b899fbf974a689b00db0f3f161139c2 Mon Sep 17 00:00:00 2001 From: Li-yao Xia Date: Wed, 16 Nov 2022 00:50:35 +0000 Subject: [PATCH 07/12] Add some comments about ternary search tries --- .../src/Data/Edison/Assoc/TernaryTrie.hs | 26 ++++++++++++++++++- 1 file changed, 25 insertions(+), 1 deletion(-) diff --git a/edison-core/src/Data/Edison/Assoc/TernaryTrie.hs b/edison-core/src/Data/Edison/Assoc/TernaryTrie.hs index 1510892..210b278 100644 --- a/edison-core/src/Data/Edison/Assoc/TernaryTrie.hs +++ b/edison-core/src/Data/Edison/Assoc/TernaryTrie.hs @@ -7,7 +7,8 @@ -- Stability : stable -- Portability : GHC, Hugs (MPTC and FD) -- --- Finite maps implemented as ternary search tries +-- Finite maps indexed by lists or strings @[k]@, implemented as ternary +-- search tries module Data.Edison.Assoc.TernaryTrie ( -- * Type of ternary search tries @@ -163,6 +164,29 @@ moduleName = "Data.Edison.Assoc.TernaryTrie" data FM k a = FM !(Maybe a) !(FMB k a) +-- | This is isomorphic to an iteration of binary trees with keys @k@. +-- +-- @ +-- data BT k v = E | I k v (BT k v) (BT k v) +-- data Layer k v x = Layer (Maybe v) (BT k x) +-- +-- FMB k v = Fix (Layer k v) +-- @ +-- +-- The trees are weight-balanced trees, ensuring that the sizes of the +-- two subtrees of any node are bounded by each other up to a constant factor. +-- +-- @ +-- size l + size r <= 1 +-- +-- -- or -- +-- +-- size l <= 6 * size r +-- size r <= 6 * size l +-- @ +-- +-- Source: +-- by Hirai and Yamamoto, 2011 (Section 4) data FMB k v = E | I !Int !k !(Maybe v) !(FMB k v) !(FMB' k v) !(FMB k v) From dfee3eb280ab4987ccc7b286ff6628add3c5ed9d Mon Sep 17 00:00:00 2001 From: Li-yao Xia Date: Wed, 16 Nov 2022 01:29:34 +0000 Subject: [PATCH 08/12] Record the extra invariant for minView: other functions break it --- .../src/Data/Edison/Assoc/TernaryTrie.hs | 28 +++++++++++++------ 1 file changed, 19 insertions(+), 9 deletions(-) diff --git a/edison-core/src/Data/Edison/Assoc/TernaryTrie.hs b/edison-core/src/Data/Edison/Assoc/TernaryTrie.hs index 210b278..ca32cac 100644 --- a/edison-core/src/Data/Edison/Assoc/TernaryTrie.hs +++ b/edison-core/src/Data/Edison/Assoc/TernaryTrie.hs @@ -64,7 +64,7 @@ import Control.Monad import Data.Coerce (coerce) import Data.Monoid import Data.Semigroup as SG -import Data.Maybe (isNothing) +import Data.Maybe (isJust, isNothing) import Data.Edison.Assoc.Defaults import Test.QuickCheck (Arbitrary(..), CoArbitrary(..), Gen(), NonNegative(..), variant, sized, resize, choose, oneof) @@ -1155,7 +1155,7 @@ actualSizeFMB (I _ _ _ l _ r) = 1 + actualSizeFMB l + actualSizeFMB r structuralInvariantFMB :: Ord k => FMB k a -> Bool structuralInvariantFMB E = True -structuralInvariantFMB fmb@(I size k _ l (FMB' m) r) +structuralInvariantFMB fmb@(I size k v l (FMB' m) r) = structuralInvariantFMB l && structuralInvariantFMB m && structuralInvariantFMB r @@ -1163,6 +1163,7 @@ structuralInvariantFMB fmb@(I size k _ l (FMB' m) r) && keyInvariantFMB (>k) r && actualSizeFMB fmb == size && isBalanced l r + && relevantRoot fmb isBalanced :: FMB k a -> FMB k a -> Bool isBalanced l r = sizel + sizer <= 1 @@ -1171,6 +1172,11 @@ isBalanced l r = sizel + sizer <= 1 sizel = sizeFMB l sizer = sizeFMB r +-- | This invariant is used by minView +relevantRoot :: FMB k a -> Bool +relevantRoot (I _ _ Nothing _ (FMB' E) _) = False +relevantRoot _ = True + structuralInvariant :: Ord k => FM k a -> Bool structuralInvariant (FM _ fmb) = structuralInvariantFMB fmb @@ -1225,12 +1231,12 @@ genFMB i n = sized $ \sz -> do let b = if n <= 2 then 0 else (n-1+balance) `div` (balance+1) l <- choose (b, n-1-b) z <- choose (0, sz) + m <- resize (min z (sz-z)) genFMB_ + v <- case m of E -> Just <$> arbitrary ; _ -> arbitrary let k = fromIntegral (i+l) - I n k - -- Ensure leaves (nodes with both E children) are nonempty. - <$> (if n == 1 then Just <$> arbitrary else arbitrary) - <*> resize z (genFMB i l) - <*> (FMB' <$> resize (min z (sz-z)) genFMB_) + I n k v + <$> resize z (genFMB i l) + <*> pure (FMB' m) <*> resize (sz - z) (genFMB (i+l+1) (n-l-1)) -- Be careful to preserve balance during shrinking. @@ -1238,12 +1244,16 @@ shrinkFMB :: Arbitrary a => FMB k a -> [FMB k a] shrinkFMB E = [] shrinkFMB (I s k v l m r) = E : l : r : do let (*-) = shrinkTuple ; infixr 3 *- - (v, (l, (m, r))) <- (shrinkJust *- shrinkFMB *- shrinkFMB' *- shrinkFMB) (v, (l, (m, r))) + (v, (l, (m@(FMB' m'), r))) <- (shrinkJust *- shrinkFMB *- shrinkFMB' *- shrinkFMB) (v, (l, (m, r))) let s = sizeFMB l + sizeFMB r + 1 t = I s k v l m r - guard (isBalanced l r) + guard (isBalanced l r && (isJust v || not (nullFMB' m))) pure t +nullFMB' :: FMB' k v -> Bool +nullFMB' (FMB' E) = True +nullFMB' _ = False + shrinkFMB' :: Arbitrary a => FMB' k a -> [FMB' k a] shrinkFMB' (FMB' m) = coerce $ tailsFMB m ++ shrinkFMB m From ab649b91e8dd85e01db048faaebdcf93b730f1ca Mon Sep 17 00:00:00 2001 From: Li-yao Xia Date: Tue, 30 Dec 2025 21:32:51 +0100 Subject: [PATCH 09/12] Check invariant in prop_lookupAndDelete --- test/src/Data/Edison/Test/FM.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/test/src/Data/Edison/Test/FM.hs b/test/src/Data/Edison/Test/FM.hs index 5490ea8..acec0ea 100644 --- a/test/src/Data/Edison/Test/FM.hs +++ b/test/src/Data/Edison/Test/FM.hs @@ -392,8 +392,10 @@ prop_lookupAndDelete fm k xs = Just (z,zs) -> (lookup k xs == z) - && (lookupAndDelete k xs == (z,zs)) - && (lookupAndDeleteAll k xs == ([z],zs)) + && (lookupAndDelete k xs -== (z,zs)) + && (lookupAndDeleteAll k xs -== ([z],zs)) + where + (t, ts) -== (u, us) = t == u && ts === us prop_adjust :: FMTest k Int fm => fm Int -> k -> fm Int -> Bool From 8c4d365f0912ee1af2adad2ce1137cb4496d7620 Mon Sep 17 00:00:00 2001 From: Li-yao Xia Date: Tue, 30 Dec 2025 21:59:44 +0100 Subject: [PATCH 10/12] Also test minViewWithKey --- test/src/Data/Edison/Test/FM.hs | 21 ++++++++++++++------- 1 file changed, 14 insertions(+), 7 deletions(-) diff --git a/test/src/Data/Edison/Test/FM.hs b/test/src/Data/Edison/Test/FM.hs index acec0ea..77b6d67 100644 --- a/test/src/Data/Edison/Test/FM.hs +++ b/test/src/Data/Edison/Test/FM.hs @@ -489,13 +489,15 @@ prop_partition fm xs = prop_min :: OrdFMTest k Int fm => fm Int -> [(k,Int)] -> Bool prop_min fm xs = - case minView xs' of + case minViewWithKey xs' of Nothing -> null xs' - Just (z,zs) -> - snd min == z + Just ((k, z), zs) -> + min == (k, z) && minElem xs' == z && + minView xs' -== Just (z, zs) + && delete (fst min) xs' === zs && deleteMin xs' === zs @@ -504,17 +506,21 @@ prop_min fm xs = where xs' = (fromSeq (removeDups xs)) `asTypeOf` fm min = L.minimumBy (\x y -> compare (fst x) (fst y)) (removeDups xs) + Just (z, zs) -== Just (y, ys) = z == y && zs === ys + z -== y = z == y prop_max :: OrdFMTest k Int fm => fm Int -> [(k,Int)] -> Bool prop_max fm xs = - case maxView xs' of + case maxViewWithKey xs' of Nothing -> null xs' - Just (z,zs) -> - snd max == z + Just ((k, z), zs) -> + max == (k, z) && maxElem xs' == z && + maxView xs' -== Just (z, zs) + && delete (fst max) xs' === zs && deleteMax xs' === zs @@ -523,7 +529,8 @@ prop_max fm xs = where xs' = (fromSeq (removeDups xs)) `asTypeOf` fm max = L.maximumBy (\x y -> compare (fst x) (fst y)) (removeDups xs) - + Just (z, zs) -== Just (y, ys) = z == y && zs === ys + z -== y = z == y prop_foldr :: OrdFMTest k Int fm => fm Int -> [(k,Int)] -> Bool From 0757e7066c98a057f6f8bbae0de3ec33602b30ee Mon Sep 17 00:00:00 2001 From: Li-yao Xia Date: Tue, 30 Dec 2025 22:03:30 +0100 Subject: [PATCH 11/12] TernaryTrie: Remove nodes that violate relevantRoot invariant --- .../src/Data/Edison/Assoc/TernaryTrie.hs | 54 ++++++++++++++----- 1 file changed, 41 insertions(+), 13 deletions(-) diff --git a/edison-core/src/Data/Edison/Assoc/TernaryTrie.hs b/edison-core/src/Data/Edison/Assoc/TernaryTrie.hs index ca32cac..6c966e9 100644 --- a/edison-core/src/Data/Edison/Assoc/TernaryTrie.hs +++ b/edison-core/src/Data/Edison/Assoc/TernaryTrie.hs @@ -221,21 +221,27 @@ lookupFMB nk@(x:xs) (I _ k v l (FMB' fmbm) r) GT -> lookupFMB nk r EQ -> if L.null xs then v else lookupFMB xs fmbm -listToFMB :: [k] -> (Maybe v -> Maybe v) -> FMB k v -listToFMB [x] fv = mkFMB x (fv Nothing) E (FMB' E) E -listToFMB (x:xs) fv = mkFMB x Nothing E (FMB' $ listToFMB xs fv) E +listToFMB :: [k] -> v -> FMB k v +listToFMB [x] v = mkFMB x (Just v) E (FMB' E) E +listToFMB (x:xs) v = mkFMB x Nothing E (FMB' $ listToFMB xs v) E listToFMB _ _ = error "TernaryTrie.listToFMB: bug!" addToFMB :: (Ord k) => [k] -> (Maybe v -> Maybe v) -> FMB k v -> FMB k v addToFMB xs combiner E - = listToFMB xs combiner + = case combiner Nothing of + Just v -> listToFMB xs v + Nothing -> E addToFMB nk@(x:xs) combiner (I size k v l m@(FMB' fmbm) r) = case compare x k of LT -> mkBalancedFMB k v (addToFMB nk combiner l) m r GT -> mkBalancedFMB k v l m (addToFMB nk combiner r) EQ -> case xs of - [] -> I size k (combiner v) l m r - _ -> I size k v l (FMB' $ addToFMB xs combiner fmbm) r + [] -> case combiner v of + Nothing | FMB' E <- m -> appendFMB l r + v' -> I size k v' l m r + _ -> case addToFMB xs combiner fmbm of + E | Nothing <- v -> appendFMB l r + m' -> I size k v l (FMB' m') r addToFMB _ _ _ = error "TernaryTrie.addToFMB: bug!" addToFM :: (Ord k) => [k] -> (Maybe v -> Maybe v) -> FM k v -> FM k v @@ -256,7 +262,9 @@ lookupAndDelFromFMB onFail cont nk@(x:xs) (I size k v l m@(FMB' fmbm) r) Just w -> case fmbm of E -> cont w (appendFMB l r) _ -> cont w (I size k Nothing l m r) - _ -> lookupAndDelFromFMB onFail (\w m' -> cont w (I size k v l (FMB' m') r)) xs fmbm + _ -> lookupAndDelFromFMB onFail (\w m' -> case m' of + E | Nothing <- v -> cont w (appendFMB l r) + _ -> cont w (I size k v l (FMB' m') r)) xs fmbm lookupAndDelFromFMB _ _ _ _ = error "TernaryTrie.lookupAndDelFromFMB: bug!" lookupAndDelFromFM :: (Ord k) => z -> (v -> FM k v -> z) -> [k] -> FM k v -> z @@ -277,7 +285,9 @@ delFromFMB nk@(x:xs) (I size k v l m@(FMB' fmbm) r) [] -> case fmbm of E -> appendFMB l r _ -> I size k Nothing l m r - _ -> I size k v l (FMB' $ delFromFMB xs fmbm) r + _ -> case delFromFMB xs fmbm of + E | Nothing <- v -> appendFMB l r + m' -> I size k v l (FMB' m') r delFromFMB _ _ = error "TernaryTrie.delFromFMB: bug!" @@ -334,6 +344,8 @@ mkBalancedFMB k v l m r mkVBalancedFMB :: k -> Maybe v -> FMB k v -> FMB' k v -> FMB k v -> FMB k v +mkVBalancedFMB k Nothing l (FMB' E) r + = appendFMB l r mkVBalancedFMB k v E m E = mkFMB k v E m E mkVBalancedFMB k v l@E m (I _ kr vr rl rm rr) @@ -527,7 +539,7 @@ mergeKVFM f (FM vx fmbx) (FM vy fmby) empty = FM Nothing E singleton [] v = FM (Just v) E -singleton xs v = FM Nothing (listToFMB xs (\_ -> Just v)) +singleton xs v = FM Nothing (listToFMB xs v) fromSeq = fromSeqUsingInsertSeq @@ -888,7 +900,11 @@ intersectionWithKey f minViewFMB :: Fail.MonadFail m => FMB k a -> (FMB k a -> FM k a) -> m (a, FM k a) minViewFMB E _ = fail $ moduleName++".minView: empty map" -minViewFMB (I i k (Just v) E m r) f = return (v, f (I i k Nothing E m r)) +minViewFMB (I i k (Just v) E m r) f = return (v, f t) + where + t = case m of + FMB' E -> r + _ -> I i k Nothing E m r minViewFMB (I _ _ Nothing E (FMB' E) _) _ = error $ moduleName++".minView: bug!" minViewFMB (I _ k Nothing E (FMB' m) r) f = minViewFMB m (\m' -> f (mkVBalancedFMB k Nothing E (FMB' m') r)) minViewFMB (I _ k mv l m r) f = minViewFMB l (\l' -> f (mkVBalancedFMB k mv l' m r)) @@ -899,7 +915,11 @@ minView (FM Nothing fmb) = minViewFMB fmb (FM Nothing) minViewWithKeyFMB :: Fail.MonadFail m => FMB k a -> ([k] -> [k]) -> (FMB k a -> FM k a) -> m (([k],a),FM k a) minViewWithKeyFMB E _ _ = fail $ moduleName++".minView: empty map" -minViewWithKeyFMB (I i k (Just v) E m r) kf f = return ((kf [k],v),f (I i k Nothing E m r)) +minViewWithKeyFMB (I i k (Just v) E m r) kf f = return ((kf [k],v),f t) + where + t = case m of + FMB' E -> r + _ -> I i k Nothing E m r minViewWithKeyFMB (I _ _ Nothing E (FMB' E) _) _ _ = error $ moduleName++".minViewWithKey: bug!" minViewWithKeyFMB (I _ k Nothing E (FMB' m) r) kf f = minViewWithKeyFMB m (kf . (k:)) (\m' -> f (mkVBalancedFMB k Nothing E (FMB' m') r)) @@ -942,7 +962,11 @@ maxViewFMB :: Fail.MonadFail m => FMB k a -> (FMB k a -> FM k a) -> m (a, FM k a maxViewFMB (I _ _ (Just v) l (FMB' E) E) f = return (v, f l) --maxViewFMB (I i k (Just v) l (FMB' E) E) f = return (v, f (I i k Nothing l (FMB' E) E)) maxViewFMB (I _ _ Nothing _ (FMB' E) E) _ = error $ moduleName++".maxView: bug!" -maxViewFMB (I i k mv l (FMB' m) E) f = maxViewFMB m (\m' -> f (I i k mv l (FMB' m') E)) +maxViewFMB (I i k mv l (FMB' m) E) f = maxViewFMB m (\m' -> f (t m')) + where + t m' = case m' of + E | Nothing <- mv -> l + _ -> I i k mv l (FMB' m') E maxViewFMB (I _ k mv l m r) f = maxViewFMB r (\r' -> f (mkVBalancedFMB k mv l m r')) maxViewFMB E _ = error $ moduleName++".maxView: bug!" @@ -956,7 +980,11 @@ maxViewWithKeyFMB :: Monad m => FMB k a -> ([k] -> [k]) -> (FMB k a -> FM k a) - maxViewWithKeyFMB (I _ k (Just v) l (FMB' E) E) kf f = return ((kf [k],v),f l) maxViewWithKeyFMB (I _ _ Nothing _ (FMB' E) E) _ _ = error $ moduleName++".maxViewWithKey: bug!" maxViewWithKeyFMB (I i k mv l (FMB' m) E) kf f = maxViewWithKeyFMB m (kf . (k:)) - (\m' -> f (I i k mv l (FMB' m') E)) + (\m' -> f (t m')) + where + t m' = case m' of + E | Nothing <- mv -> l + _ -> I i k mv l (FMB' m') E maxViewWithKeyFMB (I _ k mv l m r) kf f = maxViewWithKeyFMB r kf (\r' -> f (mkVBalancedFMB k mv l m r')) maxViewWithKeyFMB E _ _ = error $ moduleName++".maxViewWithKey: bug!" From 1e38464eedccef5df12bdb2aadfbb3f24bc2db64 Mon Sep 17 00:00:00 2001 From: Li-yao Xia Date: Tue, 30 Dec 2025 22:09:59 +0100 Subject: [PATCH 12/12] Make testSuite into an actual test suite --- test/Edison-test.cabal | 3 ++- test/src/Main.hs | 5 ++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/test/Edison-test.cabal b/test/Edison-test.cabal index 752be6b..054bbfd 100644 --- a/test/Edison-test.cabal +++ b/test/Edison-test.cabal @@ -14,7 +14,8 @@ Source-Repository head Location: https://github.com/robdockins/edison/ Subdir: test -Executable testSuite +test-suite testSuite + type: exitcode-stdio-1.0 Main-Is: Main.hs Other-modules: Data.Edison.Test.Bag diff --git a/test/src/Main.hs b/test/src/Main.hs index 765cf0c..be8418b 100644 --- a/test/src/Main.hs +++ b/test/src/Main.hs @@ -6,6 +6,5 @@ module Main where import Test.HUnit import Data.Edison.Test.Driver -main = do - runTestTT edisonTests - return () +main :: IO () +main = runTestTTAndExit edisonTests