diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -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: + + + - 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): diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/bytestring-trie.cabal b/bytestring-trie.cabal --- a/bytestring-trie.cabal +++ b/bytestring-trie.cabal @@ -1,5 +1,5 @@ ---------------------------------------------------------------- --- wren gayle romano ~ 2021.11.02 +-- wren gayle romano ~ 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. diff --git a/src/Data/Trie.hs b/src/Data/Trie.hs --- a/src/Data/Trie.hs +++ b/src/Data/Trie.hs @@ -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. diff --git a/src/Data/Trie/ByteStringInternal.hs b/src/Data/Trie/ByteStringInternal.hs --- a/src/Data/Trie/ByteStringInternal.hs +++ b/src/Data/Trie/ByteStringInternal.hs @@ -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) diff --git a/src/Data/Trie/Convenience.hs b/src/Data/Trie/Convenience.hs --- a/src/Data/Trie/Convenience.hs +++ b/src/Data/Trie/Convenience.hs @@ -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. diff --git a/src/Data/Trie/Internal.hs b/src/Data/Trie/Internal.hs --- a/src/Data/Trie/Internal.hs +++ b/src/Data/Trie/Internal.hs @@ -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. +-- +#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 -- -- @@ -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) ------------------------------------------------------------ diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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. diff --git a/test/Utils.hs b/test/Utils.hs new file mode 100644 --- /dev/null +++ b/test/Utils.hs @@ -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. +-- +-- * '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.