bytestring-trie 0.2.5.3 → 0.2.6
raw patch · 9 files changed
+1731/−267 lines, 9 filesdep +QuickCheckdep +bytestring-triedep +smallcheckPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: QuickCheck, bytestring-trie, smallcheck, tasty, tasty-hunit, tasty-quickcheck, tasty-smallcheck
API changes (from Hackage documentation)
- Data.Trie.Internal: adjustBy :: (ByteString -> a -> a -> a) -> ByteString -> a -> Trie a -> Trie a
+ Data.Trie: adjustBy :: (ByteString -> a -> a -> a) -> ByteString -> a -> Trie a -> Trie a
+ Data.Trie: deleteSubmap :: ByteString -> Trie a -> Trie a
+ Data.Trie: intersectBy :: (a -> b -> Maybe c) -> Trie a -> Trie b -> Trie c
+ Data.Trie: intersectL :: Trie a -> Trie b -> Trie a
+ Data.Trie: intersectR :: Trie a -> Trie b -> Trie b
+ Data.Trie: minMatch :: Trie a -> ByteString -> Maybe (ByteString, a, ByteString)
+ Data.Trie.Convenience: intersectWith :: (a -> b -> c) -> Trie a -> Trie b -> Trie c
+ Data.Trie.Convenience: intersectWith' :: (a -> b -> c) -> Trie a -> Trie b -> Trie c
+ Data.Trie.Internal: adjust :: (a -> a) -> ByteString -> Trie a -> Trie a
+ Data.Trie.Internal: cata :: (ByteString -> a -> b -> b) -> (ByteString -> [b] -> b) -> b -> Trie a -> b
+ Data.Trie.Internal: cata_ :: (ByteString -> Maybe a -> b -> b) -> (b -> b -> b) -> b -> Trie a -> b
+ Data.Trie.Internal: intersectBy :: (a -> b -> Maybe c) -> Trie a -> Trie b -> Trie c
- Data.Trie.Internal: alterBy_ :: (ByteString -> a -> Maybe a -> Trie a -> (Maybe a, Trie a)) -> ByteString -> a -> Trie a -> Trie a
+ Data.Trie.Internal: alterBy_ :: (Maybe a -> Trie a -> (Maybe a, Trie a)) -> ByteString -> Trie a -> Trie a
Files
- CHANGELOG +13/−0
- README.md +8/−2
- bytestring-trie.cabal +29/−3
- src/Data/Trie.hs +60/−21
- src/Data/Trie/ByteStringInternal.hs +2/−2
- src/Data/Trie/Convenience.hs +27/−16
- src/Data/Trie/Internal.hs +431/−223
- test/Main.hs +841/−0
- test/Utils.hs +320/−0
CHANGELOG view
@@ -1,3 +1,16 @@+0.2.6 (2021.11.22):+ - Adjusting the instances for Applicative/Monad and Monoid, to+ avoid warnings from GHC 9.2.1 regarding:+ <https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return>+ <https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/semigroup-monoid>+ - Documented the order of results for `matches`/`matches_`+ - Added Data.Trie.minMatch+ - Added Data.Trie.Internal.{cata,cata_}+ - Added intersection functions (HT: Kevin Brubeck Unhammer)+ - Added Data.Trie.deleteSubmap (HT: YongJoon Joe)+ - Fixed a bug in mergeBy+ - Numerous minor tweaks with smart-constructors+ - Greatly increased code-coverage of the test suite 0.2.5.3 (2021.11.02): - Increasing upper bounds for GHC 9.2.1 0.2.5.2 (2021.10.16):
README.md view
@@ -33,11 +33,17 @@ ## Portability The implementation is quite portable, relying only on a few basic-language extensions. The complete list of extensions used is:+language extensions. The complete list of extensions used by the library is: * CPP-* MagicHash +* MagicHash -- Only if using GHC * NoImplicitPrelude++The test suite uses a few additional extensions:++* MultiParamTypeClasses+* FlexibleInstances+* FlexibleContexts ## Links
bytestring-trie.cabal view
@@ -1,5 +1,5 @@ ------------------------------------------------------------------- wren gayle romano <wren@cpan.org> ~ 2021.11.02+-- wren gayle romano <wren@cpan.org> ~ 2021.11.14 ---------------------------------------------------------------- -- Cabal >=1.10 is required by Hackage.@@ -7,7 +7,7 @@ Build-Type: Simple Name: bytestring-trie-Version: 0.2.5.3+Version: 0.2.6 Stability: provisional Homepage: https://wrengr.org/software/hackage.html Bug-Reports: https://github.com/wrengr/bytestring-trie/issues@@ -75,6 +75,32 @@ Build-Depends: base >= 4.5 && < 4.17 , bytestring >= 0.9.2 && < 0.12 , binary >= 0.5.1 && < 0.11- ++----------------------------------------------------------------+-- See the cabao file for bytestring-lexing for more info about Tasty.+Test-Suite test-all+ Default-Language: Haskell2010+ Hs-Source-Dirs: test+ Type: exitcode-stdio-1.0+ -- HACK: main-is must *not* have ./test/ like it does for executables!+ Main-Is: Main.hs+ Other-Modules: Utils+ -- ByteStringInternal+ -- We must include this library in order for the tests to use+ -- it; but we must not give a version restriction lest Cabal+ -- give warnings.+ Build-Depends: base >= 4.5 && < 4.17+ , bytestring >= 0.9.2 && < 0.12+ , binary >= 0.5.1 && < 0.11+ , bytestring-trie+ , tasty >= 0.10.1.2 && < 1.5+ , tasty-smallcheck >= 0.8.0.1 && < 0.9+ , tasty-quickcheck >= 0.8.3.2 && < 0.11+ -- N.B., "tasty-hunit" is just a partial API clone; whereas "tasty-hunit-compat" is a proper integration with HUnit itself. Also, tasty-hunit-compat actually depends on tasty-hunit; if you're wanting to minimize dependencies.+ , tasty-hunit < 0.11+ , QuickCheck >= 2.10 && < 2.15+ , smallcheck >= 1.1.1 && < 1.3+ -- lazysmallcheck >= 0.6 && < 0.7+ ---------------------------------------------------------------- ----------------------------------------------------------- fin.
src/Data/Trie.hs view
@@ -2,7 +2,7 @@ {-# OPTIONS_GHC -Wall -fwarn-tabs -fno-warn-unused-imports #-} {-# LANGUAGE NoImplicitPrelude #-} ------------------------------------------------------------------- ~ 2021.10.17+-- ~ 2021.11.22 -- | -- Module : Data.Trie -- Copyright : Copyright (c) 2008--2021 wren gayle romano@@ -45,13 +45,14 @@ , fromList, toListBy, toList, keys, elems -- * Query functions- , lookupBy, lookup, member, submap, match, matches+ , lookupBy, lookup, member, submap, match, minMatch, matches - -- * Single-value modification- , alterBy, insert, adjust, delete+ -- * Simple modification+ , insert, adjust, adjustBy, alterBy, delete, deleteSubmap -- * Combining tries , mergeBy, unionL, unionR+ , intersectBy, intersectL, intersectR -- * Mapping functions , mapBy, filterMap@@ -61,7 +62,6 @@ import qualified Prelude (null, lookup) import Data.Trie.Internal-import Data.Trie.Errors (impossible) import Data.ByteString (ByteString) import qualified Data.ByteString as S import Data.Maybe (isJust)@@ -111,7 +111,7 @@ -- | Return the value associated with a query string if it exists. lookup :: ByteString -> Trie a -> Maybe a {-# INLINE lookup #-}-lookup = lookupBy_ const Nothing (const Nothing)+lookup = lookupBy const -- TODO? move to "Data.Trie.Convenience"? -- | Does a string have a value in the trie?@@ -121,8 +121,8 @@ -- | Given a query, find the longest prefix with an associated value--- in the trie, returning that prefix, it's value, and the remaining--- string.+-- in the trie, and return that prefix, it's value, and the remainder+-- of the query. match :: Trie a -> ByteString -> Maybe (ByteString, a, ByteString) match t q = case match_ t q of@@ -131,10 +131,21 @@ case S.splitAt n q of (p,q') -> Just (p, x, q') +-- | Given a query, find the shortest prefix with an associated value+-- in the trie, and return that prefix, it's value, and the remainder+-- of the query.+--+-- @since 0.2.6+minMatch :: Trie a -> ByteString -> Maybe (ByteString, a, ByteString)+minMatch t q =+ case matches t q of+ [] -> Nothing+ x:_ -> Just x -- | Given a query, find all prefixes with associated values in the--- trie, returning the prefixes, their values, and their remaining--- strings. This function is a good producer for list fusion.+-- trie, and return their (prefix, value, remainder) triples in+-- order from shortest prefix to longest. This function is a good+-- producer for list fusion. matches :: Trie a -> ByteString -> [(ByteString, a, ByteString)] {-# INLINE matches #-} matches t q = map f (matches_ t q)@@ -145,7 +156,7 @@ {------------------------------------------------------------------ Single-value modification functions (recurse and clone spine)+-- Simple modification functions (recurse and clone spine) ---------------------------------------------------------------} -- | Insert a new key. If the key is already present, overrides the@@ -154,33 +165,61 @@ {-# INLINE insert #-} insert = alterBy (\_ x _ -> Just x) --- | Apply a function to the value at a key.-adjust :: (a -> a) -> ByteString -> Trie a -> Trie a-{-# INLINE adjust #-}-adjust f q = adjustBy (\_ _ -> f) q (impossible "adjust")--- TODO: benchmark vs the definition with alterBy/liftM+-- | Alter the value associated with a given key. If the key is not+-- present, then the trie is returned unaltered. See 'alterBy' if+-- you are interested in inserting new keys or deleting old keys.+-- Because this function does not need to worry about changing the+-- trie structure, it is somewhat faster than 'alterBy'.+--+-- /Since: 0.2.6/ for being exported from "Data.Trie". Before then+-- it was only exported from "Data.Trie.Internal".+adjustBy :: (ByteString -> a -> a -> a)+ -> ByteString -> a -> Trie a -> Trie a+{-# INLINE adjustBy #-}+adjustBy f q x = adjust (f q x) q -- | Remove the value stored at a key. delete :: ByteString -> Trie a -> Trie a {-# INLINE delete #-}-delete q = alterBy (\_ _ _ -> Nothing) q (impossible "delete")+delete = alterBy_ (\_ t -> (Nothing, t)) +-- | Remove all keys beginning with a prefix.+--+-- @since 0.2.6+deleteSubmap :: ByteString -> Trie a -> Trie a+{-# INLINE deleteSubmap #-}+deleteSubmap = alterBy_ (\_ _ -> (Nothing, empty)) + {--------------------------------------------------------------- -- Trie-combining functions ---------------------------------------------------------------} --- | Combine two tries, resolving conflicts by choosing the value--- from the left trie.+-- | Take the union of two tries, resolving conflicts by choosing+-- the value from the left trie. unionL :: Trie a -> Trie a -> Trie a {-# INLINE unionL #-} unionL = mergeBy (\x _ -> Just x) --- | Combine two tries, resolving conflicts by choosing the value--- from the right trie.+-- | Take the union of two tries, resolving conflicts by choosing+-- the value from the right trie. unionR :: Trie a -> Trie a -> Trie a {-# INLINE unionR #-} unionR = mergeBy (\_ y -> Just y)++-- | Take the intersection of two tries, with values from the left trie.+--+-- @since 0.2.6+intersectL :: Trie a -> Trie b -> Trie a+{-# INLINE intersectL #-}+intersectL = intersectBy (\x _ -> Just x)++-- | Take the intersection of two tries, with values from the right trie.+--+-- @since 0.2.6+intersectR :: Trie a -> Trie b -> Trie b+{-# INLINE intersectR #-}+intersectR = intersectBy (\_ y -> Just y) ---------------------------------------------------------------- ----------------------------------------------------------- fin.
src/Data/Trie/ByteStringInternal.hs view
@@ -1,6 +1,6 @@ {-# OPTIONS_GHC -Wall -fwarn-tabs #-} --------------------------------------------------------------- ~ 2021.10.17+-- ~ 2021.11.07 -- | -- Module : Data.Trie.ByteStringInternal -- Copyright : Copyright (c) 2008--2021 wren gayle romano@@ -61,7 +61,7 @@ return $! (,,) !$ pre !$ s1' !$ s2' --- | Get the 'sizeOf' the type, without requiring @-XScopedTypeVariables@+-- | Get the 'sizeOf' type @a@, without requiring @-XScopedTypeVariables@ -- nor making a spurious call to 'System.IO.Unsafe.unsafePerformIO' or similar. sizeOfPtr :: Storable a => Ptr a -> Int sizeOfPtr = sizeOf . (undefined :: Ptr a -> a)
src/Data/Trie/Convenience.hs view
@@ -1,7 +1,7 @@ {-# OPTIONS_GHC -Wall -fwarn-tabs #-} ------------------------------------------------------------------- ~ 2021.10.17+-- ~ 2021.11.22 -- | -- Module : Data.Trie.Convenience -- Copyright : Copyright (c) 2008--2021 wren gayle romano@@ -37,14 +37,14 @@ , adjustWithKey , update, updateWithKey - -- * Combining tries ('mergeBy' variants)+ -- * Combining tries ('mergeBy' and 'intersectBy' variants) , disunion , unionWith, unionWith'+ , intersectWith, intersectWith' ) where import Data.Trie-import Data.Trie.Internal (lookupBy_, adjustBy)-import Data.Trie.Errors (impossible)+import Data.Trie.Internal (lookupBy_, alterBy_) import Data.ByteString (ByteString) import Data.List (foldl', sortBy) import Data.Ord (comparing)@@ -200,19 +200,15 @@ ---------------------------------------------------------------- -- | Apply a function to change the value at a key. adjustWithKey :: (ByteString -> a -> a) -> ByteString -> Trie a -> Trie a-adjustWithKey f q =- adjustBy (\k _ -> f k) q (impossible "Convenience.adjustWithKey")--- TODO: benchmark vs the definition with alterBy/liftM+adjustWithKey f q = adjust (f q) q -- | Apply a function to the value at a key, possibly removing it. update :: (a -> Maybe a) -> ByteString -> Trie a -> Trie a-update f q =- alterBy (\_ _ mx -> mx >>= f) q (impossible "Convenience.update")+update f q = alterBy_ (\mx t -> (mx >>= f, t)) q -- | A variant of 'update' which also provides the key to the function. updateWithKey :: (ByteString -> a -> Maybe a) -> ByteString -> Trie a -> Trie a-updateWithKey f q =- alterBy (\k _ mx -> mx >>= f k) q (impossible "Convenience.updateWithKey")+updateWithKey f q = alterBy_ (\mx t -> (mx >>= f q, t)) q {- updateLookupWithKey :: (ByteString -> a -> Maybe a) -> ByteString -> Trie a -> (Maybe a, Trie a)@@ -227,18 +223,33 @@ disunion :: Trie a -> Trie a -> Trie a disunion = mergeBy (\_ _ -> Nothing) --- | Combine two tries, using a function to resolve conflicts.+-- | Take the union of two tries, using a function to resolve+-- conflicts. The resulting trie is constructed strictly, but the+-- results of the combining function are evaluated lazily. unionWith :: (a -> a -> a) -> Trie a -> Trie a -> Trie a unionWith f = mergeBy (\x y -> Just (f x y)) --- | A variant of 'unionWith' which applies the combining function+-- | A variant of 'unionWith' which evaluates the combining function -- strictly. unionWith' :: (a -> a -> a) -> Trie a -> Trie a -> Trie a unionWith' f = mergeBy (\x y -> Just $! f x y) -{- TODO: (efficiently)-difference, intersection--}+-- | Take the intersection of two tries, with a function to resolve+-- the values. The resulting trie is constructed strictly, bit the+-- results of the combining function are evaluated lazily.+--+-- @since 0.2.6+intersectWith :: (a -> b -> c) -> Trie a -> Trie b -> Trie c+intersectWith f = intersectBy (\x y -> Just (f x y))++-- | A variant of 'intersectWith' which evaluates the combining+-- function strictly.+--+-- @since 0.2.6+intersectWith' :: (a -> b -> c) -> Trie a -> Trie b -> Trie c+intersectWith' f = intersectBy (\x y -> Just $! f x y)++-- TODO(github#23): add `difference` (efficiently!) ---------------------------------------------------------------- ----------------------------------------------------------- fin.
src/Data/Trie/Internal.hs view
@@ -6,7 +6,7 @@ {-# LANGUAGE CPP #-} --------------------------------------------------------------- ~ 2021.10.17+-- ~ 2021.11.22 -- | -- Module : Data.Trie.Internal -- Copyright : Copyright (c) 2008--2021 wren gayle romano@@ -34,17 +34,17 @@ , empty, null, singleton, size -- * Conversion and folding functions- , foldrWithKey, toListBy+ , toListBy, foldrWithKey, cata_, cata -- * Query functions , lookupBy_, submap , match_, matches_ - -- * Single-value modification- , alterBy, alterBy_, adjustBy+ -- * Simple modification+ , alterBy, alterBy_, adjust -- * Combining tries- , mergeBy+ , mergeBy, intersectBy -- * Mapping functions , mapBy@@ -65,14 +65,17 @@ import qualified Data.ByteString as S import Data.Trie.ByteStringInternal import Data.Trie.BitTwiddle+import Data.Trie.Errors (impossible) import Data.Binary (Binary(..), Get, Word8) #if MIN_VERSION_base(4,9,0) import Data.Semigroup (Semigroup(..))+#elif MIN_VERSION_base(4,5,0)+-- So we can abbreviate 'S.append'+import Data.Monoid ((<>)) #endif import Data.Monoid (Monoid(..)) import Control.Monad (liftM, liftM3, liftM4)-import Control.Monad (ap) import Control.Applicative (Applicative(..), (<$>)) import Data.Foldable (Foldable(foldMap)) import Data.Traversable (Traversable(traverse))@@ -83,6 +86,13 @@ ------------------------------------------------------------ ------------------------------------------------------------ +#if (!(MIN_VERSION_base(4,5,0)))+infixr 6 <>+-- Only ever used to abbreviate 'S.append'+(<>) :: Monoid m => m -> m -> m+(<>) = mappend+{-# INLINE (<>) #-}+#endif {----------------------------------------------------------- -- ByteString Big-endian Patricia Trie datatype@@ -94,62 +104,80 @@ patricia tree like Data.IntMap. In order to simplify things we then go through a series of derivations. -data Node a = Accept a (ArcSet a)- | Reject (Branch a) -- Invariant: Must be Branch-data Arc a = Arc ByteString (Node a) -- Invariant: never empty string-data ArcSet a = None- | One {KeyElem} (Arc a)- | Branch {Prefix} {Mask} (ArcSet a) (ArcSet a)-data Trie a = Empty- | Start ByteString (Node a) -- Maybe empty string [1]+ data Node a = Accept a (ArcSet a)+ | Reject (Branch a)+ data Arc a = Arc ByteString (Node a)+ data ArcSet a = None+ | One KeyElem (Arc a)+ | Many (Branch a)+ data Branch a = Branch {Prefix} {Mask} (ArcSet a) (ArcSet a)+ data Trie a = Empty+ | Start (Arc a) -- [1] -[1] If we maintain the invariants on how Nodes recurse, then we-can't simply have Start(Node a) because we may have a shared prefix-where the prefix itself is not Accept'ed.+[1]: N.B., we must allow constructing @Start(Arc pre (Reject b))@+for non-null @pre@, so that we can have a shared prefix even though+that prefix itself doesn't have an associated value. +** Squash Arc into One and Start:+For One, this allows combining the initial KeyElem with the rest+of the ByteString, which is purely beneficial. However, it does+introduce some invariants since now we must distinguish NonEmptyBS+vs NullableBS. --- Squash Arc into One:--- (pure good)-data Node a = Accept a (ArcSet a)- | Reject (Branch a)-data ArcSet a = None- | Arc ByteString (Node a)- | Branch {Prefix} {Mask} (ArcSet a) (ArcSet a)-data Trie a = Empty- | Start ByteString (Node a)+ newtype NonEmptyBS = NonEmptyBS ByteString -- Invariant: never empty+ newtype NullableBS = NullableBS Bytestring -- May be empty. + data Node a = Accept a (ArcSet a)+ | Reject (Branch a)+ data ArcSet a = None+ | Arc NonEmptyBS (Node a)+ | Many (Branch a)+ data Branch a = Branch {Prefix} {Mask} (ArcSet a) (ArcSet a)+ data Trie a = Empty+ | Start NullableBS (Node a) --- Squash Node together:--- (most likely good)-data Node a = Node (Maybe a) (ArcSet a)-data ArcSet a = None- | Arc ByteString (Node a)- | Branch {Prefix} {Mask} (ArcSet a) (ArcSet a)-data Trie a = Empty- | Start ByteString (Node a)+** Squash Accept and Reject together:+Most likely beneficial, though it complicates stating the invariants+about Node's recursion. + data Node a = Node (Maybe a) (ArcSet a)+ -- Invariant: if Nothing then must be Branch+ data ArcSet a = None+ | Arc NonEmptyBS (Node a)+ | Many (Branch a)+ data Branch a = Branch {Prefix} {Mask} (ArcSet a) (ArcSet a)+ data Trie a = Empty+ | Start NullableBS (Node a) --- Squash Empty/None and Arc/Start together:--- (This complicates invariants about non-empty strings and Node's--- recursion, but those can be circumvented by using smart--- constructors.)-data Node a = Node (Maybe a) (ArcSet a)-data Trie a = Empty- | Arc ByteString (Node a)- | Branch {Prefix} {Mask} (Trie a) (Trie a)+** Squash Branch into Many:+Purely beneficial, since there's no point in keeping them distinct anymore. + data Node a = Node (Maybe a) (ArcSet a)+ -- Invariant: if Nothing then must be Branch+ data ArcSet a = None+ | Arc NonEmptyBS (Node a)+ | Branch {Prefix} {Mask} (ArcSet a) (ArcSet a)+ data Trie a = Empty+ | Start NullableBS (Node a) --- Squash Node into Arc:--- (By this point, pure good)--- Unseen invariants:--- * ByteString non-empty, unless Arc is absolute root of tree--- * If (Maybe a) is Nothing, then (Trie a) is Branch--- * With views, we could re-expand Arc into accepting and--- nonaccepting variants------ [2] Maybe we shouldn't unpack the ByteString. We could specialize--- or inline the breakMaximalPrefix function to prevent constructing--- a new ByteString from the parts...+** Squash Empty/None and Arc/Start together:+Alas, this complicates the invariants about non-empty strings.++ data Node a = Node (Maybe a) (ArcSet a)+ -- Invariant: if Nothing then must be Branch+ data Trie a = Empty+ | Arc ByteString (Node a)+ -- Invariant: empty string only allowed if both+ -- (a) the Arc is at the root, and+ -- (b) the Node has a value.+ | Branch {Prefix} {Mask} (Trie a) (Trie a)++** Squash Node into Arc:+By this point, purely beneficial. However, the two unseen invariants remain.++[2] Maybe we shouldn't unpack the ByteString. We could specialize+or inline the breakMaximalPrefix function to prevent constructing+a new ByteString from the parts... -} -- | A map from 'ByteString's to @a@. For all the generic functions, -- note that tries are strict in the @Maybe@ but not in @a@.@@ -216,6 +244,7 @@ put (Arc k m t) = do put (1 :: Word8); put k; put m; put t put (Branch p m l r) = do put (2 :: Word8); put p; put m; put l; put r + -- BUG(github#21): need to verify the invariants! get = do tag <- get :: Get Word8 case tag of 0 -> return Empty@@ -276,8 +305,8 @@ go (Branch p m l r) = Branch p m <$> go l <*> go r instance Applicative Trie where- pure = return- (<*>) = ap+ pure = singleton S.empty+ m <*> n = m >>= (<$> n) -- Does this even make sense? It's not nondeterminism like lists -- and sets. If no keys were prefixes of other keys it'd make sense@@ -290,14 +319,24 @@ -- 2. m >>= return == m -- 3. (m >>= f) >>= g == m >>= (\x -> f x >>= g) instance Monad Trie where- return = singleton S.empty+-- Since base-4.8 (ghc-7.10.1) we have the default @return = pure@.+-- Since ghc-9.2.1 we get a warning about providing any other+-- definition, and should instead define both 'pure' and @(*>)@+-- directly, leaving 'return' and @(>>)@ as their defaults so they+-- can eventually be removed from the class.+-- <https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return>+#if (!(MIN_VERSION_base(4,8,0)))+ return = pure+#endif (>>=) Empty _ = empty (>>=) (Branch p m l r) f = branch p m (l >>= f) (r >>= f)- (>>=) (Arc k Nothing t) f = arc k Nothing (t >>= f)- (>>=) (Arc k (Just v) t) f = arc k Nothing (f v `unionL` (t >>= f))+ (>>=) (Arc k Nothing t) f = prepend k (t >>= f)+ (>>=) (Arc k (Just v) t) f = arc_ k (f v `unionL` (t >>= f)) where unionL = mergeBy (\x _ -> Just x)+ arc_ q | S.null q = id+ | otherwise = prepend q #if MIN_VERSION_base(4,9,0)@@ -314,7 +353,9 @@ -- This instance is more sensible than Data.IntMap and Data.Map's instance (Monoid a) => Monoid (Trie a) where mempty = empty+#if (!(MIN_VERSION_base(4,11,0))) mappend = mergeBy $ \x y -> Just (x `mappend` y)+#endif -- Since the Monoid instance isn't natural in @a@, I can't think@@ -350,8 +391,8 @@ filterMap f = go where go Empty = empty- go (Arc k Nothing t) = arc k Nothing (go t)- go (Arc k (Just v) t) = arc k (f v) (go t)+ go (Arc k Nothing t) = prepend k (go t)+ go (Arc k (Just v) t) = arc k (f v) (go t) go (Branch p m l r) = branch p m (go l) (go r) @@ -362,8 +403,8 @@ mapBy f = go S.empty where go _ Empty = empty- go q (Arc k Nothing t) = arc k Nothing (go q' t) where q' = S.append q k- go q (Arc k (Just v) t) = arc k (f q' v) (go q' t) where q' = S.append q k+ go q (Arc k Nothing t) = prepend k (go q' t) where q' = q <> k+ go q (Arc k (Just v) t) = arc k (f q' v) (go q' t) where q' = q <> k go q (Branch p m l r) = branch p m (go q l) (go q r) @@ -393,7 +434,7 @@ contextualFilterMap f = go where go Empty = empty- go (Arc k Nothing t) = arc k Nothing (go t)+ go (Arc k Nothing t) = prepend k (go t) go (Arc k (Just v) t) = arc k (f v t) (go t) go (Branch p m l r) = branch p m (go l) (go r) @@ -404,9 +445,8 @@ contextualMapBy f = go S.empty where go _ Empty = empty- go q (Arc k Nothing t) = arc k Nothing (go (S.append q k) t)- go q (Arc k (Just v) t) = let q' = S.append q k- in arc k (f q' v t) (go q' t)+ go q (Arc k Nothing t) = prepend k (go q' t) where q' = q <> k+ go q (Arc k (Just v) t) = arc k (f q' v t) (go q' t) where q' = q <> k go q (Branch p m l r) = branch p m (go q l) (go q r) @@ -423,16 +463,38 @@ -- | Smart constructor to prune @Arc@s that lead nowhere.--- N.B if mv=Just then doesn't check whether t=epsilon. It's up to callers to ensure that invariant isn't broken.+-- N.B if mv=Just then doesn't check that t /= (Arc S.empty (Just _) _);+-- it's up to callers to ensure that invariant isn't broken. arc :: ByteString -> Maybe a -> Trie a -> Trie a {-# INLINE arc #-}-arc k mv@(Just _) t = Arc k mv t-arc _ Nothing Empty = Empty-arc k Nothing t@(Branch _ _ _ _) | S.null k = t- | otherwise = Arc k Nothing t-arc k Nothing (Arc k' mv' t') = Arc (S.append k k') mv' t'+arc k mv@(Just _) = Arc k mv+arc k Nothing+ | S.null k = id+ | otherwise = prepend k +-- | Variant of `arc` where the string is known to be non-null.+arcNN :: ByteString -> Maybe a -> Trie a -> Trie a+{-# INLINE arcNN #-}+arcNN k mv@(Just _) = Arc k mv+arcNN k Nothing = prepend k +-- | Prepend a non-empty string to a trie. Relies on the caller+-- to ensure that the string is non-empty.+prepend :: ByteString -> Trie a -> Trie a+{-# INLINE prepend #-}+prepend _ t@Empty = t+prepend k t@(Branch{}) = Arc k Nothing t+prepend k (Arc k' mv' t') = Arc (k <> k') mv' t'++-- | Variant of `arc` for when the string is known to be empty.+-- Does not verify that the trie argument is not already contain+-- an epsilon value; is up to the caller to ensure correctness.+epsilon :: Maybe a -> Trie a -> Trie a+{-# INLINE epsilon #-}+epsilon Nothing = id+epsilon mv@(Just _) = Arc S.empty mv++ -- | Smart constructor to join two tries into a @Branch@ with maximal -- prefix sharing. Requires knowing the prefixes, but can combine -- either @Branch@es or @Arc@s.@@ -466,7 +528,10 @@ -- Error messages -----------------------------------------------------------} --- TODO: shouldn't we inline the logic and just NOINLINE the string constant? There are only three use sites, which themselves aren't inlined...+-- TODO: move off to "Data.Trie.Errors"?+-- TODO: shouldn't we inline the logic and just NOINLINE the string+-- constant? There are only three use sites, which themselves aren't+-- inlined... errorLogHead :: String -> ByteString -> ByteStringElem {-# NOINLINE errorLogHead #-} errorLogHead fn q@@ -548,9 +613,61 @@ Just v -> fcons k' v . rest where rest = go k' t- k' = S.append q k+ k' = q <> k +-- | Catamorphism for tries. Unlike most other functions (`mapBy`,+-- `contextualMapBy`, `foldrWithKey`, etc), this function does *not*+-- reconstruct the full `ByteString` for each value; instead it+-- only returns the suffix since the previous value or branch point.+--+-- This function is a direct\/literal catamorphism of the implementation+-- datatype, erasing only some bitmasking metadata for the branches.+-- For a more semantic catamorphism, see `cata`.+--+-- @since 0.2.6+cata_+ :: (ByteString -> Maybe a -> b -> b)+ -> (b -> b -> b)+ -> b+ -> Trie a -> b+cata_ a b e = go+ where+ go Empty = e+ go (Arc k mv t) = a k mv (go t)+ go (Branch _ _ l r) = b (go l) (go r)+++-- | Catamorphism for tries. Unlike most other functions (`mapBy`,+-- `contextualMapBy`, `foldrWithKey`, etc), this function does *not*+-- reconstruct the full `ByteString` for each value; instead it+-- only returns the suffix since the previous value or branch point.+--+-- This function is a semantic catamorphism; that is, it tries to+-- express the invariants of the implementation, rather than exposing+-- the literal structure of the implementation. For a more literal+-- catamorphism, see `cata_`.+--+-- @since 0.2.6+cata+ :: (ByteString -> a -> b -> b)+ -> (ByteString -> [b] -> b)+ -> b+ -> Trie a -> b+cata a b e = start+ where+ start Empty = e+ start (Arc k mv t) = step k mv t+ start (Branch _ _ l r) = b S.empty (collect l (collect r []))++ step k (Just v) t = a k v (start t)+ step k Nothing t = b k (collect t [])++ collect Empty bs = bs+ collect (Arc k mv t) bs = step k mv t : bs+ collect (Branch _ _ l r) bs = collect l (collect r bs)++ -- cf Data.ByteString.unpack -- <http://hackage.haskell.org/packages/archive/bytestring/0.9.1.4/doc/html/src/Data-ByteString.html> --@@ -587,40 +704,44 @@ -- an arc is reached, the second function argument is used. -- -- This function is intended for internal use. For the public-facing--- version, see @lookupBy@ in "Data.Trie".+-- version, see 'Data.Trie.lookupBy'. lookupBy_ :: (Maybe a -> Trie a -> b) -> b -> (Trie a -> b) -> ByteString -> Trie a -> b lookupBy_ f z a = lookupBy_' where -- | Deal with epsilon query (when there is no epsilon value)- lookupBy_' q t@(Branch _ _ _ _) | S.null q = f Nothing t- lookupBy_' q t = go q t+ lookupBy_' q t@(Branch{}) | S.null q = f Nothing t+ lookupBy_' q t = go q t -- | The main recursion go _ Empty = z- go q (Arc k mv t) = let (_,k',q') = breakMaximalPrefix k q- in case (not $ S.null k', S.null q') of- (True, True) -> a (Arc k' mv t)- (True, False) -> z- (False, True) -> f mv t- (False, False) -> go q' t-- go q t_@(Branch _ _ _ _) = findArc t_+ in case (S.null k', S.null q') of+ (False, True) -> a (Arc k' mv t)+ (False, False) -> z+ (True, True) -> f mv t+ (True, False) -> go q' t+ go q t_@(Branch{}) = findArc t_ where qh = errorLogHead "lookupBy_" q- -- | /O(min(m,W))/, where /m/ is number of @Arc@s in this -- branching, and /W/ is the word size of the Prefix,Mask type. findArc (Branch p m l r) | nomatch qh p m = z | zero qh m = findArc l | otherwise = findArc r- findArc t@(Arc _ _ _) = go q t- findArc Empty = z+ findArc t@(Arc{}) = go q t+ findArc Empty = impossible "lookupBy_" -- see [Note1] +-- [Note1]: Our use of the 'branch' and 'branchMerge' smart+-- constructors ensure that 'Empty' never occurs in a 'Branch' tree+-- ('Empty' can only occur at the root, or under an 'Arc' with+-- value); therefore the @findArc Empty@ case is unreachable. If+-- we allowed such nodes, however, then this case should return the+-- same result as the 'nomatch' case. + -- This function needs to be here, not in "Data.Trie", because of -- 'arc' which isn't exported. We could use the monad instance -- instead, though it'd be far more circuitous.@@ -632,13 +753,15 @@ -- | Return the subtrie containing all keys beginning with a prefix. submap :: ByteString -> Trie a -> Trie a {-# INLINE submap #-}-submap q = lookupBy_ (arc q) empty (arc q Nothing) q+submap q+ | S.null q = id+ | otherwise = lookupBy_ (arcNN q) empty (prepend q) q {- -- Disable superfluous error checking. -- @submap'@ would replace the first argument to @lookupBy_@ where- submap' Nothing Empty = errorEmptyAfterNothing "submap"- submap' Nothing (Arc _ _ _) = errorArcAfterNothing "submap"- submap' mx t = Arc q mx t+ submap' Nothing Empty = errorEmptyAfterNothing "submap"+ submap' Nothing (Arc{}) = errorArcAfterNothing "submap"+ submap' mx t = Arc q mx t errorInvariantBroken :: String -> String -> a {-# NOINLINE errorInvariantBroken #-}@@ -665,85 +788,77 @@ -- -- This function may not have the most useful return type. For a -- version that returns the prefix itself as well as the remaining--- string, see @match@ in "Data.Trie".+-- string, see 'Data.Trie.match'. match_ :: Trie a -> ByteString -> Maybe (Int, a) match_ = flip start where -- | Deal with epsilon query (when there is no epsilon value)- start q (Branch _ _ _ _) | S.null q = Nothing- start q t = goNothing 0 q t+ start q (Branch{}) | S.null q = Nothing+ start q t = goNothing 0 q t+ -- TODO: for the non-null Branch case, maybe we should jump directly to 'findArc' (i.e., inline that case of 'goNothing') -- | The initial recursion goNothing _ _ Empty = Nothing- goNothing n q (Arc k mv t) = let (p,k',q') = breakMaximalPrefix k q n' = n + S.length p in n' `seq`- if S.null k'- then- if S.null q'- then (,) n' <$> mv- else- case mv of- Nothing -> goNothing n' q' t- Just v -> goJust n' v n' q' t- else Nothing-- goNothing n q t_@(Branch _ _ _ _) = findArc t_+ case (S.null k', S.null q') of+ (False, _) -> Nothing+ (True, True) -> (,) n' <$> mv+ (True, False) ->+ case mv of+ Nothing -> goNothing n' q' t+ Just v -> goJust n' v n' q' t+ goNothing n q t_@(Branch{}) = findArc t_ where qh = errorLogHead "match_" q- -- | /O(min(m,W))/, where /m/ is number of @Arc@s in this -- branching, and /W/ is the word size of the Prefix,Mask type. findArc (Branch p m l r) | nomatch qh p m = Nothing | zero qh m = findArc l | otherwise = findArc r- findArc t@(Arc _ _ _) = goNothing n q t- findArc Empty = Nothing+ findArc t@(Arc{}) = goNothing n q t+ findArc Empty = impossible "match_" -- see [Note1] -- | The main recursion goJust n0 v0 _ _ Empty = Just (n0,v0)- goJust n0 v0 n q (Arc k mv t) = let (p,k',q') = breakMaximalPrefix k q n' = n + S.length p in n' `seq`- if S.null k'- then- if S.null q'- then- case mv of- Nothing -> Just (n0,v0)- Just v -> Just (n',v)- else- case mv of- Nothing -> goJust n0 v0 n' q' t- Just v -> goJust n' v n' q' t- else Just (n0,v0)-- goJust n0 v0 n q t_@(Branch _ _ _ _) = findArc t_+ case (S.null k', S.null q') of+ (False, _) -> Just (n0,v0)+ (True, True) ->+ case mv of+ Nothing -> Just (n0,v0)+ Just v -> Just (n',v)+ (True, False) ->+ case mv of+ Nothing -> goJust n0 v0 n' q' t+ Just v -> goJust n' v n' q' t+ goJust n0 v0 n q t_@(Branch{}) = findArc t_ where qh = errorLogHead "match_" q- -- | /O(min(m,W))/, where /m/ is number of @Arc@s in this -- branching, and /W/ is the word size of the Prefix,Mask type. findArc (Branch p m l r) | nomatch qh p m = Just (n0,v0) | zero qh m = findArc l | otherwise = findArc r- findArc t@(Arc _ _ _) = goJust n0 v0 n q t- findArc Empty = Just (n0,v0)+ findArc t@(Arc{}) = goJust n0 v0 n q t+ findArc Empty = impossible "match_" -- see [Note1] -- | Given a query, find all prefixes with associated values in the--- trie, returning their lengths and values. This function is a--- good producer for list fusion.+-- trie, and return the length of each prefix with their value, in+-- order from shortest prefix to longest. This function is a good+-- producer for list fusion. -- -- This function may not have the most useful return type. For a -- version that returns the prefix itself as well as the remaining--- string, see @matches@ in "Data.Trie".+-- string, see 'Data.Trie.matches'. matches_ :: Trie a -> ByteString -> [(Int,a)] matches_ t q = #if !defined(__GLASGOW_HASKELL__)@@ -759,12 +874,11 @@ matchFB_' cons = start where -- | Deal with epsilon query (when there is no epsilon value)- start q (Branch _ _ _ _) | S.null q = id- start q t = go 0 q t+ start q (Branch{}) | S.null q = id+ start q t = go 0 q t -- | The main recursion go _ _ Empty = id- go n q (Arc k mv t) = let (p,k',q') = breakMaximalPrefix k q n' = n + S.length p@@ -775,23 +889,21 @@ . if S.null q' then id else go n' q' t else id-- go n q t_@(Branch _ _ _ _) = findArc t_+ go n q t_@(Branch{}) = findArc t_ where qh = errorLogHead "matches_" q- -- | /O(min(m,W))/, where /m/ is number of @Arc@s in this -- branching, and /W/ is the word size of the Prefix,Mask type. findArc (Branch p m l r) | nomatch qh p m = id | zero qh m = findArc l | otherwise = findArc r- findArc t@(Arc _ _ _) = go n q t- findArc Empty = id+ findArc t@(Arc{}) = go n q t+ findArc Empty = impossible "matches_" -- see [Note1] {-------------------------------------------------------------- Single-value modification functions (recurse and clone spine)+-- Simple modification functions (recurse and clone spine) -----------------------------------------------------------} -- TODO: We should CPS on Empty to avoid cloning spine if no change.@@ -804,88 +916,93 @@ -- to resolve conflicts (or non-conflicts). alterBy :: (ByteString -> a -> Maybe a -> Maybe a) -> ByteString -> a -> Trie a -> Trie a-alterBy f = alterBy_ (\k v mv t -> (f k v mv, t))+alterBy f q x = alterBy_ (\mv t -> (f q x mv, t)) q -- TODO: use GHC's 'inline' function so that this gets specialized away.--- TODO: benchmark to be sure that this doesn't introduce unforseen performance costs because of the uncurrying etc.+-- TODO: benchmark to be sure that this doesn't introduce unforseen+-- performance costs because of the uncurrying etc.+-- TODO: move to "Data.Trie" itself instead of here, since it doesn't+-- depend on any internals (unless we actually do the CPS optimization).+-- TODO: would there be any benefit in basing this off a different+-- function that captures the invariant that the subtrie is left+-- alone? -- | A variant of 'alterBy' which also allows modifying the sub-trie.-alterBy_ :: (ByteString -> a -> Maybe a -> Trie a -> (Maybe a, Trie a))- -> ByteString -> a -> Trie a -> Trie a-alterBy_ f_ q_ x_- | S.null q_ = alterEpsilon- | otherwise = go q_+-- If the function returns @(Just v, t)@ and @lookup S.empty t ==+-- Just w@, then the @w@ will be overwritten by @v@.+--+-- /Type changed in 0.2.6/+alterBy_+ :: (Maybe a -> Trie a -> (Maybe a, Trie a))+ -> ByteString -> Trie a -> Trie a+alterBy_ f = start where- f = f_ q_ x_- nothing q = uncurry (arc q) (f Nothing Empty)+ start q+ | S.null q = alterEpsilon+ | otherwise = go q - alterEpsilon t_@Empty = uncurry (arc q_) (f Nothing t_)- alterEpsilon t_@(Branch _ _ _ _) = uncurry (arc q_) (f Nothing t_)- alterEpsilon t_@(Arc k mv t) | S.null k = uncurry (arc q_) (f mv t)- | otherwise = uncurry (arc q_) (f Nothing t_)+ alterEpsilon (Arc k mv t) | S.null k = uncurry epsilon (f mv t)+ alterEpsilon t_ = uncurry epsilon (f Nothing t_) + -- @go@ is always called with non-null @q@, therefore @nothing@ is too.+ nothing q = uncurry (arcNN q) (f Nothing Empty) go q Empty = nothing q- go q t@(Branch p m l r) | nomatch qh p m = branchMerge p t qh (nothing q) | zero qh m = branch p m (go q l) r | otherwise = branch p m l (go q r) where- qh = errorLogHead "alterBy" q-+ qh = errorLogHead "alterBy_" q go q t_@(Arc k mv t) = let (p,k',q') = breakMaximalPrefix k q in- case (not $ S.null k', S.null q') of- (True, True) -> -- add node to middle of arc- uncurry (arc p) (f Nothing (Arc k' mv t))- (True, False) ->+ case (S.null k', S.null q') of+ (False, True) -> -- add node to middle of Arc+ uncurry (arcNN p) (f Nothing (Arc k' mv t))+ (False, False) -> case nothing q' of- Empty -> t_ -- Nothing to add, reuse old arc+ Empty -> t_ -- Nothing to add, reuse old Arc l -> arc' (branchMerge (getPrefix l) l (getPrefix r) r) where r = Arc k' mv t-- -- inlined version of 'arc'+ -- inlined variant of @arc p Nothing@, which captures+ -- the invariant that the result of 'branchMerge'+ -- above must be a Branch (because neither @l@ nor+ -- @r@ are Empty) arc' | S.null p = id | otherwise = Arc p Nothing-- (False, True) -> uncurry (arc k) (f mv t)- (False, False) -> arc k mv (go q' t)+ (True, True) -> uncurry (arc k) (f mv t)+ (True, False) -> arc k mv (go q' t) --- | Alter the value associated with a given key. If the key is not--- present, then the trie is returned unaltered. See 'alterBy' if--- you are interested in inserting new keys or deleting old keys.--- Because this function does not need to worry about changing the--- trie structure, it is somewhat faster than 'alterBy'.-adjustBy :: (ByteString -> a -> a -> a)- -> ByteString -> a -> Trie a -> Trie a-adjustBy f_ q_ x_- | S.null q_ = adjustEpsilon- | otherwise = go q_+-- TODO: benchmark vs the definition with alterBy/liftM+-- TODO: add a variant that's strict in the function.+--+-- /Since: 0.2.6/ for being exported from "Data.Trie.Internal".+--+-- | Apply a function to the value at a key. If the key is not+-- present, then the trie is returned unaltered.+adjust :: (a -> a) -> ByteString -> Trie a -> Trie a+adjust f = start where- f = f_ q_ x_-- adjustEpsilon (Arc k (Just v) t) | S.null k = Arc k (Just (f v)) t- adjustEpsilon t_ = t_+ start q t | not (S.null q) = go q t+ start _ (Arc k (Just v) t) | S.null k = Arc k (Just (f v)) t+ start _ t = t go _ Empty = Empty- go q t@(Branch p m l r) | nomatch qh p m = t | zero qh m = Branch p m (go q l) r | otherwise = Branch p m l (go q r) where- qh = errorLogHead "adjustBy" q-+ qh = errorLogHead "adjust" q go q t_@(Arc k mv t) = let (_,k',q') = breakMaximalPrefix k q in- case (not $ S.null k', S.null q') of- (True, True) -> t_ -- don't break arc inline- (True, False) -> t_ -- don't break arc branching- (False, True) -> Arc k (liftM f mv) t- (False, False) -> Arc k mv (go q' t)+ case (S.null k', S.null q') of+ (False, True) -> t_ -- don't break Arc inline+ (False, False) -> t_ -- don't break Arc branching+ (True, True) -> Arc k (liftM f mv) t+ (True, False) -> Arc k mv (go q' t) {-----------------------------------------------------------@@ -897,7 +1014,7 @@ -- where t = map (\s -> (pk s, 0)) -- ["heat","hello","hoi","apple","appa","hell","appb","appc"] ----- | Combine two tries, using a function to resolve collisions.+-- | Take the union of two tries, using a function to resolve collisions. -- This can only define the space of functions between union and -- symmetric difference but, with those two, all set operations can -- be defined (albeit inefficiently).@@ -908,24 +1025,22 @@ mergeBy' t0_@(Arc k0 mv0 t0) t1_@(Arc k1 mv1 t1)- | S.null k0 && S.null k1 = arc k0 (mergeMaybe f mv0 mv1) (go t0 t1)- | S.null k0 = arc k0 mv0 (go t0 t1_)- | S.null k1 = arc k1 mv1 (go t1 t0_)+ | S.null k0 && S.null k1 = epsilon (mergeMaybe f mv0 mv1) (go t0 t1)+ | S.null k0 = epsilon mv0 (go t0 t1_)+ | S.null k1 = epsilon mv1 (go t0_ t1) mergeBy' (Arc k0 mv0@(Just _) t0)- t1_@(Branch _ _ _ _)- | S.null k0 = arc k0 mv0 (go t0 t1_)+ t1_@(Branch{})+ | S.null k0 = Arc k0 mv0 (go t0 t1_) mergeBy'- t0_@(Branch _ _ _ _)+ t0_@(Branch{}) (Arc k1 mv1@(Just _) t1)- | S.null k1 = arc k1 mv1 (go t1 t0_)+ | S.null k1 = Arc k1 mv1 (go t0_ t1) mergeBy' t0_ t1_ = go t0_ t1_ - -- | The main recursion go Empty t1 = t1 go t0 Empty = t0- -- /O(n+m)/ for this part where /n/ and /m/ are sizes of the branchings go t0@(Branch p0 m0 l0 r0) t1@(Branch p1 m1 l1 r1)@@ -937,13 +1052,14 @@ union0 | nomatch p1 p0 m0 = branchMerge p0 t0 p1 t1 | zero p1 m0 = branch p0 m0 (go l0 t1) r0 | otherwise = branch p0 m0 l0 (go r0 t1)- union1 | nomatch p0 p1 m1 = branchMerge p0 t0 p1 t1 | zero p0 m1 = branch p1 m1 (go t0 l1) r1 | otherwise = branch p1 m1 l1 (go t0 r1)-- -- We combine these branches of 'go' in order to clarify where the definitions of 'p0', 'p1', 'm'', 'p'' are relevant. However, this may introduce inefficiency in the pattern matching automaton...- -- TODO: check. And get rid of 'go'' if it does.+ -- We combine these branches of @go@ in order to clarify where+ -- the definitions of @p0@, @p1@, @m'@, @p'@ are relevant.+ -- However, this may introduce inefficiency in the pattern+ -- matching automaton...+ -- TODO: check; and get rid of @go'@ if it does. go t0_ t1_ = go' t0_ t1_ where p0 = getPrefix t0_@@ -957,25 +1073,27 @@ let (pre,k0',k1') = breakMaximalPrefix k0 k1 in if S.null pre then error "mergeBy: no mask, but no prefix string"- else let {-# INLINE arcMerge #-}- arcMerge mv' t1' t2' = arc pre mv' (go t1' t2')- in case (S.null k0', S.null k1') of- (True, True) -> arcMerge (mergeMaybe f mv0 mv1) t0 t1- (True, False) -> arcMerge mv0 t0 (Arc k1' mv1 t1)- (False,True) -> arcMerge mv1 (Arc k0' mv0 t0) t1- (False,False) -> arcMerge Nothing (Arc k0' mv0 t0)- (Arc k1' mv1 t1)- go' (Arc _ _ _)+ else+ let {-# INLINE t0' #-}+ t0' = Arc k0' mv0 t0+ {-# INLINE t1' #-}+ t1' = Arc k1' mv1 t1+ in+ case (S.null k0', S.null k1') of+ (True, True) -> arcNN pre (mergeMaybe f mv0 mv1) (go t0 t1)+ (True, False) -> arcNN pre mv0 (go t0 t1')+ (False,True) -> arcNN pre mv1 (go t0' t1)+ (False,False) -> prepend pre (go t0' t1')+ go' (Arc{}) (Branch _p1 m1 l r) | nomatch p0 p1 m1 = branchMerge p1 t1_ p0 t0_ | zero p0 m1 = branch p1 m1 (go t0_ l) r | otherwise = branch p1 m1 l (go t0_ r) go' (Branch _p0 m0 l r)- (Arc _ _ _)+ (Arc{}) | nomatch p1 p0 m0 = branchMerge p0 t0_ p1 t1_ | zero p1 m0 = branch p0 m0 (go l t1_) r | otherwise = branch p0 m0 l (go r t1_)- -- Inlined branchMerge. Both tries are disjoint @Arc@s now. go' _ _ | zero p0 m' = Branch p' m' t0_ t1_ go' _ _ = Branch p' m' t1_ t0_@@ -989,6 +1107,97 @@ mergeMaybe f (Just v0) (Just v1) = f v0 v1 +-- | Take the intersection of two tries, using a function to resolve+-- collisions.+--+-- @since 0.2.6+intersectBy :: (a -> b -> Maybe c) -> Trie a -> Trie b -> Trie c+intersectBy f = intersectBy'+ where+ -- | Deals with epsilon entries, before recursing into @go@+ intersectBy'+ t0_@(Arc k0 mv0 t0)+ t1_@(Arc k1 mv1 t1)+ | S.null k0 && S.null k1 = epsilon (intersectMaybe f mv0 mv1) (go t0 t1)+ | S.null k0 = go t0 t1_+ | S.null k1 = go t0_ t1+ intersectBy'+ (Arc k0 (Just _) t0)+ t1_@(Branch{})+ | S.null k0 = go t0 t1_+ intersectBy'+ t0_@(Branch{})+ (Arc k1 (Just _) t1)+ | S.null k1 = go t0_ t1+ intersectBy' t0_ t1_ = go t0_ t1_++ -- | The main recursion+ go Empty _ = Empty+ go _ Empty = Empty+ go t0@(Branch p0 m0 l0 r0)+ t1@(Branch p1 m1 l1 r1)+ | shorter m0 m1 = intersection0+ | shorter m1 m0 = intersection1+ | p0 == p1 = branch p0 m0 (go l0 l1) (go r0 r1)+ | otherwise = Empty+ where+ intersection0+ | nomatch p1 p0 m0 = Empty+ | zero p1 m0 = go l0 t1+ | otherwise = go r0 t1+ intersection1+ | nomatch p0 p1 m1 = Empty+ | zero p0 m1 = go t0 l1+ | otherwise = go t0 r1+ go t0_@(Arc k0 mv0 t0)+ t1_@(Arc k1 mv1 t1)+ | m' == 0 =+ let (pre,k0',k1') = breakMaximalPrefix k0 k1 in+ if S.null pre+ then error "intersectBy: no mask, but no prefix string"+ else+ let {-# INLINE t0' #-}+ t0' = Arc k0' mv0 t0+ {-# INLINE t1' #-}+ t1' = Arc k1' mv1 t1+ in+ case (S.null k0', S.null k1') of+ (True, True) -> arcNN pre (intersectMaybe f mv0 mv1) (go t0 t1)+ (True, False) -> prepend pre (go t0 t1')+ (False,True) -> prepend pre (go t0' t1)+ (False,False) -> prepend pre (go t0' t1')+ where+ p0 = getPrefix t0_+ p1 = getPrefix t1_+ m' = branchMask p0 p1+ go t0_@(Arc{})+ t1_@(Branch _p1 m1 l r)+ | nomatch p0 p1 m1 = Empty+ | zero p0 m1 = go t0_ l+ | otherwise = go t0_ r+ where+ p0 = getPrefix t0_+ p1 = getPrefix t1_+ go t0_@(Branch _p0 m0 l r)+ t1_@(Arc{})+ | nomatch p1 p0 m0 = Empty+ | zero p1 m0 = go l t1_+ | otherwise = go r t1_+ where+ p0 = getPrefix t0_+ p1 = getPrefix t1_+ go _ _ = Empty+++intersectMaybe :: (a -> b -> Maybe c) -> Maybe a -> Maybe b -> Maybe c+{-# INLINE intersectMaybe #-}+intersectMaybe f (Just v0) (Just v1) = f v0 v1+intersectMaybe _ _ _ = Nothing+++-- TODO(github#23): add `differenceBy`++ {----------------------------------------------------------- -- Priority-queue functions -----------------------------------------------------------}@@ -1000,8 +1209,8 @@ minAssoc = go S.empty where go _ Empty = Nothing- go q (Arc k (Just v) _) = Just (S.append q k,v)- go q (Arc k Nothing t) = go (S.append q k) t+ go q (Arc k (Just v) _) = Just (q <> k, v)+ go q (Arc k Nothing t) = go (q <> k) t go q (Branch _ _ l _) = go q l @@ -1012,13 +1221,14 @@ maxAssoc = go S.empty where go _ Empty = Nothing- go q (Arc k (Just v) Empty) = Just (S.append q k,v)- go q (Arc k _ t) = go (S.append q k) t+ go q (Arc k (Just v) Empty) = Just (q <> k, v)+ go q (Arc k _ t) = go (q <> k) t go q (Branch _ _ _ r) = go q r mapView :: (Trie a -> Trie a) -> Maybe (ByteString, a, Trie a) -> Maybe (ByteString, a, Trie a)+{-# INLINE mapView #-} mapView _ Nothing = Nothing mapView f (Just (k,v,t)) = Just (k,v, f t) @@ -1029,9 +1239,8 @@ updateMinViewBy f = go S.empty where go _ Empty = Nothing- go q (Arc k (Just v) t) = let q' = S.append q k- in Just (q',v, arc k (f q' v) t)- go q (Arc k Nothing t) = mapView (arc k Nothing) (go (S.append q k) t)+ go q (Arc k (Just v) t) = Just (q',v, arc k (f q' v) t) where q' = q <> k+ go q (Arc k Nothing t) = mapView (prepend k) (go (q <> k) t) go q (Branch p m l r) = mapView (\l' -> branch p m l' r) (go q l) @@ -1041,9 +1250,8 @@ updateMaxViewBy f = go S.empty where go _ Empty = Nothing- go q (Arc k (Just v) Empty) = let q' = S.append q k- in Just (q',v, arc k (f q' v) Empty)- go q (Arc k mv t) = mapView (arc k mv) (go (S.append q k) t)+ go q (Arc k (Just v) Empty) = Just (q',v, arc k (f q' v) Empty) where q' = q <> k+ go q (Arc k mv t) = mapView (arc k mv) (go (q <> k) t) go q (Branch p m l r) = mapView (branch p m l) (go q r) ------------------------------------------------------------
+ test/Main.hs view
@@ -0,0 +1,841 @@+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}+{-# LANGUAGE CPP+ , MultiParamTypeClasses+ , FlexibleContexts+ #-}++----------------------------------------------------------------+-- ~ 2021.11.22+-- |+-- Module : test/Main+-- Copyright : Copyright (c) 2008--2021 wren gayle romano+-- License : BSD3+-- Maintainer : wren@cpan.org+-- Stability : provisional+-- Portability : semi-portable (MPTC,...)+--+-- Testing 'Trie's.+----------------------------------------------------------------+module Main (main) where++import Utils++import qualified Data.Trie as T+import qualified Data.Trie.Internal as TI+import qualified Data.Trie.Convenience as TC+import qualified Data.ByteString as S++import qualified System.Exit as System (exitSuccess, exitFailure)+import qualified System.IO as System (hPutStrLn, stderr)+import qualified Test.Tasty.Ingredients as Tasty (tryIngredients)+import qualified Test.Tasty.Options as Tasty (singleOption, OptionSet)+import qualified Test.Tasty.Runners as Tasty (installSignalHandlers, parseOptions)+import qualified Test.Tasty as Tasty+import qualified Test.Tasty.SmallCheck as SC+import qualified Test.Tasty.QuickCheck as QC++import Data.List (nubBy, sortBy)+import Data.Ord (comparing)+#if MIN_VERSION_base(4,13,0)+-- [aka GHC 8.8.1] @(<>)@ is re-exported from the Prelude.+#elif MIN_VERSION_base(4,9,0)+-- [aka GHC 8.0.1]+import Data.Semigroup (Semigroup(..))+#elif MIN_VERSION_base(4,5,0)+-- [aka GHC 7.4.1]+import Data.Monoid ((<>))+#endif+#if MIN_VERSION_base(4,9,0)+import Data.Semigroup (Sum)+#else+data Sum a = Sum a+ deriving (Eq, Ord, Read, Show, Bounded, Num)+instance Num a => Monoid (Sum a) where+ mempty = Sum 0+ mappend (Sum x) (Sum y) = Sum (x + y)+#endif++----------------------------------------------------------------+----------------------------------------------------------------+-- We can't use 'Tasty.defaultMain' together with 'Tasty.localOption',+-- because what we want to do is to set new defaults but still allow+-- the commandline to override those defaults, and I don't see any+-- way to do that with 'Tasty.defaultMain'.+--+-- TODO: Still need some way to remove the few remaining+-- 'Tasty.localOption' calls that aren't global...+main :: IO ()+main = do+ let ins = Tasty.defaultIngredients+ Tasty.installSignalHandlers+ opts <- Tasty.parseOptions ins tests+ case Tasty.tryIngredients ins (globalOptions <> opts) tests of+ Nothing -> do+ System.hPutStrLn System.stderr+ "No ingredients agreed to run. Something is wrong."+ System.exitFailure+ Just act -> do+ ok <- act+ if ok+ then System.exitSuccess+ else System.exitFailure++-- We add the timeout for the sake of GithubActions CI, so we don't+-- accidentally blow our budget. So far, with HPC enabled the test+-- suite still takes about 20sec all together, so allowing 30sec+-- per test is more than generous.+globalOptions :: Tasty.OptionSet+globalOptions = mconcat+ [ Tasty.singleOption (Tasty.mkTimeout 30000000) -- 30sec; in microsecs+ , Tasty.singleOption (QC.QuickCheckTests 500) -- QC.Args.maxSuccess+ , Tasty.singleOption (QC.QuickCheckMaxSize 400) -- QC.Args.maxSize+ , Tasty.singleOption (QC.QuickCheckMaxRatio 10) -- QC.Args.maxDiscardRatio+ , Tasty.singleOption (SC.SmallCheckDepth 3)+ ]++tests :: Tasty.TestTree+tests =+ Tasty.testGroup "All Tests"+ [ hunitTests+ , Tasty.testGroup "Properties"+ [ quickcheckTests+ , smallcheckTests+ ]+ ]++hunitTests :: Tasty.TestTree+hunitTests =+ Tasty.testGroup "HUnit"+ [ test_Union+ , test_Intersect+ , test_Submap+ , test_Insert+ , test_Delete+ ]++{-+TODO: see if we can't figure out some way of wrapping our properties+so that we can just write this list once and then pass in a token+for which checker to resolve to; something like:++ data Prop a = Prop String a++ data PropChecker = QuickCheck | SmallCheck+ deriving (Eq, Show)++ testProp :: (QC.Testable a, SC.Testable IO a) => PropChecker -> Prop a -> Tasty.TestTree+ testProp QuickCheck (Prop name a) = QC.testProperty name a+ testProp SmallCheck (Prop name a) = SC.testProperty name a++Of course, the problem with that implementation is that we need to+have the Prop remain polymorphic in the CheckGuard type, and have+testProp resole it depending on the PropChecker. So is there a way+to do that without GADTs or impredicativity?+-}++quickcheckTests :: Tasty.TestTree+quickcheckTests+ = Tasty.testGroup "QuickCheck"+ [ Tasty.testGroup "Trivialities (@Int)"+ [ QC.testProperty+ "prop_insert"+ (prop_insert :: WS -> Int -> WTrie Int -> Bool)+ , QC.testProperty+ "prop_singleton"+ (prop_singleton :: WS -> Int -> Bool)+ , QC.testProperty+ "prop_size_insert"+ (prop_size_insert :: WS -> Int -> WTrie Int -> QC.Property)+ , QC.testProperty+ "prop_size_delete"+ (prop_size_delete :: WS -> Int -> WTrie Int -> QC.Property)+ , QC.testProperty+ "prop_insert_delete"+ (prop_insert_delete :: WS -> Int -> WTrie Int -> QC.Property)+ , QC.testProperty+ "prop_delete_lookup"+ (prop_delete_lookup :: WS -> WTrie Int -> QC.Property)+ ]+ , Tasty.testGroup "Submap (@Int)"+ [ QC.testProperty+ "prop_submap_keysAreMembers"+ (prop_submap_keysAreMembers :: WS -> WTrie Int -> Bool)+ , QC.testProperty+ "prop_submap_keysHavePrefix"+ (prop_submap_keysHavePrefix :: WS -> WTrie Int -> Bool)+ , QC.testProperty+ "prop_submap_valuesEq"+ (prop_submap_valuesEq :: WS -> WTrie Int -> Bool)+ , QC.testProperty+ "prop_deleteSubmap_keysAreMembers"+ (prop_deleteSubmap_keysAreMembers :: WS -> WTrie Int -> Bool)+ , QC.testProperty+ "prop_deleteSubmap_keysLackPrefix"+ (prop_deleteSubmap_keysLackPrefix :: WS -> WTrie Int -> Bool)+ , QC.testProperty+ "prop_deleteSubmap_disunion"+ (prop_deleteSubmap_disunion :: WS -> WTrie Int -> Bool)+ ]+ , Tasty.localOption (QC.QuickCheckMaxSize 300)+ -- BUG: fix that 'Tasty.localOption'+ $ Tasty.testGroup "Intersection (@Int)"+ [ QC.testProperty+ "prop_intersectL"+ (prop_intersectL :: WTrie Int -> WTrie Int -> Bool)+ , QC.testProperty+ "prop_intersectR"+ (prop_intersectR :: WTrie Int -> WTrie Int -> Bool)+ , QC.testProperty+ "prop_intersectPlus"+ (prop_intersectPlus :: WTrie Int -> WTrie Int -> Bool)+ ]+ , Tasty.testGroup "Matching (@Int)"+ [ QC.testProperty+ "prop_matches_keysOrdered"+ (prop_matches_keysOrdered :: WS -> WTrie Int -> Bool)+ , QC.testProperty+ "prop_matches_keysArePrefix"+ (prop_matches_keysArePrefix :: WS -> WTrie Int -> Bool)+ , QC.testProperty+ "prop_minMatch_is_first_matches"+ (prop_minMatch_is_first_matches :: WS -> WTrie Int -> Bool)+ , QC.testProperty+ "prop_match_is_last_matches"+ (prop_match_is_last_matches :: WS -> WTrie Int -> Bool)+ ]+ , Tasty.testGroup "Priority-queue (@Int)"+ [ QC.testProperty+ "prop_minAssoc_is_first_toList"+ (prop_minAssoc_is_first_toList :: WTrie Int -> Bool)+ , QC.testProperty+ "prop_maxAssoc_is_last_toList"+ (prop_maxAssoc_is_last_toList :: WTrie Int -> Bool)+ , QC.testProperty+ "prop_updateMinViewBy_ident"+ (prop_updateMinViewBy_ident :: WTrie Int -> Bool)+ , QC.testProperty+ "prop_updateMaxViewBy_ident"+ (prop_updateMaxViewBy_ident :: WTrie Int -> Bool)+ , QC.testProperty+ "prop_updateMinViewBy_gives_minAssoc"+ (prop_updateMinViewBy_gives_minAssoc :: (WS -> Int -> Maybe Int) -> WTrie Int -> Bool)+ , QC.testProperty+ "prop_updateMaxViewBy_gives_maxAssoc"+ (prop_updateMaxViewBy_gives_maxAssoc :: (WS -> Int -> Maybe Int) -> WTrie Int -> Bool)+ ]+ , Tasty.testGroup "List-conversion (@Int)"+ [ QC.testProperty+ "prop_toListBy_keysOrdered"+ (prop_toListBy_keysOrdered :: WTrie Int -> Bool)+ , QC.testProperty+ "prop_fromList_takes_first"+ (prop_fromList_takes_first :: [(WS, Int)] -> Bool)+ , QC.testProperty+ "prop_fromListR_takes_first"+ (prop_fromListR_takes_first :: [(WS, Int)] -> Bool)+ , QC.testProperty+ "prop_fromListL_takes_first"+ (prop_fromListL_takes_first :: [(WS, Int)] -> Bool)+ , QC.testProperty+ "prop_fromListS_takes_first"+ (prop_fromListS_takes_first :: [(WS, Int)] -> Bool)+ , QC.testProperty+ "prop_fromListWithConst_takes_first"+ (prop_fromListWithConst_takes_first :: [(WS, Int)] -> Bool)+ , QC.testProperty+ "prop_fromListWithLConst_takes_first"+ (prop_fromListWithLConst_takes_first :: [(WS, Int)] -> Bool)+ ]+ , Tasty.testGroup "Type classes"+ [ Tasty.testGroup "Functor (@Int)"+ [ QC.testProperty+ "prop_FunctorIdentity"+ (prop_FunctorIdentity :: WTrie Int -> Bool)+ -- TODO: prop_FunctorCompose+ {-+ -- TODO: still worth it to do this test with 'undefined'?+ , QC.testProperty+ "prop_fmap_keys"+ (prop_fmap_keys (undefined :: Int -> Int) :: WTrie Int -> Bool)+ -}+ , QC.testProperty+ -- TODO: generalize to other functions.+ "prop_fmap_toList"+ (prop_fmap_toList (+1) :: WTrie Int -> Bool)+ ]+ , Tasty.testGroup "Applicative (@Int)"+ [ QC.testProperty+ "prop_ApplicativeIdentity"+ (prop_ApplicativeIdentity :: WTrie Int -> Bool)+ -- TODO: prop_ApplicativeCompose, prop_ApplicativeHom, prop_ApplicativeInterchange+ ]+ , Tasty.testGroup "Monad (@Int)"+ [ QC.testProperty+ "prop_MonadIdentityR"+ (prop_MonadIdentityR :: WTrie Int -> Bool)+ -- TODO: prop_MonadIdentityL, prop_MonadAssoc+ ]+ -- TODO: Foldable, Traversable+#if MIN_VERSION_base(4,9,0)+ , Tasty.testGroup "Semigroup (@Sum Int)"+ [ QC.testProperty+ -- This one is a bit more expensive: ~1sec instead of <=0.5sec+ "prop_Semigroup"+ (prop_Semigroup :: WTrie (Sum Int) -> WTrie (Sum Int) -> WTrie (Sum Int) -> Bool)+ ]+#endif+ , Tasty.testGroup "Monoid (@Sum Int)"+ [ QC.testProperty+ "prop_MonoidIdentityL"+ (prop_MonoidIdentityL :: WTrie (Sum Int) -> Bool)+ , QC.testProperty+ "prop_MonoidIdentityR"+ (prop_MonoidIdentityR :: WTrie (Sum Int) -> Bool)+ ]+ ]+ , Tasty.testGroup "Other mapping/filtering (@Int)"+ [ QC.testProperty+ "prop_filterMap_ident"+ (prop_filterMap_ident :: WTrie Int -> Bool)+ , QC.testProperty+ "prop_filterMap_empty"+ (prop_filterMap_empty :: WTrie Int -> Bool)+ , QC.testProperty+ "prop_mapBy_keys"+ (prop_mapBy_keys :: WTrie Int -> Bool)+ , QC.testProperty+ "prop_contextualMap_ident"+ (prop_contextualMap_ident :: WTrie Int -> Bool)+ , QC.testProperty+ "prop_contextualMap'_ident"+ (prop_contextualMap'_ident :: WTrie Int -> Bool)+ , QC.testProperty+ "prop_contextualFilterMap_ident"+ (prop_contextualFilterMap_ident :: WTrie Int -> Bool)+ , QC.testProperty+ "prop_contextualMapBy_keys"+ (prop_contextualMapBy_keys :: WTrie Int -> Bool)+ , QC.testProperty+ "prop_contextualMapBy_ident"+ (prop_contextualMapBy_ident :: WTrie Int -> Bool)+ , QC.testProperty+ "prop_contextualMapBy_empty"+ (prop_contextualMapBy_empty :: WTrie Int -> Bool)+ ]+ ]++-- Throughout, we try to use 'W' or @()@ whenever we can, to reduce+-- the exponential growth problem.+smallcheckTests :: Tasty.TestTree+smallcheckTests+ = Tasty.testGroup "SmallCheck"+ [ Tasty.testGroup "Trivial properties (@W)"+ -- Depth=4 is death here (>30sec) ever since changing the instance.+ [ SC.testProperty+ "prop_insert"+ (prop_insert :: WS -> W -> WTrie W -> Bool)+ , SC.testProperty+ -- This one can easily handle depth=6 fine (~0.1sec), but d=7 (~4sec)+ "prop_singleton"+ (prop_singleton :: WS -> W -> Bool)+ , SC.testProperty+ "prop_size_insert"+ (prop_size_insert :: WS -> W -> WTrie W -> SC.Property IO)+ , SC.testProperty+ "prop_size_delete"+ (prop_size_delete :: WS -> W -> WTrie W -> SC.Property IO)+ , SC.testProperty+ "prop_insert_delete"+ (prop_insert_delete :: WS -> W -> WTrie W -> SC.Property IO)+ , SC.testProperty+ "prop_delete_lookup"+ (prop_delete_lookup :: WS -> WTrie W -> SC.Property IO)+ ]+ , Tasty.testGroup "Submap properties (@()/@W)"+ -- Depth=4 is at best very marginal here...+ [ SC.testProperty+ "prop_submap_keysAreMembers"+ (prop_submap_keysAreMembers :: WS -> WTrie () -> Bool)+ , SC.testProperty+ "prop_submap_keysHavePrefix"+ (prop_submap_keysHavePrefix :: WS -> WTrie () -> Bool)+ , SC.testProperty+ "prop_submap_valuesEq"+ (prop_submap_valuesEq :: WS -> WTrie W -> Bool)+ , SC.testProperty+ "prop_deleteSubmap_keysAreMembers"+ (prop_deleteSubmap_keysAreMembers :: WS -> WTrie () -> Bool)+ , SC.testProperty+ "prop_deleteSubmap_keysLackPrefix"+ (prop_deleteSubmap_keysLackPrefix :: WS -> WTrie () -> Bool)+ , SC.testProperty+ "prop_deleteSubmap_disunion"+ (prop_deleteSubmap_disunion :: WS -> WTrie W -> Bool)+ ]+ , Tasty.testGroup "Intersection properties (@W/@Int)"+ -- Warning: Using depth=4 here is bad (the first two take about+ -- 26.43sec; the last one much longer).+ [ SC.testProperty+ "prop_intersectL"+ (prop_intersectL :: WTrie W -> WTrie W -> Bool)+ , SC.testProperty+ "prop_intersectR"+ (prop_intersectR :: WTrie W -> WTrie W -> Bool)+ , SC.testProperty+ "prop_intersectPlus"+ (prop_intersectPlus :: WTrie Int -> WTrie Int -> Bool)+ ]+ , Tasty.testGroup "match/matches properties (@()/@W)"+ [ SC.testProperty+ "prop_matches_keysOrdered"+ (prop_matches_keysOrdered :: WS -> WTrie () -> Bool)+ , SC.testProperty+ "prop_matches_keysArePrefix"+ (prop_matches_keysArePrefix :: WS -> WTrie () -> Bool)+ , SC.testProperty+ "prop_minMatch_is_first_matches"+ (prop_minMatch_is_first_matches :: WS -> WTrie W -> Bool)+ , SC.testProperty+ "prop_match_is_last_matches"+ (prop_match_is_last_matches :: WS -> WTrie W -> Bool)+ ]+ , Tasty.testGroup "Priority-queue functions (@W)"+ -- Depth=4 takes about 1sec each+ [ SC.testProperty+ "prop_minAssoc_is_first_toList"+ (prop_minAssoc_is_first_toList :: WTrie W -> Bool)+ , SC.testProperty+ "prop_maxAssoc_is_last_toList"+ (prop_maxAssoc_is_last_toList :: WTrie W -> Bool)+ , SC.testProperty+ "prop_updateMinViewBy_ident"+ (prop_updateMinViewBy_ident :: WTrie W -> Bool)+ , SC.testProperty+ "prop_updateMaxViewBy_ident"+ (prop_updateMaxViewBy_ident :: WTrie W -> Bool)+ -- HACK: must explicitly pass functions for these two, else they're too slow+ , SC.testProperty+ "prop_updateMinViewBy_gives_minAssoc"+ (prop_updateMinViewBy_gives_minAssoc undefined :: WTrie W -> Bool)+ , SC.testProperty+ "prop_updateMaxViewBy_gives_maxAssoc"+ (prop_updateMaxViewBy_gives_maxAssoc undefined :: WTrie W -> Bool)+ ]+ , Tasty.adjustOption (+ (1::SC.SmallCheckDepth))+ $ Tasty.testGroup "List-conversion properties (@()/@W)"+ [ SC.testProperty+ "prop_toListBy_keysOrdered"+ (prop_toListBy_keysOrdered :: WTrie () -> Bool)+ , SC.testProperty+ "prop_fromList_takes_first"+ (prop_fromList_takes_first :: [(WS, W)] -> Bool)+ , SC.testProperty+ "prop_fromListR_takes_first"+ (prop_fromListR_takes_first :: [(WS, W)] -> Bool)+ , SC.testProperty+ "prop_fromListL_takes_first"+ (prop_fromListL_takes_first :: [(WS, W)] -> Bool)+ , SC.testProperty+ "prop_fromListS_takes_first"+ (prop_fromListS_takes_first :: [(WS, W)] -> Bool)+ , SC.testProperty+ "prop_fromListWithConst_takes_first"+ (prop_fromListWithConst_takes_first :: [(WS, W)] -> Bool)+ , SC.testProperty+ "prop_fromListWithLConst_takes_first"+ (prop_fromListWithLConst_takes_first :: [(WS, W)] -> Bool)+ ]+ ]+++----------------------------------------------------------------+----------------------------------------------------------------+-- Because we avoid epsilons everywhere else, need to make sure+-- 'mergeBy' gets it right+test_Union :: Tasty.TestTree+test_Union =+ Tasty.testGroup "mergeBy"+ [ testEqual "unionL epsilon" (e1 `T.unionL` e2) e1+ , testEqual "unionR epsilon" (e1 `T.unionR` e2) e2+ , testEqual "unionL regression" (tLeft `T.unionL` tRight) tLeftResult+ , testEqual "unionR regression" (tLeft `T.unionR` tRight) tRightResult+ ]+ where+ e1 = T.singleton S.empty (4::Int)+ e2 = T.singleton S.empty (2::Int)++ -- Regression test against bug filed by Gregory Crosswhite on+ -- 2010.06.10 against version 0.2.1.1.+ a, b :: S.ByteString+ a = read "\"\231^\179\160Y\134Gr\158<)&\222\217#\156\""+ b = read "\"\172\193\GSp\222\174GE\186\151\DC1#P\213\147\SI\""+ tLeft, tRight, tRightResult, tLeftResult :: T.Trie Int+ tLeft = T.fromList [(a,1), (b,0)]+ tRight = T.fromList [(a,2)]+ tRightResult = T.fromList [(a,2), (b,0)]+ tLeftResult = T.fromList [(a,1), (b,0)]++test_Intersect :: Tasty.TestTree+test_Intersect =+ Tasty.testGroup "intersectBy"+ [ testEqual "intersectL" (tLeft `T.intersectL` tRight) tLeftResult+ , testEqual "intersectR" (tLeft `T.intersectR` tRight) tRightResult+ ]+ where+ -- Trivial regression example+ a, b, c :: S.ByteString+ a = packC2W "a"+ b = packC2W "b"+ c = packC2W "c"+ tLeft, tRight, tRightResult, tLeftResult :: T.Trie Int+ tLeft = T.fromList [(S.empty,0), (a,1), (b,3)]+ tRight = T.fromList [ (a,2), (c,4)]+ tLeftResult = T.fromList [(a,1)]+ tRightResult = T.fromList [(a,2)]+ -- TODO: better unit test for when one string is prefix of another.++----------------------------------------------------------------+test_Submap :: Tasty.TestTree+test_Submap =+ Tasty.testGroup "submap"+ [ nullSubmap "split on arc fails" fi True+ , nullSubmap "prefix of arc matches" fo False+ , nullSubmap "suffix of empty fails" food True+ , nullSubmap "missing branch fails" bag True+ , nullSubmap "at a branch matches" ba False+ ]+ where+ t = vocab2trie ["foo", "bar", "baz"]+ fi = packC2W "fi"+ fo = packC2W "fo"+ food = packC2W "food"+ ba = packC2W "ba"+ bag = packC2W "bag"++ nullSubmap s q b = testEqual s (T.null $ T.submap q t) b++----------------------------------------------------------------+-- requires Eq (Trie a) and, in case it fails, Show (Trie a)+test_Insert :: Tasty.TestTree+test_Insert =+ Tasty.testGroup "insert"+ [ testEqual "insertion is commutative for prefix/superfix"+ (T.insert aba o $ T.insert abaissed i $ T.empty)+ (T.insert abaissed i $ T.insert aba o $ T.empty)+ ]+ where+ aba = packC2W "aba"+ abaissed = packC2W "abaissed"++ o = 0::Int+ i = 1::Int+++test_Delete :: Tasty.TestTree+test_Delete =+ Tasty.testGroup "delete"+ [ testEqual "deleting epsilon from empty trie is empty"+ (T.delete epsilon T.empty) (T.empty :: T.Trie Int)+ ]+ where+ -- TODO: why not 'S.empty'?+ epsilon = packC2W ""++----------------------------------------------------------------+----------------------------------------------------------------++-- | If you insert a value, you can look it up+prop_insert :: (Eq a) => WS -> a -> WTrie a -> Bool+prop_insert (WS k) v (WT t) =+ (T.lookup k . T.insert k v $ t) == Just v++-- | A singleton, is.+prop_singleton :: (Eq a) => WS -> a -> Bool+prop_singleton (WS k) v =+ T.insert k v T.empty == T.singleton k v++prop_size_insert :: (Eq a, CheckGuard Bool b) => WS -> a -> WTrie a -> b+prop_size_insert (WS k) v =+ ((not . T.member k) .==>. (T.size . T.insert k v) .==. ((1+) . T.size)) . unWT++prop_size_delete :: (Eq a, CheckGuard Bool b) => WS -> a -> WTrie a -> b+prop_size_delete (WS k) v =+ ((not . T.member k) .==>. (T.size . T.delete k . T.insert k v) .==. T.size) . unWT++prop_insert_delete :: (Eq a, CheckGuard Bool b) => WS -> a -> WTrie a -> b+prop_insert_delete (WS k) v =+ ((not . T.member k) .==>. (T.delete k . T.insert k v) .==. id) . unWT++prop_delete_lookup :: (Eq a, CheckGuard Bool b) => WS -> WTrie a -> b+prop_delete_lookup (WS k) =+ ((not . T.member k) .==>. (T.lookup k . T.delete k) .==. const Nothing) . unWT++-- | All keys in a submap are keys in the supermap+prop_submap_keysAreMembers :: WS -> WTrie a -> Bool+prop_submap_keysAreMembers (WS q) (WT t) =+ all (`T.member` t) . T.keys . T.submap q $ t+ -- TODO: should we use 'QC.conjoin' (assuming another class to overload it) in lieu of 'all'? What are the actual benefits of doing so? Ditto for all the uses below.++-- | All keys in a submap have the query as a prefix+prop_submap_keysHavePrefix :: WS -> WTrie a -> Bool+prop_submap_keysHavePrefix (WS q) =+ all (q `S.isPrefixOf`) . T.keys . T.submap q . unWT++-- | All values in a submap are the same in the supermap+prop_submap_valuesEq :: (Eq a) => WS -> WTrie a -> Bool+prop_submap_valuesEq (WS q) (WT t) =+ ((`T.lookup` t') .==. (`T.lookup` t)) `all` T.keys t'+ where t' = T.submap q t++-- | All keys in the result are keys in the supermap+prop_deleteSubmap_keysAreMembers :: WS -> WTrie a -> Bool+prop_deleteSubmap_keysAreMembers (WS q) (WT t) =+ all (`T.member` t) . T.keys . T.deleteSubmap q $ t++-- | All keys in a submap lack the query as a prefix+prop_deleteSubmap_keysLackPrefix :: WS -> WTrie a -> Bool+prop_deleteSubmap_keysLackPrefix (WS q) =+ all (not . S.isPrefixOf q) . T.keys . T.deleteSubmap q . unWT++-- | `T.submap` and `T.deleteSubmap` partition every trie for every key.+prop_deleteSubmap_disunion :: (Eq a) => WS -> WTrie a -> Bool+prop_deleteSubmap_disunion (WS q) (WT t) =+ t == (T.submap q t `TC.disunion` T.deleteSubmap q t)++-- TODO: other than as a helper like below, could we actually+-- generate interesting enough functions to make this worth testing+-- directly?+--+-- | Arbitrary @x ∩ y == (x ∪ y) ⋈ (x ⋈ y)@.+prop_intersectBy :: (Eq a) => (a -> a -> Maybe a) -> WTrie a -> WTrie a -> Bool+prop_intersectBy f (WT x) (WT y) =+ T.intersectBy f x y == (T.mergeBy f x y `TC.disunion` TC.disunion x y)++-- | Left-biased @x ∩ y == (x ∪ y) ⋈ (x ⋈ y)@.+prop_intersectL :: (Eq a) => WTrie a -> WTrie a -> Bool+prop_intersectL = prop_intersectBy (\x _ -> Just x)++-- | Right-biased @x ∩ y == (x ∪ y) ⋈ (x ⋈ y)@.+prop_intersectR :: (Eq a) => WTrie a -> WTrie a -> Bool+prop_intersectR = prop_intersectBy (\_ y -> Just y)++-- | Additive @x ∩ y == (x ∪ y) ⋈ (x ⋈ y)@.+prop_intersectPlus :: (Eq a, Num a) => WTrie a -> WTrie a -> Bool+prop_intersectPlus = prop_intersectBy (\x y -> Just (x + y))++isOrdered :: (Ord a) => [a] -> Bool+isOrdered xs = and (zipWith (<=) xs (drop 1 xs))++-- | 'T.toListBy', 'T.toList', and 'T.keys' are ordered by keys.+prop_toListBy_keysOrdered :: WTrie a -> Bool+prop_toListBy_keysOrdered = isOrdered . T.keys . unWT++fst3 :: (a,b,c) -> a+fst3 (a,_,_) = a++-- | 'T.matches' is ordered by keys.+prop_matches_keysOrdered :: WS -> WTrie a -> Bool+prop_matches_keysOrdered (WS q) (WT t) =+ isOrdered . map fst3 $ T.matches t q++-- | Matching keys are a prefix of the query.+prop_matches_keysArePrefix :: WS -> WTrie a -> Bool+prop_matches_keysArePrefix (WS q) (WT t) =+ all (`S.isPrefixOf` q) . map fst3 $ T.matches t q++_eqHead :: (Eq a) => Maybe a -> [a] -> Bool+_eqHead Nothing [] = True+_eqHead (Just x) (y:_) = x == y+_eqHead _ _ = False++_eqLast :: (Eq a) => Maybe a -> [a] -> Bool+_eqLast Nothing [] = True+_eqLast (Just x) ys@(_:_) = x == last ys+_eqLast _ _ = False++prop_minMatch_is_first_matches :: Eq a => WS -> WTrie a -> Bool+prop_minMatch_is_first_matches (WS q) (WT t) =+ _eqHead (T.minMatch t q) (T.matches t q)++prop_match_is_last_matches :: Eq a => WS -> WTrie a -> Bool+prop_match_is_last_matches (WS q) (WT t) =+ _eqLast (T.match t q) (T.matches t q)++prop_minAssoc_is_first_toList :: Eq a => WTrie a -> Bool+prop_minAssoc_is_first_toList (WT t) =+ _eqHead (TI.minAssoc t) (T.toList t)++prop_maxAssoc_is_last_toList :: Eq a => WTrie a -> Bool+prop_maxAssoc_is_last_toList (WT t) =+ _eqLast (TI.maxAssoc t) (T.toList t)++view2assoc :: Maybe (S.ByteString, a, T.Trie a) -> Maybe (S.ByteString, a)+view2assoc Nothing = Nothing+view2assoc (Just (k,v,_)) = Just (k,v)++-- TODO: again, can we actually generate any interesting functions here?+prop_updateMinViewBy_gives_minAssoc :: Eq a => (WS -> a -> Maybe a) -> WTrie a -> Bool+prop_updateMinViewBy_gives_minAssoc f =+ ((view2assoc . TI.updateMinViewBy (f . WS)) .==. TI.minAssoc) . unWT++prop_updateMaxViewBy_gives_maxAssoc :: Eq a => (WS -> a -> Maybe a) -> WTrie a -> Bool+prop_updateMaxViewBy_gives_maxAssoc f =+ ((view2assoc . TI.updateMaxViewBy (f . WS)) .==. TI.maxAssoc) . unWT++view2trie :: Maybe (S.ByteString, a, T.Trie a) -> T.Trie a+view2trie Nothing = T.empty+view2trie (Just (_,_,t)) = t++prop_updateMinViewBy_ident :: Eq a => WTrie a -> Bool+prop_updateMinViewBy_ident =+ ((view2trie . TI.updateMinViewBy (\_ v -> Just v)) .==. id) . unWT++prop_updateMaxViewBy_ident :: Eq a => WTrie a -> Bool+prop_updateMaxViewBy_ident =+ ((view2trie . TI.updateMaxViewBy (\_ v -> Just v)) .==. id) .unWT+++-- | If there are duplicate keys in the @assocs@, then @f@ will+-- take the first value.+_takes_first :: (Eq c) => ([(S.ByteString, c)] -> T.Trie c) -> [(WS, c)] -> Bool+_takes_first f assocs =+ (T.toList . f) .==. (nubBy (apFst (==)) . sortBy (comparing fst))+ $ map (first unWS) assocs++-- | Lift a function to apply to the 'fst' of pairs, retaining the 'snd'.+first :: (a -> b) -> (a,c) -> (b,c)+first f (x,y) = (f x, y)++-- | Lift a function to apply to the 'snd' of pairs, retaining the 'fst'.+second :: (b -> c) -> (a,b) -> (a,c)+second f (x,y) = (x, f y)++-- | Lift a binary function to apply to the first of pairs, discarding seconds.+apFst :: (a -> b -> c) -> ((a,d) -> (b,e) -> c)+apFst f (x,_) (y,_) = f x y++-- | 'T.fromList' takes the first value for a given key.+prop_fromList_takes_first :: (Eq a) => [(WS, a)] -> Bool+prop_fromList_takes_first = _takes_first T.fromList++-- | 'T.fromListR' takes the first value for a given key.+prop_fromListR_takes_first :: (Eq a) => [(WS, a)] -> Bool+prop_fromListR_takes_first = _takes_first TC.fromListR++-- | 'T.fromListL' takes the first value for a given key.+prop_fromListL_takes_first :: (Eq a) => [(WS, a)] -> Bool+prop_fromListL_takes_first = _takes_first TC.fromListL++-- | 'T.fromListS' takes the first value for a given key.+prop_fromListS_takes_first :: (Eq a) => [(WS, a)] -> Bool+prop_fromListS_takes_first = _takes_first TC.fromListS++-- | @('TC.fromListWith' const)@ takes the first value for a given key.+prop_fromListWithConst_takes_first :: (Eq a) => [(WS, a)] -> Bool+prop_fromListWithConst_takes_first = _takes_first (TC.fromListWith const)++-- | @('TC.fromListWithL' const)@ takes the first value for a given key.+prop_fromListWithLConst_takes_first :: (Eq a) => [(WS, a)] -> Bool+prop_fromListWithLConst_takes_first = _takes_first (TC.fromListWithL const)++prop_FunctorIdentity :: Eq a => WTrie a -> Bool+prop_FunctorIdentity = (fmap id .==. id) . unWT++{- -- TODO: is there any way to make this remotely testable?+prop_FunctorCompose :: Eq c => (b -> c) -> (a -> b) -> WTrie a -> Bool+prop_FunctorCompose f g = (fmap (f . g) .==. (fmap f . fmap g)) . unWT+-}++{-+-- Both of these test only a subset of what 'prop_fmap_toList' tests. I was hoping they'd help simplify the function-generation problem, but if we're testing 'prop_fmap_toList' anyways then there's no point in testing these too.++-- | 'fmap' doesn't affect the keys. This is safe to call with an+-- undefined function, thereby proving that the function cannot+-- affect things.+prop_fmap_keys :: Eq b => (a -> b) -> WTrie a -> Bool+prop_fmap_keys f = ((T.keys . fmap f) .==. T.keys) . unWT++prop_fmap_elems :: Eq b => (a -> b) -> WTrie a -> Bool+prop_fmap_elems f = ((T.elems . fmap f) .==. (map f . T.elems)) . unWT+-}++-- TODO: is there any way to generate halfway useful functions for testing here?+prop_fmap_toList :: Eq b => (a -> b) -> WTrie a -> Bool+prop_fmap_toList f =+ ((T.toList . fmap f) .==. (map (second f) . T.toList)) . unWT++prop_filterMap_ident :: Eq a => WTrie a -> Bool+prop_filterMap_ident = (T.filterMap Just .==. id) . unWT++prop_filterMap_empty :: Eq a => WTrie a -> Bool+prop_filterMap_empty = (T.filterMap const_Nothing .==. const T.empty) . unWT+ where+ -- Have to fix the result type here.+ const_Nothing :: a -> Maybe a+ const_Nothing = const Nothing++justConst :: a -> b -> Maybe a+justConst x _ = Just x++prop_mapBy_keys :: WTrie a -> Bool+prop_mapBy_keys = all (uncurry (==)) . T.toList . T.mapBy justConst . unWT++prop_contextualMap_ident :: Eq a => WTrie a -> Bool+prop_contextualMap_ident = (TI.contextualMap const .==. id) . unWT++prop_contextualMap'_ident :: Eq a => WTrie a -> Bool+prop_contextualMap'_ident = (TI.contextualMap' const .==. id) . unWT++prop_contextualFilterMap_ident :: Eq a => WTrie a -> Bool+prop_contextualFilterMap_ident =+ (TI.contextualFilterMap justConst .==. id) . unWT++prop_contextualMapBy_keys :: WTrie a -> Bool+prop_contextualMapBy_keys =+ all (uncurry (==)) . T.toList . TI.contextualMapBy f . unWT+ where+ f k _ _ = Just k++prop_contextualMapBy_ident :: Eq a => WTrie a -> Bool+prop_contextualMapBy_ident = (TI.contextualMapBy f .==. id) . unWT+ where+ f _ v _ = Just v++prop_contextualMapBy_empty :: Eq a => WTrie a -> Bool+prop_contextualMapBy_empty = (TI.contextualMapBy f .==. const T.empty) . unWT+ where+ -- Have to fix the result type here.+ f :: S.ByteString -> a -> T.Trie a -> Maybe a+ f _ _ _ = Nothing++prop_ApplicativeIdentity :: Eq a => WTrie a -> Bool+prop_ApplicativeIdentity = ((pure id <*>) .==. id) . unWT++{- -- (remaining, untestable) Applicative laws+prop_ApplicativeCompose = pure (.) <*> u <*> v <*> w == u <*> (v <*> w)+prop_ApplicativeHom = pure f <*> pure x == pure (f x)+prop_ApplicativeInterchange = u <*> pure y == pure ($ y) <*> u+-}++prop_MonadIdentityR :: Eq a => WTrie a -> Bool+prop_MonadIdentityR = ((>>= return) .==. id) . unWT++{- -- (remaining, untestable) Monad laws+prop_MonadIdentityL = (return a >>= k) == k a+prop_MonadAssoc = m >>= (\x -> k x >>= h) == (m >>= k) >>= h+-}++#if MIN_VERSION_base(4,9,0)+prop_Semigroup :: (Semigroup a, Eq a) => WTrie a -> WTrie a -> WTrie a -> Bool+prop_Semigroup (WT a) (WT b) (WT c) = a <> (b <> c) == (a <> b) <> c+#endif++-- N.B., base-4.11.0.0 is when Semigroup became superclass of Monoid+prop_MonoidIdentityL :: (Monoid a, Eq a) => WTrie a -> Bool+prop_MonoidIdentityL = ((mempty `mappend`) .==. id) . unWT++prop_MonoidIdentityR :: (Monoid a, Eq a) => WTrie a -> Bool+prop_MonoidIdentityR = ((`mappend` mempty) .==. id) . unWT++----------------------------------------------------------------+----------------------------------------------------------- fin.
+ test/Utils.hs view
@@ -0,0 +1,320 @@+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}+{-# LANGUAGE CPP+ , MultiParamTypeClasses+ , FlexibleInstances+ , FlexibleContexts+ #-}++----------------------------------------------------------------+-- ~ 2021.11.21+-- |+-- Module : test/Utils.hs+-- Copyright : Copyright (c) 2008--2021 wren gayle romano+-- License : BSD3+-- Maintainer : wren@cpan.org+-- Stability : provisional+-- Portability : semi-portable (MPTC,...)+--+-- Utilities for testing 'Trie's.+----------------------------------------------------------------+module Utils+ ( packC2W, vocab2trie+ , localQuickCheckOptions+ , testEqual+ , W(..), everyW+ , WS(..), packWS, unpackWS+ , WTrie(..)+ , CheckGuard(..), (.==>.), (.==.)+ ) where++import qualified Data.Trie as T+import Data.Word (Word8)+import qualified Data.ByteString as S+import qualified Data.ByteString.Internal as S (c2w, w2c)+import Data.ByteString.Internal (ByteString(PS))+import Control.Monad ((<=<))++-- N.B., "Test.Tasty.HUnit" does not in fact depend on "Test.HUnit";+-- hence using the longer alias.+import qualified Test.Tasty as Tasty+import qualified Test.Tasty.HUnit as TastyHU+import qualified Test.Tasty.QuickCheck as TastyQC+import qualified Test.QuickCheck as QC+import qualified Test.SmallCheck as SC+import qualified Test.SmallCheck.Series as SC+-- import qualified Test.LazySmallCheck as LSC+-- import qualified Test.SparseCheck as PC++----------------------------------------------------------------+----------------------------------------------------------------++-- | Construct a bytestring from the first byte of each 'Char'.+packC2W :: String -> S.ByteString+packC2W = S.pack . map S.c2w++-- | Construct a trie via 'packC2W' giving each key a unique value+-- (namely its position in the list).+vocab2trie :: [String] -> T.Trie Int+vocab2trie = T.fromList . flip zip [0..] . map packC2W++----------------------------------------------------------------+-- QuickCheck >=2.1.0 && <2.5.0 used 'maxDiscard' instead, which+-- has a different semantics and which we set to @max 1000 (10*n)@.+-- But since the cabal file lists QuickCheck-2.10 as the minimum+-- version, must switch to the new 'maxDiscardRatio' instead.++-- | Convert most of 'QC.Args' into Tasty. There are a few QuickCheck+-- args which are not handled:+--+-- * 'QC.maxShrinks' if tasty-quickcheck<0.10.2, because+-- 'TastyQC.QuickCheckMaxShrinks' is not exported.+-- <https://github.com/UnkindPartition/tasty/issues/316>+-- * 'QC.chatty' because Tasty always ignores this setting.+-- * 'QC.replay' because of technical difficulty with inverting+-- @Test.QuickCheck.Random.mkQCGen :: Int -> QCGen@+--+-- Conversely, there are two TastyQC options which have no equivalent+-- in 'QC.Args': 'TastyQC.QuickCheckVerbose' and 'TastyQC.QuickCheckShowReplay'.+localQuickCheckOptions :: QC.Args -> Tasty.TestTree -> Tasty.TestTree+localQuickCheckOptions args+ = Tasty.localOption (TastyQC.QuickCheckTests $ QC.maxSuccess args)+ . Tasty.localOption (TastyQC.QuickCheckMaxSize $ QC.maxSize args)+ . Tasty.localOption (TastyQC.QuickCheckMaxRatio $ QC.maxDiscardRatio args)+#if MIN_VERSION_tasty_quickcheck(0,10,2)+ . Tasty.localOption (TastyQC.QuickCheckMaxShrinks $ QC.maxShrinks args)+#endif+{-+Tasty lacks some options that QC.Args has:+ * (QC.chatty Bool{default=True}), though 'TastyQC.optionSetToArgs'+ always sets this to False.+Tasty has some additional options that QC.Args lacks:+ * (TastyQC.QuickCheckVerbose Bool{default=False})+ chooses between QC.verboseCheckWithResult vs QC.quickCheckWithResult.+ Where,+ QC.verboseCheckWithResult a p = QC.quickCheckWithResult a (QC.verbose p)+ * (TastyQC.QuickCheckShowReplay Bool{default=False})+ says whether to print the replay seed even on successful tests+ (it's always printed on unsuccessful tests).+Tasty has some discrepancy with QC.Args:+ * (TastyQC.QuickCheckReplay (Maybe Int){default=Nothing})+ vs (QC.replay (Maybe (QCGen, Int)){default=Nothing})++ The Int of QC.replay is the value returned by QC.getSize,+ which can be ignored for the purposes of TastyQC.QuickCheckReplay+ since QC.verboseCheckWithResult doesn't use it for random+ seed stuff. (QC.verboseCheckWithResult does use it to define+ the case for QC.State.computeSize applied to (0,0) however.)++ However, there's no good way I can think to invert+ Test.QuickCheck.Random.mkQCGen :: Int -> QCGen+ Which is just a wrapper around+ System.Random.mkStdGen :: Int -> StdGen+ or+ System.Random.SplitMix.mkSMGen :: Word64 -> SMGen+ depending on, if impl(hugs): cpp-options: -DNO_SPLITMIX++ Partly because it depends on whether the @random@ library+ version is >=1.2 vs <1.2, since they use different internals+ which the QCGen type is expressly designed to paper over.+ But mainly because there is no inverse function already given.+ We could use the Read and Show instances to recover the components+ of the QCGen, however it's less clear how to put them back+ together into an Int.+-}+++-- TODO: come up with a thing that pretty-prints the diff, instead+-- of just showing the expected\/actual.+testEqual :: (Show a, Eq a) => String -> a -> a -> Tasty.TestTree+testEqual name expected actual =+ TastyHU.testCase name (TastyHU.assertEqual "" expected actual)++----------------------------------------------------------------+-- | A small subset of 'Word8', so that 'WS' is more likely to have+-- shared prefixes. The 'Show' instance shows it as a 'Char', for+-- better legibility and for consistency with the 'Show' instance+-- of 'WS'.+newtype W = W { unW :: Word8 }+ deriving (Eq, Ord)++instance Show W where+ showsPrec p = showsPrec p . S.w2c . unW++-- TODO: ensure that these have good bit-patterns for covering corner cases.+-- | All the possible 'W' values; or rather, all the ones generated+-- by the 'QC.Arbitrary' and 'SC.Serial' instances.+everyW :: [W]+everyW = (W . S.c2w) <$> ['a'..'m']++-- TODO: if we define (Enum W) then we could use 'QC.chooseEnum'+-- which is much faster than 'QC.elements'. Alternatively we might+-- consider using 'QC.growingElements' if we want something more+-- like what the SC.Serial case does.+instance QC.Arbitrary W where+ arbitrary = QC.elements everyW+ shrink w = takeWhile (w /=) everyW++instance QC.CoArbitrary W where+ coarbitrary = QC.coarbitrary . unW++-- We take @(d+1)@ to match the instances for 'Char', (SC.N a), etc+instance Monad m => SC.Serial m W where+ series = SC.generate (\d -> take (d+1) everyW)++instance Monad m => SC.CoSerial m W where+ coseries = fmap (. unW) . SC.coseries++----------------------------------------------------------------+-- TODO: we need a better instance of Arbitrary for lists to make+-- them longer than our smallcheck depth.+--+-- | A subset of 'S.ByteString' produced by 'packWS'.+-- This newtype is to ensure that generated bytestrings are more+-- likely to have shared prefixes (and thus non-trivial tries).+newtype WS = WS { unWS :: S.ByteString }+ deriving (Eq, Ord)++instance Show WS where+ showsPrec p = showsPrec p . unWS++packWS :: [W] -> WS+packWS = WS . S.pack . map unW++unpackWS :: WS -> [W]+unpackWS = map W . S.unpack . unWS++-- | Like 'S.inits' but each step keeps half more, rather than just one more.+prefixes :: WS -> [WS]+prefixes (WS (PS x s l)) =+ [WS (PS x s (l - k)) | k <- takeWhile (> 0) (iterate (`div` 2) l)]++instance QC.Arbitrary WS where+ arbitrary = QC.sized $ \n -> do+ k <- QC.chooseInt (0,n)+ xs <- QC.vector k+ return $ packWS xs+ shrink = QC.shrinkMap packWS unpackWS <=< prefixes++instance QC.CoArbitrary WS where+ coarbitrary = QC.coarbitrary . unpackWS++instance Monad m => SC.Serial m WS where+ series = packWS <$> SC.series++-- TODO: While this is a perfectly valid instance, is it really the+-- most efficient one for our needs?+instance Monad m => SC.CoSerial m WS where+ coseries rs =+ SC.alts0 rs SC.>>- \z ->+ SC.alts2 rs SC.>>- \f ->+ return $ \(WS xs) ->+ if S.null xs+ then z+ else f (W $ S.head xs) (WS $ S.tail xs)++----------------------------------------------------------------+-- | A subset of 'T.Trie' where all the keys are 'WS'. This newtype+-- is mainly just to avoid orphan instances.+newtype WTrie a = WT { unWT :: T.Trie a }+ deriving (Eq)++instance Show a => Show (WTrie a) where+ showsPrec p = showsPrec p . unWT++first :: (b -> c) -> (b,d) -> (c,d)+first f (x,y) = (f x, y)++-- TODO: maybe we ought to define @T.fromListBy@ for better fusion?+fromListWT :: [(WS,a)] -> WTrie a+fromListWT = WT . T.fromList . map (first unWS)++-- We can use 'T.toListBy' to manually fuse with the map+toListWT :: WTrie a -> [(WS,a)]+toListWT = map (first WS) . T.toList . unWT++instance (QC.Arbitrary a) => QC.Arbitrary (WTrie a) where+ arbitrary = QC.sized $ \n -> do+ k <- QC.chooseInt (0,n)+ labels <- QC.vector k+ elems <- QC.vector k+ return . fromListWT $ zip labels elems+ -- Extremely inefficient, but should be effective at least.+ shrink = QC.shrinkMap fromListWT toListWT++-- TODO: instance QC.CoArbitrary (WTrie a)++-- TODO: This instance really needs some work. The smart constructures+-- ensure only valid values are generated, but there are redundancies+-- and inefficiencies.+instance (Monad m, SC.Serial m a) => SC.Serial m (WTrie a) where+ series = SC.cons0 (WT T.empty)+ SC.\/ SC.cons3 arcHACK+ SC.\/ SC.cons2 branch+ where+ arcHACK (WS k) mv (WT t) =+ case mv of+ Nothing -> WT (T.singleton k () >> t)+ Just v -> WT (T.singleton k v >>= T.unionR t . T.singleton S.empty)++ branch (WT t0) (WT t1) = WT (t0 `T.unionR` t1)++-- TODO: instance Monad m => SC.CoSerial m (WTrie a)++----------------------------------------------------------------+----------------------------------------------------------------++infixr 0 ==>, .==>.+infix 4 .==.++{-+-- TODO: clean up something like this:+class ForAll src p q where+ forAll :: forall a. (Show a) => src a -> (a -> p) -> q+instance (QC.Testable p) => ForAll QC.Gen p QC.Property where+ forAll gen pf = QC.forAllShrink gen QC.shrink pf+instance (SC.Testable m p) => ForAll (SC.Series m) p (SC.Property m) where+ forAll srs pf = SC.forAll (SC.over srs pf)++class SuchThat src where+ suchThat :: forall a. src a -> (a -> Bool) -> src a+instance SuchThat QC.Gen where+ suchThat = QC.suchThat+instance SuchThat (SC.Series m) where+ suchThat = flip Control.Monad.mfilter++class Generable src a where+ generate :: src a+instance (QC.Arbitrary a) => Generable QC.Gen a where+ generate = QC.arbitrary+instance (SC.Serial m a) => Generable (SC.Series m) a where+ generate = SC.series++forEach :: (Forall src p q, SuchThat src, Generable src a, Show a) => (a -> Bool) -> (a -> p) -> q+forEach = forAll . suchThat generate+-}+++-- | Deal with QC\/SC polymorphism issues because of @(==>)@.+-- Fundeps would be nice here, but @|b->a@ is undecidable, and @|a->b@ is wrong.+class CheckGuard p q where+ (==>) :: Bool -> p -> q++instance (QC.Testable p) => CheckGuard p QC.Property where+ (==>) = (QC.==>)+ -- TODO: might should also use 'QC.cover' with this.+ -- TODO: or we may prefer to rephrase things to use 'QC.suchThat' instead (should be sufficient for our particular use case, if we can find a smallcheck analogue (probably 'SC.over'))++instance (Monad m, SC.Testable m p) => CheckGuard p (SC.Property m) where+ (==>) = (SC.==>)++-- | Lifted implication.+(.==>.) :: CheckGuard testable prop => (a -> Bool) -> (a -> testable) -> (a -> prop)+(.==>.) p q x = p x ==> q x++-- | Function equality / lifted equality.+(.==.) :: (Eq b) => (a -> b) -> (a -> b) -> (a -> Bool)+(.==.) f g x = f x == g x+ -- TODO: should use (QC.===) or diy with QC.counterexample; assuming we can overload that for smallcheck equivalent (or for smallcheck to ignore and fall back to (==))++----------------------------------------------------------------+----------------------------------------------------------- fin.