-- Not using -Wcompat, because it wants outdated things for GHC 8.0/8.2
{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
-- Note: can also pass show-extensions to get Haddock to show
-- everything implicit/entailed by the things we actually request.
-- Apparently we're getting: MonoLocalBinds, KindSignatures,
-- ExplicitNamespaces; regardless of whether we set the default to Haskell98 or Haskell2010
{-# OPTIONS_HADDOCK not-home #-}

{-# LANGUAGE NoImplicitPrelude, CPP, BangPatterns #-}
#if __GLASGOW_HASKELL__ >= 708
-- For defining the 'IsList' instance.
{-# LANGUAGE TypeFamilies #-}
#endif
#if __GLASGOW_HASKELL__ >= 701
-- Alas, "GHC.Exts" isn't considered safe, even though 'build' and
-- 'IsList'(..) surely are.
{-# LANGUAGE Trustworthy #-}
#endif
------------------------------------------------------------
--                                              ~ 2022.03.13
-- |
-- Module      :  Data.Trie.Internal
-- Copyright   :  2008--2022 wren romano
-- License     :  BSD-3-Clause
-- Maintainer  :  wren@cpan.org
-- Stability   :  experimental
-- Portability :  portable (with CPP)
--
-- Internal definition of the 'Trie' data type and generic functions
-- for manipulating them. Almost everything here is re-exported
-- from "Data.Trie", which is the preferred API for users. This
-- module is for developers who need deeper (and less stable) access
-- to the abstract type.
--
-- @since 0.1.3
------------------------------------------------------------

module Data.Trie.Internal
    (
    -- * Data types
      Trie()
    -- BUG: can't seem to put this at the top: it'll gobble up the
    -- following section name and replace it.  (I'm guessing that's
    -- something to do with the section not having any exported
    -- entities?)
    -- *** Performance Warning
    -- $bug25

    -- * Basic functions
    , empty, null, singleton, size

    -- * List-conversion functions
    , fromList
    , toList, toListBy, elems

    -- * Query functions
    , lookupBy_, submap
    , match_, matches_

    -- * Simple modification
    , alterBy, alterBy_, adjust

    -- * Combining tries
    , wip_unionWith
    , mergeBy, intersectBy

    -- * Priority-queue functions
    , minAssoc, maxAssoc
    , updateMinViewBy, updateMaxViewBy

    -- * Mapping, filtering, folding, and traversing
    -- ** Filterable
    , filter
    , filterMap
    , mapBy
    -- ** Witherable
    , filterA
    , wither
    -- TODO: 'witherBy' (effectful 'mapBy')
    -- ** Contextual filtering\/mapping functions
    , contextualMap
    , contextualMap'
    , contextualFilterMap
    , contextualMapBy
    -- TODO: 'contextualWither'
    -- TODO: 'contextualWitherBy' (effectful 'contextualMapBy')
    -- ** Foldable
    , foldrWithKey, foldrWithKey', foldlWithKey, foldlWithKey'
    , cata_, cata
    -- ** Traverse
    , traverseWithKey

    -- * Internal utility functions
    , showTrie
    , breakMaximalPrefix
    ) where

import Prelude hiding      (null, lookup, filter)

import qualified Data.ByteString as S
import qualified Data.ByteString.Unsafe as SU
import Data.Trie.Internal.ByteString
import Data.Trie.Internal.BitTwiddle
import Data.Trie.Internal.Errors    (impossible)

import Data.Binary         (Binary(..), Get, Word8)
import Data.Bits           (xor)

#if MIN_VERSION_base(4,9,0)
-- [aka GHC 8.0.1]: "Data.Semigroup" added to base.
--
-- Note: [base-4.13.0 / GHC 8.8.1] has Prelude re-export 'Semigroup'
-- (the class name) and 'Data.Semigroup.<>'; however it does not
-- re-export 'stimes' nor (I assume) 'sconcat'!
import Data.Semigroup      (Semigroup(..))
#endif
#if !(MIN_VERSION_base(4,8,0))
-- [aka GHC 7.10.1]: Prelude re-exports 'Monoid'.
import Data.Monoid         (Monoid(..))
#endif

import Control.DeepSeq     (NFData(rnf))
import Control.Monad       (liftM3, liftM4)

import qualified Data.Foldable as F
-- [base-4.10.0.0 / GHC 8.2.1] moved 'liftA2' into the 'Applicative'
-- class for performance reasons; so we want to use it wherever
-- possible, for those same performance reasons.  However, while
-- the Prelude re-exports all the other methods of 'Applicative'
-- since base-4.8, it does not re-export 'liftA2' (at least not up
-- through base-4.16.0.0 / GHC 9.2.1).
import Control.Applicative (liftA2)
#if MIN_VERSION_base(4,8,0)
-- [aka GHC 7.10.1]: Prelude re-exports 'Applicative', @(<$>)@,
-- 'Foldable', and 'Traversable'. But not 'liftA2'.
#else
import Control.Applicative (Applicative(..), (<$>))
import Data.Foldable       (Foldable())
import Data.Traversable    (Traversable(traverse))
#endif

#if MIN_VERSION_base(4,9,0)
import Data.Functor.Classes (Eq1(..), Ord1(..), Show1(..), Read1(..))
import qualified Data.Functor.Classes as FC
#endif

#ifdef __GLASGOW_HASKELL__
import qualified Text.Read as R
import GHC.Exts (build)
#endif
#if __GLASGOW_HASKELL__ >= 708
import qualified GHC.Exts (IsList(..))
#endif

------------------------------------------------------------
------------------------------------------------------------
-- $bug25
-- #bug25#
-- Many (but not all) functions which need to reconstruct bytestrings
-- suffer from an asymptotic slowdown; see:
-- <https://github.com/wrengr/bytestring-trie/issues/25 Bug #25>.
-- For clarity, all functions affected by this bug will have a link
-- to this section.  This is not a new bug, it has affected all
-- prior versions of this library as well.  However, compared to
-- older versions, /bytestring-trie-0.2.7/ mitigates the severity
-- of the bug, and in certain cases to avoids it entirely.
--
-- In particular, this affects the \"keyed\" variants of functions
-- (for folding, traversing, filtering, etc), and anything built
-- from them, including 'toListBy' and various instances which use
-- it.
--
-- Conversely, functions which are unaffected include: those like
-- 'alterBy' which merely pass the query back to the user as a
-- convenience; those which only need to reconstruct a single
-- bytestring (e.g., the priority-queue functions); and
-- 'Data.Trie.matches'\/'matches_'.


------------------------------------------------------------
-- | Infix variant of 'uncurry'.  Currently only used in 'alterBy_'.
-- The fixity-level is like @(<$>)@; but I'm making it nonassociative
-- to avoid any possible\/potential confusion.
infix 4 $$
($$) :: (a -> b -> c) -> (a, b) -> c
$$ :: (a -> b -> c) -> (a, b) -> c
($$) = (a -> b -> c) -> (a, b) -> c
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry
{-# INLINE ($$) #-}

{-----------------------------------------------------------
-- ByteString Big-endian Patricia Trie datatype
-----------------------------------------------------------}
{-
In our idealized representation, we use a (directed) discrete graph
to represent our finite state machine. To organize the set of
outgoing arcs from a given Node we have ArcSet be a big-endian
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)
    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]: 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.

    newtype NonEmptyBS = NonEmptyBS ByteString  -- Invariant: never null.
    newtype NullableBS = NullableBS Bytestring  -- May be null.

    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 Accept and Reject together:
Maybe[2] beneficial.  However, 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)

[2]: The above change is certainly beneficial from the perspective
of source-code size/repetition for 'mergeBy', 'intersectBy', and
other operations that operate on two tries in tandem; though it's
unclear whether/how much that transfers to compiled-code size/bloat.
Also since the 'Maybe' isn't unpacked, this introduces an additional
indirection to reach values.  Starting at version 0.2.7 there's an
ongoing effort to try to determine whether this change is beneficial
or not, and to quantify how much it affects things.

** 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 Empty/None and Arc/Start together:
Alas, this complicates the invariants about non-null 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: null 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.
-}


-- [Note: Order of constructors]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- As discussed in "Data.IntMap.Internal", the order of constructors
-- in the definition is the order in which case analysis will always
-- test them.  On GHC 9.2.1 I haven't noticed a significant difference
-- from changing the order, but that could be due to bad benchmarking
-- (i.e., reusing the test suite); so I'll trust that this hasn't
-- changed so much since GHC 7.0.  The only question is whether
-- @Arc@ or @Branch@ should come first, which depends a lot on the
-- dataset being used.
--
-- This reordering change was performed for version 0.2.7
-- <https://github.com/wrengr/bytestring-trie/commit/75f3d32f7de7457dc7d029b60be3cce8b99c5e80>


-- | A map from 'ByteString's to @a@. For all the generic functions,
-- note that tries are strict in the @Maybe@ but not in @a@.
--
-- The 'Monad' instance is strange. If a key @k1@ is a prefix of
-- other keys, then results from binding the value at @k1@ will
-- override values from longer keys when they collide. If this is
-- useful for anything, or if there's a more sensible instance, I'd
-- be curious to know.

data Trie a
    = Branch {-# UNPACK #-} !Prefix
             {-# UNPACK #-} !Mask
                            !(Trie a) -- Must not be @Empty@.
                            !(Trie a) -- Must not be @Empty@.
    | Arc    {-# UNPACK #-} !ByteString -- Has nontrivial invariants.
                            !(Maybe a)
                            !(Trie a) -- Has complex invariants.
    | Empty
    deriving Trie a -> Trie a -> Bool
(Trie a -> Trie a -> Bool)
-> (Trie a -> Trie a -> Bool) -> Eq (Trie a)
forall a. Eq a => Trie a -> Trie a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Trie a -> Trie a -> Bool
$c/= :: forall a. Eq a => Trie a -> Trie a -> Bool
== :: Trie a -> Trie a -> Bool
$c== :: forall a. Eq a => Trie a -> Trie a -> Bool
Eq
    -- Prefix/Mask should be deterministic regardless of insertion order
    -- TODO: prove this is so.


{-----------------------------------------------------------
-- Smart constructors
-----------------------------------------------------------}

{-
-- | A common precondition for ensuring the safety of the following
-- smart constructors.
ifJustThenNoEpsilon :: Maybe a -> Trie a -> Bool
ifJustThenNoEpsilon (Just _) (Arc k (Just _) _) = not (S.null k)
ifJustThenNoEpsilon _ _ = True
-}

-- FIXME: [bug26] <https://github.com/wrengr/bytestring-trie/issues/26>
-- We need to adjust 'arc', 'prepend', 'arcNN', and 'prependNN' to behave
-- more like a zipper, to avoid asymptotic slowdown in corner cases.

-- | Smart constructor to prune @Arc@s that lead nowhere.
--
-- __Preconditions__
-- * @arc _ mv t | ifJustThenNoEpsilon mv t@
arc :: ByteString -> Maybe a -> Trie a -> Trie a
{-# INLINE arc #-}
arc :: ByteString -> Maybe a -> Trie a -> Trie a
arc !ByteString
k mv :: Maybe a
mv@(Just a
_) = ByteString -> Maybe a -> Trie a -> Trie a
forall a. ByteString -> Maybe a -> Trie a -> Trie a
Arc ByteString
k Maybe a
mv
arc  ByteString
k    Maybe a
Nothing  = ByteString -> Trie a -> Trie a
forall a. ByteString -> Trie a -> Trie a
prepend ByteString
k

-- | Variant of 'arc' where the string is known to be non-null.
--
-- __Preconditions__
-- * @arcNN k _  _ | not (S.null k)@
-- * @arcNN _ mv t | ifJustThenNoEpsilon mv t@
arcNN :: ByteString -> Maybe a -> Trie a -> Trie a
{-# INLINE arcNN #-}
arcNN :: ByteString -> Maybe a -> Trie a -> Trie a
arcNN !ByteString
k mv :: Maybe a
mv@(Just a
_) = ByteString -> Maybe a -> Trie a -> Trie a
forall a. ByteString -> Maybe a -> Trie a -> Trie a
Arc ByteString
k Maybe a
mv
arcNN  ByteString
k    Maybe a
Nothing  = ByteString -> Trie a -> Trie a
forall a. ByteString -> Trie a -> Trie a
prependNN ByteString
k

-- | Prepend a possibly-null string to a trie.
--
-- This function is only very rarely needed; most of the time you
-- already know that the string is non-null, and thus you can call
-- 'prependNN' directly.
--
-- TODO: may actually consider exporting this one, since it could
-- be generally useful and it has no preconditions.  Of course,
-- it's susceptible to [bug25][bug26] if used incorrectly...
prepend :: ByteString -> Trie a -> Trie a
{-# INLINE prepend #-}
prepend :: ByteString -> Trie a -> Trie a
prepend ByteString
k
    | ByteString -> Bool
S.null ByteString
k  = Trie a -> Trie a
forall a. a -> a
id
    | Bool
otherwise = ByteString -> Trie a -> Trie a
forall a. ByteString -> Trie a -> Trie a
prependNN ByteString
k

-- | Prepend a non-null string to a trie.
--
-- __Preconditions__
-- * @prependNN k _ | not (S.null k)@
prependNN :: ByteString -> Trie a -> Trie a
{-# INLINE prependNN #-}
prependNN :: ByteString -> Trie a -> Trie a
prependNN !ByteString
_ t :: Trie a
t@Trie a
Empty      = Trie a
t
prependNN  ByteString
q t :: Trie a
t@(Branch{}) = ByteString -> Maybe a -> Trie a -> Trie a
forall a. ByteString -> Maybe a -> Trie a -> Trie a
Arc ByteString
q Maybe a
forall a. Maybe a
Nothing Trie a
t
prependNN  ByteString
q (Arc ByteString
k Maybe a
mv Trie a
s) = ByteString -> Maybe a -> Trie a -> Trie a
forall a. ByteString -> Maybe a -> Trie a -> Trie a
Arc (ByteString -> ByteString -> ByteString
S.append ByteString
q ByteString
k) Maybe a
mv Trie a
s
    -- TODO: see [bug26]; should ensure that callers do not nest
    -- calls to this function which all take this @Arc@ case.

-- | > mayEpsilon mv ≡ arc S.empty mv
--
-- __Preconditions__
-- * @mayEpsilon mv t | ifJustThenNoEpsilon mv t@
mayEpsilon :: Maybe a -> Trie a -> Trie a
{-# INLINE mayEpsilon #-}
mayEpsilon :: Maybe a -> Trie a -> Trie a
mayEpsilon (Just a
v) = a -> Trie a -> Trie a
forall a. a -> Trie a -> Trie a
epsilon a
v
mayEpsilon Maybe a
Nothing  = Trie a -> Trie a
forall a. a -> a
id

-- | Canonical name for the empty arc at the top of the trie.
--
-- > epsilon ≡ Arc S.empty . Just
--
-- __Preconditions__
-- * The trie argument must not already have an epsilon value.
epsilon :: a -> Trie a -> Trie a
{-# INLINE epsilon #-}
epsilon :: a -> Trie a -> Trie a
epsilon = ByteString -> Maybe a -> Trie a -> Trie a
forall a. ByteString -> Maybe a -> Trie a -> Trie a
Arc ByteString
S.empty (Maybe a -> Trie a -> Trie a)
-> (a -> Maybe a) -> a -> Trie a -> Trie a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe a
forall a. a -> Maybe a
Just


-- | Smart @Branch@ constructor: prunes @Empty@ on both sides.
-- This function does no other work besides pruning, so the @Prefix@,
-- @Mask@, and ordering of the 'Trie's must all be as if calling
-- the @Branch@ constructor directly.
branch :: Prefix -> Mask -> Trie a -> Trie a -> Trie a
{-# INLINE branch #-}
branch :: Prefix -> Prefix -> Trie a -> Trie a -> Trie a
branch !Prefix
_ !Prefix
_ Trie a
Empty Trie a
r     = Trie a
r
branch  Prefix
_  Prefix
_ Trie a
l     Trie a
Empty = Trie a
l
branch  Prefix
p  Prefix
m Trie a
l     Trie a
r     = Prefix -> Prefix -> Trie a -> Trie a -> Trie a
forall a. Prefix -> Prefix -> Trie a -> Trie a -> Trie a
Branch Prefix
p Prefix
m Trie a
l Trie a
r

-- | Smart @Branch@ constructor: prunes @Empty@ on left side only.
--
-- __Preconditions__
-- * the right trie is not @Empty@.
branchL :: Prefix -> Mask -> Trie a -> Trie a -> Trie a
{-# INLINE branchL #-}
branchL :: Prefix -> Prefix -> Trie a -> Trie a -> Trie a
branchL !Prefix
_ !Prefix
_ Trie a
Empty Trie a
r = Trie a
r
branchL  Prefix
p  Prefix
m Trie a
l     Trie a
r = Prefix -> Prefix -> Trie a -> Trie a -> Trie a
forall a. Prefix -> Prefix -> Trie a -> Trie a -> Trie a
Branch Prefix
p Prefix
m Trie a
l Trie a
r

-- | Smart @Branch@ constructor: prunes @Empty@ on right side only.
--
-- __Preconditions__
-- * the left trie is not @Empty@.
branchR :: Prefix -> Mask -> Trie a -> Trie a -> Trie a
{-# INLINE branchR #-}
branchR :: Prefix -> Prefix -> Trie a -> Trie a -> Trie a
branchR !Prefix
_ !Prefix
_ Trie a
l Trie a
Empty = Trie a
l
branchR  Prefix
p  Prefix
m Trie a
l Trie a
r     = Prefix -> Prefix -> Trie a -> Trie a -> Trie a
forall a. Prefix -> Prefix -> Trie a -> Trie a -> Trie a
Branch Prefix
p Prefix
m Trie a
l Trie a
r

-- | Smart constructor to join two tries into a @Branch@ with maximal
-- prefix sharing, and in the correct left\/right order.  Requires
-- knowing the prefixes, but can combine either @Branch@es or @Arc@s.
--
-- __Preconditions__
-- * Both tries must be non-@Empty@.
-- * The two prefixes /must not/ be able to match entirely!
graft :: Prefix -> Trie a -> Prefix -> Trie a -> Trie a
{-# INLINE graft #-}
graft :: Prefix -> Trie a -> Prefix -> Trie a -> Trie a
graft Prefix
p0 Trie a
t0 Prefix
p1 Trie a
t1
    | Prefix -> Prefix -> Bool
zero Prefix
p0 Prefix
m = Prefix -> Prefix -> Trie a -> Trie a -> Trie a
forall a. Prefix -> Prefix -> Trie a -> Trie a -> Trie a
Branch Prefix
p Prefix
m Trie a
t0 Trie a
t1
    | Bool
otherwise = Prefix -> Prefix -> Trie a -> Trie a -> Trie a
forall a. Prefix -> Prefix -> Trie a -> Trie a -> Trie a
Branch Prefix
p Prefix
m Trie a
t1 Trie a
t0
    where
    m :: Prefix
m = Prefix -> Prefix -> Prefix
getMask Prefix
p0 Prefix
p1
    p :: Prefix
p = Prefix -> Prefix -> Prefix
applyMask Prefix
p0 Prefix
m

-- | Shorthand for prepending a non-null string to a 'graft'.  This
-- is mainly useful for when @(p,k0,k1)@ came from 'breakMaximalPrefix'.
--
-- __Preconditions__
-- * The prefix must be non-null.
-- * Each trie must agree with their key (hence must also be non-@Empty@).
-- * The keys must not have matching prefixes.
wye :: ByteString
    -> ByteString -> Trie a
    -> ByteString -> Trie a
    -> Trie a
wye :: ByteString
-> ByteString -> Trie a -> ByteString -> Trie a -> Trie a
wye ByteString
p ByteString
k0 Trie a
t0 ByteString
k1 Trie a
t1 =
    ByteString -> Maybe a -> Trie a -> Trie a
forall a. ByteString -> Maybe a -> Trie a -> Trie a
Arc ByteString
p Maybe a
forall a. Maybe a
Nothing (Trie a -> Trie a) -> Trie a -> Trie a
forall a b. (a -> b) -> a -> b
$ Prefix -> Trie a -> Prefix -> Trie a -> Trie a
forall a. Prefix -> Trie a -> Prefix -> Trie a -> Trie a
graft (ByteString -> Prefix
arcPrefix ByteString
k0) Trie a
t0 (ByteString -> Prefix
arcPrefix ByteString
k1) Trie a
t1

-- TODO: this is only used by 'mergeBy' (since 'intersectBy' returns
-- @Empty@ in lieu of @Branch@ for the latter cases); so maybe we
-- should move this to be a local definition there?
--
-- | Smart constructor to join two @Arc@s into a @Branch@ when possible,
-- and to 'breakMaximalPrefix' otherwise.
--
-- __Preconditions__
-- * Both tries must be non-@Empty@.
arcMerge
    :: ByteString -> Trie a
    -> ByteString -> Trie a
    -> (ByteString -> ByteString -> ByteString -> Trie a)
    -> Trie a
{-# INLINE arcMerge #-}
arcMerge :: ByteString
-> Trie a
-> ByteString
-> Trie a
-> (ByteString -> ByteString -> ByteString -> Trie a)
-> Trie a
arcMerge ByteString
k0 Trie a
t0 ByteString
k1 Trie a
t1 ByteString -> ByteString -> ByteString -> Trie a
whenMatch
    | Prefix
m Prefix -> Prefix -> Bool
forall a. Eq a => a -> a -> Bool
== Prefix
0 =
        case ByteString -> ByteString -> (ByteString, ByteString, ByteString)
breakMaximalPrefix ByteString
k0 ByteString
k1 of
        (ByteString
pre, ByteString
k0', ByteString
k1')
            -- TODO: change this into an 'assert' instead.
            | ByteString -> Bool
S.null ByteString
pre -> String -> Trie a
forall a. String -> a
impossible String
"arcMerge" -- perfect 'arcPrefix' match, yet no 'breakMaximalPrefix' prefix.
            | Bool
otherwise  -> ByteString -> ByteString -> ByteString -> Trie a
whenMatch ByteString
pre ByteString
k0' ByteString
k1'
    | Prefix -> Prefix -> Bool
zero Prefix
p0 Prefix
m = Prefix -> Prefix -> Trie a -> Trie a -> Trie a
forall a. Prefix -> Prefix -> Trie a -> Trie a -> Trie a
Branch Prefix
p Prefix
m Trie a
t0 Trie a
t1
    | Bool
otherwise = Prefix -> Prefix -> Trie a -> Trie a -> Trie a
forall a. Prefix -> Prefix -> Trie a -> Trie a -> Trie a
Branch Prefix
p Prefix
m Trie a
t1 Trie a
t0
    where
    p0 :: Prefix
p0 = ByteString -> Prefix
arcPrefix ByteString
k0
    p1 :: Prefix
p1 = ByteString -> Prefix
arcPrefix ByteString
k1
    m :: Prefix
m  = Prefix -> Prefix -> Prefix
getMask Prefix
p0 Prefix
p1
    p :: Prefix
p  = Prefix -> Prefix -> Prefix
applyMask Prefix
p0 Prefix
m

-- It would be better if arcs used
-- 'Data.ByteString.TrieInternal.wordHead' somehow, that way
-- we can see 4/8/?*Word8 at a time instead of just one.
-- But that makes maintaining invariants ...difficult :(

-- | Get the equivalent of the @Prefix@ stored in a @Branch@, but
-- for an @Arc@.
arcPrefix :: ByteString -> Prefix
{-# INLINE arcPrefix #-}
arcPrefix :: ByteString -> Prefix
arcPrefix ByteString
k
    | ByteString -> Bool
S.null ByteString
k  = Prefix
0 -- for lack of a better value
    | Bool
otherwise = ByteString -> Prefix
SU.unsafeHead ByteString
k


{-----------------------------------------------------------
-- Error messages
-----------------------------------------------------------}

-- 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...
-- TODO: this is almost identical to 'arcPrefix'; the only difference
-- is that we use this one for matching a query against a trie,
-- whereas we use 'arcPrefix' when matching two tries together.
-- That said, since our test suite never throws this error, it
-- should be safe to use 'arcPrefix' everywhere instead.  Or, if
-- we want to preserve the semantic distinction, then we could start
-- using 'Control.Exception.assert' to hoist the null-check out to
-- where it belongs and still allow it to compile away.  Conversely,
-- note that 'arcPrefix' is never called with a null string either
-- (since null strings are only ever allowed for epsilon values;
-- and all the use-sites of 'arcPrefix' are after handling those
-- epsilons, or otherwise guarded).
errorLogHead :: String -> ByteString -> ByteStringElem
{-# NOINLINE errorLogHead #-}
errorLogHead :: String -> ByteString -> Prefix
errorLogHead String
fn ByteString
q
    | ByteString -> Bool
S.null ByteString
q  = String -> Prefix
forall a. HasCallStack => String -> a
error (String -> Prefix) -> String -> Prefix
forall a b. (a -> b) -> a -> b
$ String
"Data.Trie.Internal." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fn String -> String -> String
forall a. [a] -> [a] -> [a]
++String
": found null subquery"
    | Bool
otherwise = ByteString -> Prefix
SU.unsafeHead ByteString
q

------------------------------------------------------------
------------------------------------------------------------


{-----------------------------------------------------------
-- Instances: Eq, Eq1
-----------------------------------------------------------}

{-
-- (2021.12.31): remove the definition of @(/=)@ for:
-- <https://github.com/haskell/core-libraries-committee/issues/3>
--
-- 'IntMap' defines their own instance so as to check the Mask
-- before the Prefix; and they have done so since at least version
-- 0.5.0.0 (2011).  So I assume the performance benefits of doing
-- that are good enough to be worth it; thus, we'll do the same.
--
-- TODO: benchmark!!
instance Eq a => Eq (Trie a) where
    (==) = equal

-- TODO: mark this INLINABLE to specialize on the Eq instance?  Why doesn't IntMap?
-- TODO: Alternatively, why doesn't IntMap simply reuse the 'liftEq' implementation?
equal :: Eq a => Trie a -> Trie a -> Bool
equal (Branch p0 m0 l0 r0)
      (Branch p1 m1 l1 r1) = m0 == m1 && p0 == p1 && equal l0 l1 && equal r0 r1
equal (Arc k0 mv0 t0)
      (Arc k1 mv1 t1)      = k0 == k1 && mv0 == mv1 && equal t0 t1
equal Empty Empty          = True
equal _     _              = False
-}

#if MIN_VERSION_base(4,9,0)
-- | @since 0.2.7
instance Eq1 Trie where
  liftEq :: (a -> b -> Bool) -> Trie a -> Trie b -> Bool
liftEq = (a -> b -> Bool) -> Trie a -> Trie b -> Bool
forall a b. (a -> b -> Bool) -> Trie a -> Trie b -> Bool
equal1

-- TODO: why doesn't IntMap close over @eq@?  Does it really cost so much more?
-- TODO: INLINEABLE?
equal1 :: (a -> b -> Bool) -> Trie a -> Trie b -> Bool
equal1 :: (a -> b -> Bool) -> Trie a -> Trie b -> Bool
equal1 a -> b -> Bool
eq (Branch Prefix
p0 Prefix
m0 Trie a
l0 Trie a
r0) (Branch Prefix
p1 Prefix
m1 Trie b
l1 Trie b
r1) =
    Prefix
m0 Prefix -> Prefix -> Bool
forall a. Eq a => a -> a -> Bool
== Prefix
m1 Bool -> Bool -> Bool
&& Prefix
p0 Prefix -> Prefix -> Bool
forall a. Eq a => a -> a -> Bool
== Prefix
p1 Bool -> Bool -> Bool
&& (a -> b -> Bool) -> Trie a -> Trie b -> Bool
forall a b. (a -> b -> Bool) -> Trie a -> Trie b -> Bool
equal1 a -> b -> Bool
eq Trie a
l0 Trie b
l1 Bool -> Bool -> Bool
&& (a -> b -> Bool) -> Trie a -> Trie b -> Bool
forall a b. (a -> b -> Bool) -> Trie a -> Trie b -> Bool
equal1 a -> b -> Bool
eq Trie a
r0 Trie b
r1
equal1 a -> b -> Bool
eq (Arc ByteString
k0 Maybe a
mv0 Trie a
t0) (Arc ByteString
k1 Maybe b
mv1 Trie b
t1) =
    ByteString
k0 ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
k1 Bool -> Bool -> Bool
&& (a -> b -> Bool) -> Maybe a -> Maybe b -> Bool
forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq a -> b -> Bool
eq Maybe a
mv0 Maybe b
mv1 Bool -> Bool -> Bool
&& (a -> b -> Bool) -> Trie a -> Trie b -> Bool
forall a b. (a -> b -> Bool) -> Trie a -> Trie b -> Bool
equal1 a -> b -> Bool
eq Trie a
t0 Trie b
t1
equal1 a -> b -> Bool
_ Trie a
Empty Trie b
Empty = Bool
True
equal1 a -> b -> Bool
_ Trie a
_     Trie b
_     = Bool
False
#endif

{-----------------------------------------------------------
-- Instances: Ord, Ord1
-----------------------------------------------------------}

-- |
-- __Warning__: This instance suffers unnecessarily from
-- <Data-Trie-Internal.html#bug25 Bug #25>.
--
-- @since 0.2.7
instance Ord a => Ord (Trie a) where
    compare :: Trie a -> Trie a -> Ordering
compare Trie a
t0 Trie a
t1 = [(ByteString, a)] -> [(ByteString, a)] -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Trie a -> [(ByteString, a)]
forall a. Trie a -> [(ByteString, a)]
toList Trie a
t0) (Trie a -> [(ByteString, a)]
forall a. Trie a -> [(ByteString, a)]
toList Trie a
t1)

#if MIN_VERSION_base(4,9,0)
-- |
-- __Warning__: This instance suffers unnecessarily from
-- <Data-Trie-Internal.html#bug25 Bug #25>.
--
-- @since 0.2.7
instance Ord1 Trie where
    liftCompare :: (a -> b -> Ordering) -> Trie a -> Trie b -> Ordering
liftCompare a -> b -> Ordering
cmp Trie a
t0 Trie b
t1 =
        ((ByteString, a) -> (ByteString, b) -> Ordering)
-> [(ByteString, a)] -> [(ByteString, b)] -> Ordering
forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompare ((a -> b -> Ordering)
-> (ByteString, a) -> (ByteString, b) -> Ordering
forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompare a -> b -> Ordering
cmp) (Trie a -> [(ByteString, a)]
forall a. Trie a -> [(ByteString, a)]
toList Trie a
t0) (Trie b -> [(ByteString, b)]
forall a. Trie a -> [(ByteString, a)]
toList Trie b
t1)
#endif

{-----------------------------------------------------------
-- Instances: Show, Show1
-----------------------------------------------------------}

-- This instance does not unveil the innards of our abstract type.
-- It doesn't emit truly proper Haskell code though, since ByteStrings
-- are printed as (ASCII) Strings, but that's not our fault.
--
-- |
-- __Warning__: This instance suffers <Data-Trie-Internal.html#bug25 Bug #25>.
--
-- @since 0.2.2
instance (Show a) => Show (Trie a) where
    showsPrec :: Int -> Trie a -> String -> String
showsPrec Int
p Trie a
t = Bool -> (String -> String) -> String -> String
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10)
                  ((String -> String) -> String -> String)
-> (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ (String
"fromList " String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(ByteString, a)] -> String -> String
forall a. Show a => a -> String -> String
shows (Trie a -> [(ByteString, a)]
forall a. Trie a -> [(ByteString, a)]
toList Trie a
t)

#if MIN_VERSION_base(4,9,0)
-- |
-- __Warning__: This instance suffers <Data-Trie-Internal.html#bug25 Bug #25>.
--
-- @since 0.2.7
instance Show1 Trie where
    liftShowsPrec :: (Int -> a -> String -> String)
-> ([a] -> String -> String) -> Int -> Trie a -> String -> String
liftShowsPrec Int -> a -> String -> String
sp [a] -> String -> String
sl Int
p Trie a
t =
        (Int -> [(ByteString, a)] -> String -> String)
-> String -> Int -> [(ByteString, a)] -> String -> String
forall a.
(Int -> a -> String -> String)
-> String -> Int -> a -> String -> String
FC.showsUnaryWith ((Int -> (ByteString, a) -> String -> String)
-> ([(ByteString, a)] -> String -> String)
-> Int
-> [(ByteString, a)]
-> String
-> String
forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> String -> String)
-> ([a] -> String -> String) -> Int -> f a -> String -> String
liftShowsPrec Int -> (ByteString, a) -> String -> String
sp' [(ByteString, a)] -> String -> String
sl') String
"fromList" Int
p (Trie a -> [(ByteString, a)]
forall a. Trie a -> [(ByteString, a)]
toList Trie a
t)
        where
        sp' :: Int -> (ByteString, a) -> String -> String
sp' = (Int -> a -> String -> String)
-> ([a] -> String -> String)
-> Int
-> (ByteString, a)
-> String
-> String
forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> String -> String)
-> ([a] -> String -> String) -> Int -> f a -> String -> String
liftShowsPrec Int -> a -> String -> String
sp [a] -> String -> String
sl
        sl' :: [(ByteString, a)] -> String -> String
sl' = (Int -> a -> String -> String)
-> ([a] -> String -> String)
-> [(ByteString, a)]
-> String
-> String
forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> String -> String)
-> ([a] -> String -> String) -> [f a] -> String -> String
liftShowList  Int -> a -> String -> String
sp [a] -> String -> String
sl
#endif

-- | Visualization fuction for debugging.
showTrie :: (Show a) => Trie a -> String
showTrie :: Trie a -> String
showTrie Trie a
t = (String -> String) -> Trie a -> String -> String
forall a.
Show a =>
(String -> String) -> Trie a -> String -> String
shows' String -> String
forall a. a -> a
id Trie a
t String
""
    where
    spaces :: (String -> [b]) -> String
spaces String -> [b]
f = (b -> Char) -> [b] -> String
forall a b. (a -> b) -> [a] -> [b]
map (Char -> b -> Char
forall a b. a -> b -> a
const Char
' ') (String -> [b]
f String
"")

    shows' :: (String -> String) -> Trie a -> String -> String
shows' String -> String
_  Trie a
Empty            = (String
".\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++)
    shows' String -> String
ss (Branch Prefix
p Prefix
m Trie a
l Trie a
r) =
        let s' :: String -> String
s'  = (String
"--"String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prefix -> String -> String
forall a. Show a => a -> String -> String
shows Prefix
p (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
","String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prefix -> String -> String
forall a. Show a => a -> String -> String
shows Prefix
m (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"-+"String -> String -> String
forall a. [a] -> [a] -> [a]
++)
            ss' :: String -> String
ss' = String -> String
ss (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String
forall a. [a] -> [a]
tail ((String -> String) -> String
forall b. (String -> [b]) -> String
spaces String -> String
s') String -> String -> String
forall a. [a] -> [a] -> [a]
++)
        in String -> String
s'              (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> Trie a -> String -> String
shows' (String -> String
ss' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"|"String -> String -> String
forall a. [a] -> [a] -> [a]
++)) Trie a
l
           (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
ss' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"|\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++)
           (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
ss' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"`"String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> Trie a -> String -> String
shows' (String -> String
ss' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
" "String -> String -> String
forall a. [a] -> [a] -> [a]
++)) Trie a
r
    shows' String -> String
ss (Arc ByteString
k Maybe a
mv Trie a
t') =
        let s' :: String -> String
s' = (String
"--"String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String -> String
forall a. Show a => a -> String -> String
shows ByteString
k
                 (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String)
-> (a -> String -> String) -> Maybe a -> String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String -> String
forall a. a -> a
id (\a
v -> (String
"-("String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String -> String
forall a. Show a => a -> String -> String
shows a
v (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
")"String -> String -> String
forall a. [a] -> [a] -> [a]
++)) Maybe a
mv
                 (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"--"String -> String -> String
forall a. [a] -> [a] -> [a]
++)
        in  String -> String
s' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> Trie a -> String -> String
shows' (String -> String
ss (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String -> String) -> String
forall b. (String -> [b]) -> String
spaces String -> String
s' String -> String -> String
forall a. [a] -> [a] -> [a]
++)) Trie a
t'

{-----------------------------------------------------------
-- Instances: Read, Read1
-----------------------------------------------------------}

-- | @since 0.2.7
instance (Read a) => Read (Trie a) where
#ifdef __GLASGOW_HASKELL__
    readPrec :: ReadPrec (Trie a)
readPrec = ReadPrec (Trie a) -> ReadPrec (Trie a)
forall a. ReadPrec a -> ReadPrec a
R.parens (ReadPrec (Trie a) -> ReadPrec (Trie a))
-> (ReadPrec (Trie a) -> ReadPrec (Trie a))
-> ReadPrec (Trie a)
-> ReadPrec (Trie a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ReadPrec (Trie a) -> ReadPrec (Trie a)
forall a. Int -> ReadPrec a -> ReadPrec a
R.prec Int
10 (ReadPrec (Trie a) -> ReadPrec (Trie a))
-> ReadPrec (Trie a) -> ReadPrec (Trie a)
forall a b. (a -> b) -> a -> b
$ do
        R.Ident String
"fromList" <- ReadPrec Lexeme
R.lexP
        [(ByteString, a)] -> Trie a
forall a. [(ByteString, a)] -> Trie a
fromList ([(ByteString, a)] -> Trie a)
-> ReadPrec [(ByteString, a)] -> ReadPrec (Trie a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadPrec [(ByteString, a)]
forall a. Read a => ReadPrec a
R.readPrec

    readListPrec :: ReadPrec [Trie a]
readListPrec = ReadPrec [Trie a]
forall a. Read a => ReadPrec [a]
R.readListPrecDefault
#else
    readsPrec p = readParen (p > 10) $ \ r0 -> do
        ("fromList", r1) <- lex r0
        (xs, r2) <- reads r1
        return (fromList xs, r2)
#endif

#if MIN_VERSION_base(4,9,0)
-- | @since 0.2.7
instance Read1 Trie where
    liftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (Trie a)
liftReadsPrec Int -> ReadS a
rp ReadS [a]
rl =
        (String -> ReadS (Trie a)) -> Int -> ReadS (Trie a)
forall a. (String -> ReadS a) -> Int -> ReadS a
FC.readsData ((String -> ReadS (Trie a)) -> Int -> ReadS (Trie a))
-> (String -> ReadS (Trie a)) -> Int -> ReadS (Trie a)
forall a b. (a -> b) -> a -> b
$ (Int -> ReadS [(ByteString, a)])
-> String
-> ([(ByteString, a)] -> Trie a)
-> String
-> ReadS (Trie a)
forall a t.
(Int -> ReadS a) -> String -> (a -> t) -> String -> ReadS t
FC.readsUnaryWith ((Int -> ReadS (ByteString, a))
-> ReadS [(ByteString, a)] -> Int -> ReadS [(ByteString, a)]
forall (f :: * -> *) a.
Read1 f =>
(Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a)
liftReadsPrec Int -> ReadS (ByteString, a)
rp' ReadS [(ByteString, a)]
rl')
            String
"fromList" [(ByteString, a)] -> Trie a
forall a. [(ByteString, a)] -> Trie a
fromList
        where
        rp' :: Int -> ReadS (ByteString, a)
rp' = (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (ByteString, a)
forall (f :: * -> *) a.
Read1 f =>
(Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a)
liftReadsPrec Int -> ReadS a
rp ReadS [a]
rl
        rl' :: ReadS [(ByteString, a)]
rl' = (Int -> ReadS a) -> ReadS [a] -> ReadS [(ByteString, a)]
forall (f :: * -> *) a.
Read1 f =>
(Int -> ReadS a) -> ReadS [a] -> ReadS [f a]
liftReadList  Int -> ReadS a
rp ReadS [a]
rl
#endif

{-----------------------------------------------------------
-- Instances: Binary
-----------------------------------------------------------}

{-
-- TODO: consider an instance more like the new one for Data.Map
-- (also for Data.IntMap), that is:
instance (Binary a) => Binary (Set.Set a) where
    put s = put (size s) <> mapM_ put (toAscList s)
    get   = liftM fromDistinctAscList get
-- It would require redoing all the work to split bytestrings, and
-- have the overhead from storing duplicated prefixes, but is forward
-- compatible to whatever representation changes, and doesn't have
-- the invariants problem.
-- BUG: However, that would suffer from
-- <https://github.com/wrengr/bytestring-trie/issues/25>, because
-- 'toList'\/@toAscList@ does.
-}
instance (Binary a) => Binary (Trie a) where
    put :: Trie a -> Put
put Trie a
Empty            = do Prefix -> Put
forall t. Binary t => t -> Put
put (Prefix
0 :: Word8)
    put (Arc ByteString
k Maybe a
mv Trie a
t)     = do Prefix -> Put
forall t. Binary t => t -> Put
put (Prefix
1 :: Word8); ByteString -> Put
forall t. Binary t => t -> Put
put ByteString
k; Maybe a -> Put
forall t. Binary t => t -> Put
put Maybe a
mv; Trie a -> Put
forall t. Binary t => t -> Put
put Trie a
t
    put (Branch Prefix
p Prefix
m Trie a
l Trie a
r) = do Prefix -> Put
forall t. Binary t => t -> Put
put (Prefix
2 :: Word8); Prefix -> Put
forall t. Binary t => t -> Put
put Prefix
p; Prefix -> Put
forall t. Binary t => t -> Put
put Prefix
m; Trie a -> Put
forall t. Binary t => t -> Put
put Trie a
l; Trie a -> Put
forall t. Binary t => t -> Put
put Trie a
r

    -- BUG(github#21): need to verify the invariants!
    get :: Get (Trie a)
get = do Prefix
tag <- Get Prefix
forall t. Binary t => Get t
get :: Get Word8
             case Prefix
tag of
                 Prefix
0 -> Trie a -> Get (Trie a)
forall (m :: * -> *) a. Monad m => a -> m a
return Trie a
forall a. Trie a
Empty
                 Prefix
1 -> (ByteString -> Maybe a -> Trie a -> Trie a)
-> Get ByteString -> Get (Maybe a) -> Get (Trie a) -> Get (Trie a)
forall (m :: * -> *) a1 a2 a3 r.
Monad m =>
(a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r
liftM3 ByteString -> Maybe a -> Trie a -> Trie a
forall a. ByteString -> Maybe a -> Trie a -> Trie a
Arc    Get ByteString
forall t. Binary t => Get t
get Get (Maybe a)
forall t. Binary t => Get t
get Get (Trie a)
forall t. Binary t => Get t
get
                 Prefix
_ -> (Prefix -> Prefix -> Trie a -> Trie a -> Trie a)
-> Get Prefix
-> Get Prefix
-> Get (Trie a)
-> Get (Trie a)
-> Get (Trie a)
forall (m :: * -> *) a1 a2 a3 a4 r.
Monad m =>
(a1 -> a2 -> a3 -> a4 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m r
liftM4 Prefix -> Prefix -> Trie a -> Trie a -> Trie a
forall a. Prefix -> Prefix -> Trie a -> Trie a -> Trie a
Branch Get Prefix
forall t. Binary t => Get t
get Get Prefix
forall t. Binary t => Get t
get Get (Trie a)
forall t. Binary t => Get t
get Get (Trie a)
forall t. Binary t => Get t
get

-- TODO: consider adding _cereal_:'Serialize' instance. (Though that adds dependencies on: array, bytestring-builder, fail, ghc-prim). THe instances for Map/IntMap are similar to the commented ones above, though the getter uses 'fromList' rather than assuming distinct or ascending.

-- TODO: potentially consider <https://github.com/mgsloan/store#readme> as well, though probably not since that has a ton of dependencies.

-- TODO: also consider 'Storable', though that seems less appropriate for data structures than for structs and scalars...

{-----------------------------------------------------------
-- Instances: NFData
-----------------------------------------------------------}

-- | @since 0.2.7
instance NFData a => NFData (Trie a) where
    rnf :: Trie a -> ()
rnf Trie a
Empty            = ()
    rnf (Arc ByteString
_ Maybe a
mv Trie a
t)     = Maybe a -> ()
forall a. NFData a => a -> ()
rnf Maybe a
mv () -> () -> ()
`seq` Trie a -> ()
forall a. NFData a => a -> ()
rnf Trie a
t
    rnf (Branch Prefix
_ Prefix
_ Trie a
l Trie a
r) = Trie a -> ()
forall a. NFData a => a -> ()
rnf Trie a
l () -> () -> ()
`seq` Trie a -> ()
forall a. NFData a => a -> ()
rnf Trie a
r

{-
-- TODO: do we want/need these?
#if __GLASGOW_HASKELL__
instance Data.Data.Data (Trie a) where ...
-- See 'IntMap' for how to do this without sacrificing abstraction.
#endif

-- I think this macro is defined in "containers.h"?
INSTANCE_TYPEABLE(Trie)

-- What about deriving Generic?
-}

{-----------------------------------------------------------
-- Instances: Functor
-----------------------------------------------------------}

-- TODO: IntMap floats the definition of 'fmap' out of the instance
-- so that it can provide rewrite rules (for @map f . map g@ and
-- for @map coerce@).  Should we do the same?
instance Functor Trie where
    fmap :: (a -> b) -> Trie a -> Trie b
fmap a -> b
f = Trie a -> Trie b
go
        where
        go :: Trie a -> Trie b
go Trie a
Empty              = Trie b
forall a. Trie a
Empty
        go (Arc ByteString
k Maybe a
Nothing  Trie a
t) = ByteString -> Maybe b -> Trie b -> Trie b
forall a. ByteString -> Maybe a -> Trie a -> Trie a
Arc ByteString
k Maybe b
forall a. Maybe a
Nothing      (Trie a -> Trie b
go Trie a
t)
        go (Arc ByteString
k (Just a
v) Trie a
t) = ByteString -> Maybe b -> Trie b -> Trie b
forall a. ByteString -> Maybe a -> Trie a -> Trie a
Arc ByteString
k (b -> Maybe b
forall a. a -> Maybe a
Just (a -> b
f a
v)) (Trie a -> Trie b
go Trie a
t)
        go (Branch Prefix
p Prefix
m Trie a
l Trie a
r)   = Prefix -> Prefix -> Trie b -> Trie b -> Trie b
forall a. Prefix -> Prefix -> Trie a -> Trie a -> Trie a
Branch Prefix
p Prefix
m (Trie a -> Trie b
go Trie a
l) (Trie a -> Trie b
go Trie a
r)
#if __GLASGOW_HASKELL__
    -- Non-default definition since 0.2.7
    -- Avoiding closure over @v@ because that's what IntMap does.
    a
_ <$ :: a -> Trie b -> Trie a
<$ Trie b
Empty              = Trie a
forall a. Trie a
Empty
    a
v <$ (Arc ByteString
k Maybe b
Nothing  Trie b
t) = ByteString -> Maybe a -> Trie a -> Trie a
forall a. ByteString -> Maybe a -> Trie a -> Trie a
Arc ByteString
k Maybe a
forall a. Maybe a
Nothing  (a
v a -> Trie b -> Trie a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Trie b
t)
    a
v <$ (Arc ByteString
k (Just b
_) Trie b
t) = ByteString -> Maybe a -> Trie a -> Trie a
forall a. ByteString -> Maybe a -> Trie a -> Trie a
Arc ByteString
k (a -> Maybe a
forall a. a -> Maybe a
Just a
v) (a
v a -> Trie b -> Trie a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Trie b
t)
    a
v <$ (Branch Prefix
p Prefix
m Trie b
l Trie b
r)   = Prefix -> Prefix -> Trie a -> Trie a -> Trie a
forall a. Prefix -> Prefix -> Trie a -> Trie a -> Trie a
Branch Prefix
p Prefix
m (a
v a -> Trie b -> Trie a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Trie b
l) (a
v a -> Trie b -> Trie a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Trie b
r)
#endif

-- TODO: strict version of fmap. Is there a canonical name\/class for this yet?

{-----------------------------------------------------------
-- Instances: Traversable, Applicative, Monad
-----------------------------------------------------------}

instance Traversable Trie where
    traverse :: (a -> f b) -> Trie a -> f (Trie b)
traverse a -> f b
f = Trie a -> f (Trie b)
go
        where
        go :: Trie a -> f (Trie b)
go Trie a
Empty              = Trie b -> f (Trie b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure   Trie b
forall a. Trie a
Empty
        go (Arc ByteString
k Maybe a
Nothing  Trie a
t) = (Trie b -> Trie b) -> f (Trie b) -> f (Trie b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap   (ByteString -> Maybe b -> Trie b -> Trie b
forall a. ByteString -> Maybe a -> Trie a -> Trie a
Arc ByteString
k Maybe b
forall a. Maybe a
Nothing)      (Trie a -> f (Trie b)
go Trie a
t)
        go (Arc ByteString
k (Just a
v) Trie a
t) = (b -> Trie b -> Trie b) -> f b -> f (Trie b) -> f (Trie b)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (ByteString -> Maybe b -> Trie b -> Trie b
forall a. ByteString -> Maybe a -> Trie a -> Trie a
Arc ByteString
k (Maybe b -> Trie b -> Trie b)
-> (b -> Maybe b) -> b -> Trie b -> Trie b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Maybe b
forall a. a -> Maybe a
Just) (a -> f b
f a
v) (Trie a -> f (Trie b)
go Trie a
t)
        go (Branch Prefix
p Prefix
m Trie a
l Trie a
r)   = (Trie b -> Trie b -> Trie b)
-> f (Trie b) -> f (Trie b) -> f (Trie b)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (Prefix -> Prefix -> Trie b -> Trie b -> Trie b
forall a. Prefix -> Prefix -> Trie a -> Trie a -> Trie a
Branch Prefix
p Prefix
m) (Trie a -> f (Trie b)
go Trie a
l) (Trie a -> f (Trie b)
go Trie a
r)

-- | Keyed version of 'traverse'.
--
-- __Warning__: This function suffers <Data-Trie-Internal.html#bug25 Bug #25>.
--
-- @since 0.2.7
traverseWithKey
    :: Applicative f => (ByteString -> a -> f b) -> Trie a -> f (Trie b)
{-# INLINE traverseWithKey #-}
traverseWithKey :: (ByteString -> a -> f b) -> Trie a -> f (Trie b)
traverseWithKey ByteString -> a -> f b
f = RevLazyByteString -> Trie a -> f (Trie b)
go RevLazyByteString
Nil
    where
    -- See [Note:LazyRLBS].
    go :: RevLazyByteString -> Trie a -> f (Trie b)
go RevLazyByteString
_ Trie a
Empty              = Trie b -> f (Trie b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure   Trie b
forall a. Trie a
Empty
    go RevLazyByteString
q (Branch Prefix
p Prefix
m Trie a
l Trie a
r)   = (Trie b -> Trie b -> Trie b)
-> f (Trie b) -> f (Trie b) -> f (Trie b)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (Prefix -> Prefix -> Trie b -> Trie b -> Trie b
forall a. Prefix -> Prefix -> Trie a -> Trie a -> Trie a
Branch Prefix
p Prefix
m) (RevLazyByteString -> Trie a -> f (Trie b)
go RevLazyByteString
q Trie a
l) (RevLazyByteString -> Trie a -> f (Trie b)
go RevLazyByteString
q Trie a
r)
    go RevLazyByteString
q (Arc ByteString
k Maybe a
Nothing  Trie a
t) = (Trie b -> Trie b) -> f (Trie b) -> f (Trie b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap   (ByteString -> Maybe b -> Trie b -> Trie b
forall a. ByteString -> Maybe a -> Trie a -> Trie a
Arc ByteString
k Maybe b
forall a. Maybe a
Nothing) (RevLazyByteString -> Trie a -> f (Trie b)
go (RevLazyByteString
q RevLazyByteString -> ByteString -> RevLazyByteString
+>! ByteString
k) Trie a
t)
    go RevLazyByteString
q (Arc ByteString
k (Just a
v) Trie a
t) =
        let q' :: ByteString
q' = RevLazyByteString -> ByteString
toStrict (RevLazyByteString
q RevLazyByteString -> ByteString -> RevLazyByteString
+>? ByteString
k)
        in (b -> Trie b -> Trie b) -> f b -> f (Trie b) -> f (Trie b)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (ByteString -> Maybe b -> Trie b -> Trie b
forall a. ByteString -> Maybe a -> Trie a -> Trie a
Arc ByteString
k (Maybe b -> Trie b -> Trie b)
-> (b -> Maybe b) -> b -> Trie b -> Trie b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Maybe b
forall a. a -> Maybe a
Just) (ByteString -> a -> f b
f ByteString
q' a
v) (RevLazyByteString -> Trie a -> f (Trie b)
go (ByteString -> RevLazyByteString
fromStrict ByteString
q') Trie a
t)

-- [Note:LazyRLBS]: We avoid making the RLBS parameter strict, to
-- avoid incuring the cost of 'toStrict' if the user's function
-- does not force it.  However, if they do force it, then we'll
-- still have the <https://github.com/wrengr/bytestring-trie/issues/25>
-- problem.  Using RLBS only reduces the constant factor of the
-- quadratic.

------------------------------------------------------------
-- TODO: would make more sense to use intersection\/zip semantics here,
-- rather than the overlaid-unionL semantics of the 'Monad'.  Alas,
-- done is done.  In a future major version we can try changing
-- that, and introducing newtype wrappers for this overlaid\/unionL
-- version (and the prospective underlaid\/unionR version).
-- TODO: see also <https://hackage.haskell.org/package/semialign>
--
-- | @since 0.2.2
instance Applicative Trie where
    pure :: a -> Trie a
pure      = ByteString -> a -> Trie a
forall a. ByteString -> a -> Trie a
singleton ByteString
S.empty
    Trie (a -> b)
t0 <*> :: Trie (a -> b) -> Trie a -> Trie b
<*> Trie a
t1 = Trie (a -> b)
t0 Trie (a -> b) -> ((a -> b) -> Trie b) -> Trie b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((a -> b) -> Trie a -> Trie b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Trie a
t1)
    -- TODO: can we do better than these defaults?
    -- t0 *> t1       = (id    <$  t0) <*> t1
    -- t0 <* t1       = (const <$> t0) <*> t1 -- actually uses @liftA2 const t0 t1@
#if MIN_VERSION_base(4,10,0)
    -- liftA2 f t0 t1 = (f     <$> t0) <*> t1
#endif
    {-
    -- Inlining and case-of-case yields the following (which GHC
    -- could surely derive on its own):
    Empty            *> _  = Empty
    Branch p m l r   *> t1 = branch p m (l *> t1) (r *> t1)
    Arc k Nothing  s *> t1 = prependNN k            (s *> t1)
    Arc k (Just _) s *> t1 = prepend k (t1 `unionL` (s *> t1))

    -- This one is marginally better, since we can use @(<$)@ in the Accept case.
    Empty            <* _  = Empty
    Branch p m l r   <* t1 = branch p m (l <* t1) (r <* t1)
    Arc k Nothing  s <* t1 = prependNN k                   (s <* t1)
    Arc k (Just v) s <* t1 = prepend k ((v <$ t1) `unionL` (s <* t1))

    -- This one took a lot of inlining\/massaging, so might be worth it...
    -- It's easier to see the structure if we define a closure
    -- @(liftA2 f _ t1)@, but unclear if that would hurt the improvement
    -- of the implementation.
    liftA2 f Empty              _  = Empty
    liftA2 f (Branch p m l r)   t1 = branch p m (liftA2 f l t1) (liftA2 f r t1)
    liftA2 f (Arc k Nothing  s) t1 = prependNN k (liftA2 f s t1)
    liftA2 f (Arc k (Just v) s) t1 = prepend k ((f v <$> t1) `unionL` liftA2 f s t1)
    -}

------------------------------------------------------------
-- 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
-- as a decision-tree; but since keys /can/ prefix, tries formed
-- from shorter keys can shadow the results from longer keys due
-- to the 'unionL'. It does seem to follow the laws though... What
-- computation could this possibly represent?
--
--  1. return x >>= f  ≡ f x
--  2. m >>= return    ≡ m
--  3. (m >>= f) >>= g ≡ m >>= (\x -> f x >>= g)
--
-- | @since 0.2.2
instance Monad Trie where
-- 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
    -- FIXME: See [bug26].
    >>= :: Trie a -> (a -> Trie b) -> Trie b
(>>=) Trie a
Empty              a -> Trie b
_ = Trie b
forall a. Trie a
empty
    (>>=) (Branch Prefix
p Prefix
m Trie a
l Trie a
r)   a -> Trie b
f = Prefix -> Prefix -> Trie b -> Trie b -> Trie b
forall a. Prefix -> Prefix -> Trie a -> Trie a -> Trie a
branch Prefix
p Prefix
m (Trie a
l Trie a -> (a -> Trie b) -> Trie b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Trie b
f) (Trie a
r Trie a -> (a -> Trie b) -> Trie b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Trie b
f)
    (>>=) (Arc ByteString
k Maybe a
Nothing  Trie a
t) a -> Trie b
f = ByteString -> Trie b -> Trie b
forall a. ByteString -> Trie a -> Trie a
prependNN ByteString
k             (Trie a
t Trie a -> (a -> Trie b) -> Trie b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Trie b
f)
    (>>=) (Arc ByteString
k (Just a
v) Trie a
t) a -> Trie b
f = ByteString -> Trie b -> Trie b
forall a. ByteString -> Trie a -> Trie a
prepend ByteString
k (a -> Trie b
f a
v Trie b -> Trie b -> Trie b
forall a. Trie a -> Trie a -> Trie a
`unionL` (Trie a
t Trie a -> (a -> Trie b) -> Trie b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Trie b
f))
                               where unionL :: Trie a -> Trie a -> Trie a
unionL = (a -> a -> Maybe a) -> Trie a -> Trie a -> Trie a
forall a. (a -> a -> Maybe a) -> Trie a -> Trie a -> Trie a
mergeBy (\a
x a
_ -> a -> Maybe a
forall a. a -> Maybe a
Just a
x)


{-----------------------------------------------------------
-- Instances: Semigroup, Monoid
-----------------------------------------------------------}

#if MIN_VERSION_base(4,9,0)
-- The "Data.Semigroup" module is in base since 4.9.0.0; but having
-- the 'Semigroup' superclass for the 'Monoid' instance only comes
-- into force in base 4.11.0.0.
-- | @since 0.2.5
instance (Semigroup a) => Semigroup (Trie a) where
    <> :: Trie a -> Trie a -> Trie a
(<>) = (a -> a -> Maybe a) -> Trie a -> Trie a -> Trie a
forall a. (a -> a -> Maybe a) -> Trie a -> Trie a -> Trie a
mergeBy ((a -> a -> Maybe a) -> Trie a -> Trie a -> Trie a)
-> (a -> a -> Maybe a) -> Trie a -> Trie a -> Trie a
forall a b. (a -> b) -> a -> b
$ \a
x a
y -> a -> Maybe a
forall a. a -> Maybe a
Just (a
x a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
y)
    -- Non-default definition since 0.2.7
    stimes :: b -> Trie a -> Trie a
stimes = (a -> a) -> Trie a -> Trie a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> a) -> Trie a -> Trie a)
-> (b -> a -> a) -> b -> Trie a -> Trie a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> a -> a
forall a b. (Semigroup a, Integral b) => b -> a -> a
stimes
#endif


-- This instance is more sensible than Data.IntMap and Data.Map's
instance (Monoid a) => Monoid (Trie a) where
    mempty :: Trie a
mempty = Trie a
forall a. Trie a
empty
#if MIN_VERSION_base(4,11,0)
    -- Now that the canonical instance is the default, don't define
    -- 'mappend', in anticipation of Phase 4 of:
    -- <https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/semigroup-monoid>
{-
--if MIN_VERSION_base(4,9,0)
    -- GHC 8.0/8.2 -Wnoncanonical-monoid-instances wants this
    -- definition, even though 'Semigroup' isn't a superclass of
    -- 'Monoid' until base-4.11 so it would require additional
    -- constraints on the instance.  Since we're only supporting
    -- these older versions for legacy reasons, there's no reason
    -- to bother adhering to the -Wcompat here.
    mappend = (<>)
-}
#else
    mappend = mergeBy $ \x y -> Just (x `mappend` y)
#endif


{-----------------------------------------------------------
-- Instances: Alternative, MonadPlus
-----------------------------------------------------------}

-- Since the Monoid instance isn't natural in @a@, I can't think
-- of any other sensible instance for MonadPlus. It's as specious
-- as Maybe, IO, and STM's instances though.
--
-- MonadPlus laws: <http://www.haskell.org/haskellwiki/MonadPlus>
--  1. <Trie a, mzero, mplus> forms a monoid
--  2. mzero >>= f        ≡ mzero
--  3. m >> mzero         ≡ mzero
--  4. mplus m n >>= k    ≡ mplus (m >>= k) (n >>= k)
--  4' mplus (return a) n ≡ return a
{-
-- Follows #1, #1, and #3. But it does something like 4' instead
-- of actually doing #4 (since we'd merge the trees generated by
-- @k@ for conflicting values)
--
-- TODO: cf Control.Applicative.Alternative (base-4, but not Hugs).
-- But (<*>) gets odd when the function is not 'pure'... maybe
-- helpful though.
instance MonadPlus Trie where
    mzero = empty
    mplus = unionL where unionL = mergeBy (\x _ -> Just x)
-}


{-----------------------------------------------------------
-- Extra mapping and filtering functions
-----------------------------------------------------------}

{-----------------------------------------------------------
-- Pseudo-instances: Filterable, Witherable
-----------------------------------------------------------}

-- We avoid depending on the _filterable_ package because it combines
-- too many things into its @Filterable@ class.  And we avoid using
-- the _witherable_ package because it has too many dependencies,
-- and too many orphan instances.  However, we go with the names
-- (mostly[1]) and laws as phrased by _witherable_.
--
-- [1]: I'm rather not a fan of @mapMaybe@, despite its pervasiveness.
-- And similarly for @catMaybes@ etc.  That's actually one of the
-- reasons I prefer the _witherable_ package over _filterable_:
-- because of the name 'wither' instead of @mapMaybeA@ :)


-- | Apply a function to all values, potentially removing them.
--
-- ==== __Laws__
-- [/Fission/]
--   @'filterMap' f ≡ 'fmap' ('Data.Maybe.fromJust' . f) . 'filter' ('Data.Maybe.isJust' . f)@
--
-- [/Fusion/]
--   @'fmap' f . 'filter' g ≡ 'filterMap' (\\v -> f v '<$' 'Control.Monad.guard' (g v))@
--
-- [/Conservation/]
--   @'filterMap' ('Just' . f) ≡ 'fmap' f@
--
-- [/Composition/]
--   @'filterMap' f . 'filterMap' g ≡ 'filterMap' (f 'Control.Monad.<=<' g)@
--
-- The fission\/fusion laws are essentially the same, they differ
-- only in which direction is more \"natural\" for use as a rewrite
-- rule.  The conservation law is just a special case of fusion,
-- but it's a particularly helpful one to take note of.
--
filterMap :: (a -> Maybe b) -> Trie a -> Trie b
filterMap :: (a -> Maybe b) -> Trie a -> Trie b
filterMap a -> Maybe b
f = Trie a -> Trie b
start
    where
    -- Handle epsilon values before entering the main recursion.
    start :: Trie a -> Trie b
start (Arc ByteString
k (Just a
v) Trie a
t) = ByteString -> Maybe b -> Trie b -> Trie b
forall a. ByteString -> Maybe a -> Trie a -> Trie a
arc ByteString
k (a -> Maybe b
f a
v) (Trie a -> Trie b
go Trie a
t)
    start Trie a
t                  = Trie a -> Trie b
go Trie a
t
    -- FIXME: See [bug26].
    go :: Trie a -> Trie b
go Trie a
Empty              = Trie b
forall a. Trie a
empty
    go (Arc ByteString
k Maybe a
Nothing  Trie a
t) = ByteString -> Trie b -> Trie b
forall a. ByteString -> Trie a -> Trie a
prependNN ByteString
k   (Trie a -> Trie b
go Trie a
t)
    go (Arc ByteString
k (Just a
v) Trie a
t) = ByteString -> Maybe b -> Trie b -> Trie b
forall a. ByteString -> Maybe a -> Trie a -> Trie a
arcNN ByteString
k (a -> Maybe b
f a
v) (Trie a -> Trie b
go Trie a
t)
    go (Branch Prefix
p Prefix
m Trie a
l Trie a
r)   = Prefix -> Prefix -> Trie b -> Trie b -> Trie b
forall a. Prefix -> Prefix -> Trie a -> Trie a -> Trie a
branch Prefix
p Prefix
m (Trie a -> Trie b
go Trie a
l) (Trie a -> Trie b
go Trie a
r)
-- TODO: rewrite rule for the latter three laws. (The fission law
-- is unlikely to be very helpful.)
-- TODO: why not implement as @contextualFilterMap (const . f)@ ?
-- Does that actually incur additional overhead?


-- Some translations:
--   @'filter' f ≡ 'filterMap' (\\v -> if f v then 'Just' v else 'Nothing')@
--   @'filter' f ≡ 'filterMap' (('<$') '<*>' 'Control.Monad.guard' . f)@
--   @'filter' f ≡ 'filterMap' (\\v -> v '<$' 'Control.Monad.guard' (f v))@
--
-- | Retain only those values which satisfy some predicate.
--
-- ==== __Laws__
-- [/Definition/]
--   @'filter' f ≡ 'filterMap' (\\v -> v '<$' 'Control.Monad.guard' (f v))@
--
-- [/Composition/]
--   @'filter' f . 'filter' g ≡ 'filter' ('liftA2' ('&&') f g)@
--
-- The definition above is a special case of the fusion law for
-- 'filterMap'.  (Also, the name just means definitional-equality;
-- it's not the actual implementation used.)
--
-- @since 0.2.7
filter :: (a -> Bool) -> Trie a -> Trie a
filter :: (a -> Bool) -> Trie a -> Trie a
filter a -> Bool
f = Trie a -> Trie a
start
    where
    -- Handle epsilon values before entering the main recursion.
    start :: Trie a -> Trie a
start (Arc ByteString
k (Just a
v) Trie a
t) = ByteString -> a -> Bool -> Trie a -> Trie a
forall a. ByteString -> a -> Bool -> Trie a -> Trie a
arcB ByteString
k a
v (a -> Bool
f a
v) (Trie a -> Trie a
go Trie a
t)
    start Trie a
t                  = Trie a -> Trie a
go Trie a
t
    -- FIXME: See [bug26].
    go :: Trie a -> Trie a
go Trie a
Empty              = Trie a
forall a. Trie a
empty
    go (Arc ByteString
k Maybe a
Nothing  Trie a
t) = ByteString -> Trie a -> Trie a
forall a. ByteString -> Trie a -> Trie a
prependNN ByteString
k      (Trie a -> Trie a
go Trie a
t)
    go (Arc ByteString
k (Just a
v) Trie a
t) = ByteString -> a -> Bool -> Trie a -> Trie a
forall a. ByteString -> a -> Bool -> Trie a -> Trie a
arcNNB ByteString
k a
v (a -> Bool
f a
v) (Trie a -> Trie a
go Trie a
t)
    go (Branch Prefix
p Prefix
m Trie a
l Trie a
r)   = Prefix -> Prefix -> Trie a -> Trie a -> Trie a
forall a. Prefix -> Prefix -> Trie a -> Trie a -> Trie a
branch Prefix
p Prefix
m (Trie a -> Trie a
go Trie a
l) (Trie a -> Trie a
go Trie a
r)

-- | > arcB k v b ≡ arc k (v <$ guard b)
arcB :: ByteString -> a -> Bool -> Trie a -> Trie a
{-# INLINE arcB #-}
arcB :: ByteString -> a -> Bool -> Trie a -> Trie a
arcB ByteString
k a
v Bool
True  = ByteString -> Maybe a -> Trie a -> Trie a
forall a. ByteString -> Maybe a -> Trie a -> Trie a
Arc ByteString
k (a -> Maybe a
forall a. a -> Maybe a
Just a
v)
arcB ByteString
k a
_ Bool
False = ByteString -> Trie a -> Trie a
forall a. ByteString -> Trie a -> Trie a
prepend ByteString
k

-- | > arcNNB k v b ≡ arcNN k (v <$ guard b)
arcNNB :: ByteString -> a -> Bool -> Trie a -> Trie a
{-# INLINE arcNNB #-}
arcNNB :: ByteString -> a -> Bool -> Trie a -> Trie a
arcNNB ByteString
k a
v Bool
True  = ByteString -> Maybe a -> Trie a -> Trie a
forall a. ByteString -> Maybe a -> Trie a -> Trie a
Arc ByteString
k (a -> Maybe a
forall a. a -> Maybe a
Just a
v)
arcNNB ByteString
k a
_ Bool
False = ByteString -> Trie a -> Trie a
forall a. ByteString -> Trie a -> Trie a
prependNN ByteString
k


{-
#if MIN_VERSION_base(4,9,0)
import Data.Functor.Compose (Compose(Compose))
#endif
#if MIN_VERSION_base(4,8,0)
import Data.Functor.Identity (Identity(Identity))
#endif
-}

-- BUG: Is there any other way to get the Haddock to force linebreaks,
-- other than using birdtracks which have a whole different
-- stylization?
-- TODO: is commutative monad sufficient, or are there other
-- requirements too?  If it does in fact hold for commutative monads,
-- then we should state it as a law (like we do for naturality).
--
-- | An effectful version of 'filterMap'.
--
-- ==== __Laws__
-- [/Naturality/]
--   @'wither' (t . f) ≡ t . 'wither' f@,
--   for any /applicative-transformation/ @t@
--
-- [/Purity/]
--   @'wither' ('pure' . f) ≡ 'pure' . 'filterMap' f@
--
-- [/Conservation/]
--   @'wither' ('fmap' 'Just' . f) ≡ 'traverse' f@
--
-- [/Horizontal Composition/]
--   @'wither' f \`under\` 'wither' g ≡ 'wither' (wither_Maybe f \`under\` g)@,
--   where:
--
-- > under :: Functor f
-- >       => (b -> g c)
-- >       -> (a -> f b)
-- >       -> a -> Compose f g c
-- > under g f = Compose . fmap g . f
-- >
-- > -- | Variant of wither for Maybe instead of Trie.
-- > wither_Maybe :: Applicative f
-- >              => (a -> f (Maybe b))
-- >              -> Maybe a -> f (Maybe b)
-- > wither_Maybe f = fmap join . traverse f
--
-- Note that the horizontal composition law is using two different
-- applicative functors.  Conversely, a vertical composition law
-- would have the form: @'wither' f 'Control.Monad.<=<' 'wither' g ≡ ...@;
-- however, we cannot have such a law except when the applicative
-- functor is in fact a commutative monad (i.e., the order of effects
-- doesn't matter).  For the curious, the terminology of
-- <https://ncatlab.org/nlab/show/horizontal+composition \"horizontal\" composition> vs
-- <https://ncatlab.org/nlab/show/vertical+composition \"vertical\" composition>
-- comes from category theory.
--
-- Although the horizontal composition law may look baroque, it is
-- helpful to compare it to the composition law for 'traverse'
-- itself:
--
-- @'traverse' f \`under\` 'traverse' g ≡ 'traverse' (f \`under\` g)@
--
-- @since 0.2.7
wither :: Applicative f => (a -> f (Maybe b)) -> Trie a -> f (Trie b)
wither :: (a -> f (Maybe b)) -> Trie a -> f (Trie b)
wither a -> f (Maybe b)
f = Trie a -> f (Trie b)
start
    where
    -- Handle epsilon values before entering the main recursion.
    start :: Trie a -> f (Trie b)
start (Arc ByteString
k (Just a
v) Trie a
t) = (Maybe b -> Trie b -> Trie b)
-> f (Maybe b) -> f (Trie b) -> f (Trie b)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (ByteString -> Maybe b -> Trie b -> Trie b
forall a. ByteString -> Maybe a -> Trie a -> Trie a
arc ByteString
k) (a -> f (Maybe b)
f a
v) (Trie a -> f (Trie b)
go Trie a
t)
    start Trie a
t                  = Trie a -> f (Trie b)
go Trie a
t
    -- FIXME: See [bug26].
    go :: Trie a -> f (Trie b)
go Trie a
Empty              = Trie b -> f (Trie b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure   Trie b
forall a. Trie a
empty
    go (Arc ByteString
k Maybe a
Nothing  Trie a
t) = (Trie b -> Trie b) -> f (Trie b) -> f (Trie b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap   (ByteString -> Trie b -> Trie b
forall a. ByteString -> Trie a -> Trie a
prependNN ByteString
k)   (Trie a -> f (Trie b)
go Trie a
t)
    go (Arc ByteString
k (Just a
v) Trie a
t) = (Maybe b -> Trie b -> Trie b)
-> f (Maybe b) -> f (Trie b) -> f (Trie b)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (ByteString -> Maybe b -> Trie b -> Trie b
forall a. ByteString -> Maybe a -> Trie a -> Trie a
arcNN ByteString
k) (a -> f (Maybe b)
f a
v) (Trie a -> f (Trie b)
go Trie a
t)
    go (Branch Prefix
p Prefix
m Trie a
l Trie a
r)   = (Trie b -> Trie b -> Trie b)
-> f (Trie b) -> f (Trie b) -> f (Trie b)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (Prefix -> Prefix -> Trie b -> Trie b -> Trie b
forall a. Prefix -> Prefix -> Trie a -> Trie a -> Trie a
branch Prefix
p Prefix
m) (Trie a -> f (Trie b)
go Trie a
l) (Trie a -> f (Trie b)
go Trie a
r)

-- Some other spellings of the translation:
--   @'filterA' f ≡ 'wither' (\\v -> (\\b -> if b then 'Just' v else 'Nothing') '<$>' f v)@
--   @'filterA' f ≡ 'wither' (\\v -> (\\b -> v '<$' 'Control.Monad.guard' b) '<$>' f v)@
--   @'filterA' f ≡ 'wither' ('fmap' . (. 'Control.Monad.guard') . ('<$') '<*>' f)@
--
-- An alternative variant of 'underA2' which has a nicer type.
-- Alas, that just makes the twist show up in the law itself; also
-- the name is peculiar since it's the second argument that's run
-- under the first.  Decisions decisions.
-- > underF2 :: (Functor f, Functor g)
-- >         => (b -> c -> d)
-- >         -> (a -> f b)
-- >         -> (a -> g c)
-- >         -> a -> Compose f g d
-- > underF2 h f g a = Compose (f a <&> ((g a <&>) . h))
--
--
-- | An effectful version of 'filter'.
--
-- ==== __Laws__
-- [/Definition/]
--   @'filterA' f ≡ 'wither' (\\v -> (v '<$') . 'Control.Monad.guard' '<$>' f v)@
--
-- [/Naturality/]
--   @'filterA' (t . f) ≡ t . 'filterA' f@,
--   for any /applicative-transformation/ @t@
--
-- [/Purity/]
--   @'filterA' ('pure' . f) ≡ 'pure' . 'filter' f@
--
-- [/Horizontal Composition/]
--   @'filterA' f \`under\` 'filterA' g ≡ 'filterA' (underA2 ('&&') f g)@,
--   where
--
-- > -- Like 'liftA2' for the @(a->)@ monad, but horizontal.
-- > -- The function definition should (hopefully) be straightforward
-- > -- to follow; however, do beware the oddly criss-crossed types
-- > -- for @g@ and @f@.
-- > underA2 :: (Applicative f, Applicative g)
-- >         => (b -> c -> d)
-- >         -> (a -> g b)
-- >         -> (a -> f c)
-- >         -> a -> Compose f g d
-- > underA2 h g f = liftA2 (liftA2 h) (g `under` pure) (pure `under` f)
--
-- For the definition of @under@ and more details about horizontal
-- composition, see the laws section of 'wither'.
--
-- @since 0.2.7
filterA :: Applicative f => (a -> f Bool) -> Trie a -> f (Trie a)
filterA :: (a -> f Bool) -> Trie a -> f (Trie a)
filterA a -> f Bool
f = Trie a -> f (Trie a)
start
    where
    -- Handle epsilon values before entering the main recursion.
    start :: Trie a -> f (Trie a)
start (Arc ByteString
k (Just a
v) Trie a
t) = (Bool -> Trie a -> Trie a) -> f Bool -> f (Trie a) -> f (Trie a)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (ByteString -> a -> Bool -> Trie a -> Trie a
forall a. ByteString -> a -> Bool -> Trie a -> Trie a
arcB ByteString
k a
v) (a -> f Bool
f a
v) (Trie a -> f (Trie a)
go Trie a
t)
    start Trie a
t                  = Trie a -> f (Trie a)
go Trie a
t
    -- FIXME: See [bug26].
    go :: Trie a -> f (Trie a)
go Trie a
Empty              = Trie a -> f (Trie a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure   Trie a
forall a. Trie a
empty
    go (Arc ByteString
k Maybe a
Nothing  Trie a
t) = (Trie a -> Trie a) -> f (Trie a) -> f (Trie a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap   (ByteString -> Trie a -> Trie a
forall a. ByteString -> Trie a -> Trie a
prependNN ByteString
k)      (Trie a -> f (Trie a)
go Trie a
t)
    go (Arc ByteString
k (Just a
v) Trie a
t) = (Bool -> Trie a -> Trie a) -> f Bool -> f (Trie a) -> f (Trie a)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (ByteString -> a -> Bool -> Trie a -> Trie a
forall a. ByteString -> a -> Bool -> Trie a -> Trie a
arcNNB ByteString
k a
v) (a -> f Bool
f a
v) (Trie a -> f (Trie a)
go Trie a
t)
    go (Branch Prefix
p Prefix
m Trie a
l Trie a
r)   = (Trie a -> Trie a -> Trie a)
-> f (Trie a) -> f (Trie a) -> f (Trie a)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (Prefix -> Prefix -> Trie a -> Trie a -> Trie a
forall a. Prefix -> Prefix -> Trie a -> Trie a -> Trie a
branch Prefix
p Prefix
m) (Trie a -> f (Trie a)
go Trie a
l) (Trie a -> f (Trie a)
go Trie a
r)


-- | Keyed version of 'filterMap'.
--
-- __Warning__: This function suffers <Data-Trie-Internal.html#bug25 Bug #25>.
mapBy :: (ByteString -> a -> Maybe b) -> Trie a -> Trie b
-- TODO: why not implement as @contextualMapBy (\k v _ -> f k v)@ ?
-- Does that actually incur additional overhead?
mapBy :: (ByteString -> a -> Maybe b) -> Trie a -> Trie b
mapBy ByteString -> a -> Maybe b
f = Trie a -> Trie b
start
    where
    -- Handle epsilon values before entering the main recursion.
    start :: Trie a -> Trie b
start (Arc ByteString
k (Just a
v) Trie a
t) = ByteString -> Maybe b -> Trie b -> Trie b
forall a. ByteString -> Maybe a -> Trie a -> Trie a
arc ByteString
k (ByteString -> a -> Maybe b
f ByteString
k a
v) (RevLazyByteString -> Trie a -> Trie b
go (ByteString -> RevLazyByteString
fromStrict ByteString
k) Trie a
t)
    start Trie a
t                  = RevLazyByteString -> Trie a -> Trie b
go RevLazyByteString
Nil Trie a
t
    -- FIXME: See [bug26].
    -- See [Note:LazyRLBS].
    go :: RevLazyByteString -> Trie a -> Trie b
go RevLazyByteString
_ Trie a
Empty              = Trie b
forall a. Trie a
empty
    go RevLazyByteString
q (Branch Prefix
p Prefix
m Trie a
l Trie a
r)   = Prefix -> Prefix -> Trie b -> Trie b -> Trie b
forall a. Prefix -> Prefix -> Trie a -> Trie a -> Trie a
branch Prefix
p Prefix
m (RevLazyByteString -> Trie a -> Trie b
go RevLazyByteString
q Trie a
l) (RevLazyByteString -> Trie a -> Trie b
go RevLazyByteString
q Trie a
r)
    go RevLazyByteString
q (Arc ByteString
k Maybe a
Nothing  Trie a
t) = ByteString -> Trie b -> Trie b
forall a. ByteString -> Trie a -> Trie a
prependNN ByteString
k (RevLazyByteString -> Trie a -> Trie b
go (RevLazyByteString
q RevLazyByteString -> ByteString -> RevLazyByteString
+>! ByteString
k) Trie a
t)
    go RevLazyByteString
q (Arc ByteString
k (Just a
v) Trie a
t) = ByteString -> Maybe b -> Trie b -> Trie b
forall a. ByteString -> Maybe a -> Trie a -> Trie a
arcNN ByteString
k (ByteString -> a -> Maybe b
f ByteString
q' a
v) (RevLazyByteString -> Trie a -> Trie b
go (ByteString -> RevLazyByteString
fromStrict ByteString
q') Trie a
t)
                            where q' :: ByteString
q' = RevLazyByteString -> ByteString
toStrict (RevLazyByteString
q RevLazyByteString -> ByteString -> RevLazyByteString
+>? ByteString
k)


-- | A variant of 'fmap' which provides access to the subtrie rooted
-- at each value.
--
-- @since 0.2.3
contextualMap :: (a -> Trie a -> b) -> Trie a -> Trie b
contextualMap :: (a -> Trie a -> b) -> Trie a -> Trie b
contextualMap a -> Trie a -> b
f = Trie a -> Trie b
go
    where
    go :: Trie a -> Trie b
go Trie a
Empty              = Trie b
forall a. Trie a
Empty
    go (Arc ByteString
k Maybe a
Nothing  Trie a
t) = ByteString -> Maybe b -> Trie b -> Trie b
forall a. ByteString -> Maybe a -> Trie a -> Trie a
Arc ByteString
k Maybe b
forall a. Maybe a
Nothing        (Trie a -> Trie b
go Trie a
t)
    go (Arc ByteString
k (Just a
v) Trie a
t) = ByteString -> Maybe b -> Trie b -> Trie b
forall a. ByteString -> Maybe a -> Trie a -> Trie a
Arc ByteString
k (b -> Maybe b
forall a. a -> Maybe a
Just (a -> Trie a -> b
f a
v Trie a
t)) (Trie a -> Trie b
go Trie a
t)
    go (Branch Prefix
p Prefix
m Trie a
l Trie a
r)   = Prefix -> Prefix -> Trie b -> Trie b -> Trie b
forall a. Prefix -> Prefix -> Trie a -> Trie a -> Trie a
Branch Prefix
p Prefix
m (Trie a -> Trie b
go Trie a
l) (Trie a -> Trie b
go Trie a
r)


-- | A variant of 'contextualMap' which evaluates the function strictly.
--
-- @since 0.2.3
contextualMap' :: (a -> Trie a -> b) -> Trie a -> Trie b
contextualMap' :: (a -> Trie a -> b) -> Trie a -> Trie b
contextualMap' a -> Trie a -> b
f = Trie a -> Trie b
go
    where
    go :: Trie a -> Trie b
go Trie a
Empty              = Trie b
forall a. Trie a
Empty
    go (Arc ByteString
k Maybe a
Nothing  Trie a
t) = ByteString -> Maybe b -> Trie b -> Trie b
forall a. ByteString -> Maybe a -> Trie a -> Trie a
Arc ByteString
k Maybe b
forall a. Maybe a
Nothing         (Trie a -> Trie b
go Trie a
t)
    go (Arc ByteString
k (Just a
v) Trie a
t) = ByteString -> Maybe b -> Trie b -> Trie b
forall a. ByteString -> Maybe a -> Trie a -> Trie a
Arc ByteString
k (b -> Maybe b
forall a. a -> Maybe a
Just (b -> Maybe b) -> b -> Maybe b
forall a b. (a -> b) -> a -> b
$! a -> Trie a -> b
f a
v Trie a
t) (Trie a -> Trie b
go Trie a
t)
    go (Branch Prefix
p Prefix
m Trie a
l Trie a
r)   = Prefix -> Prefix -> Trie b -> Trie b -> Trie b
forall a. Prefix -> Prefix -> Trie a -> Trie a -> Trie a
Branch Prefix
p Prefix
m (Trie a -> Trie b
go Trie a
l) (Trie a -> Trie b
go Trie a
r)


-- | Contextual variant of 'filterMap'.
--
-- @since 0.2.3
contextualFilterMap :: (a -> Trie a -> Maybe b) -> Trie a -> Trie b
contextualFilterMap :: (a -> Trie a -> Maybe b) -> Trie a -> Trie b
contextualFilterMap a -> Trie a -> Maybe b
f = Trie a -> Trie b
start
    where
    -- Handle epsilon values before entering the main recursion.
    start :: Trie a -> Trie b
start (Arc ByteString
k (Just a
v) Trie a
t) = ByteString -> Maybe b -> Trie b -> Trie b
forall a. ByteString -> Maybe a -> Trie a -> Trie a
arc ByteString
k (a -> Trie a -> Maybe b
f a
v Trie a
t) (Trie a -> Trie b
go Trie a
t)
    start Trie a
t                  = Trie a -> Trie b
go Trie a
t
    -- FIXME: See [bug26].
    go :: Trie a -> Trie b
go Trie a
Empty              = Trie b
forall a. Trie a
empty
    go (Arc ByteString
k Maybe a
Nothing  Trie a
t) = ByteString -> Trie b -> Trie b
forall a. ByteString -> Trie a -> Trie a
prependNN ByteString
k     (Trie a -> Trie b
go Trie a
t)
    go (Arc ByteString
k (Just a
v) Trie a
t) = ByteString -> Maybe b -> Trie b -> Trie b
forall a. ByteString -> Maybe a -> Trie a -> Trie a
arcNN ByteString
k (a -> Trie a -> Maybe b
f a
v Trie a
t) (Trie a -> Trie b
go Trie a
t)
    go (Branch Prefix
p Prefix
m Trie a
l Trie a
r)   = Prefix -> Prefix -> Trie b -> Trie b -> Trie b
forall a. Prefix -> Prefix -> Trie a -> Trie a -> Trie a
branch Prefix
p Prefix
m (Trie a -> Trie b
go Trie a
l) (Trie a -> Trie b
go Trie a
r)


-- | Contextual variant of 'mapBy', aka keyed variant of 'contextualFilterMap'.
--
-- __Warning__: This function suffers <Data-Trie-Internal.html#bug25 Bug #25>.
--
-- @since 0.2.3
contextualMapBy :: (ByteString -> a -> Trie a -> Maybe b) -> Trie a -> Trie b
contextualMapBy :: (ByteString -> a -> Trie a -> Maybe b) -> Trie a -> Trie b
contextualMapBy ByteString -> a -> Trie a -> Maybe b
f = Trie a -> Trie b
start
    where
    -- Handle epsilon values before entering the main recursion.
    start :: Trie a -> Trie b
start (Arc ByteString
k (Just a
v) Trie a
t) = ByteString -> Maybe b -> Trie b -> Trie b
forall a. ByteString -> Maybe a -> Trie a -> Trie a
arc ByteString
k (ByteString -> a -> Trie a -> Maybe b
f ByteString
k a
v Trie a
t) (RevLazyByteString -> Trie a -> Trie b
go (ByteString -> RevLazyByteString
fromStrict ByteString
k) Trie a
t)
    start Trie a
t                  = RevLazyByteString -> Trie a -> Trie b
go RevLazyByteString
Nil Trie a
t
    -- FIXME: See [bug26].
    -- See [Note:LazyRLBS].
    go :: RevLazyByteString -> Trie a -> Trie b
go RevLazyByteString
_ Trie a
Empty              = Trie b
forall a. Trie a
empty
    go RevLazyByteString
q (Branch Prefix
p Prefix
m Trie a
l Trie a
r)   = Prefix -> Prefix -> Trie b -> Trie b -> Trie b
forall a. Prefix -> Prefix -> Trie a -> Trie a -> Trie a
branch Prefix
p Prefix
m (RevLazyByteString -> Trie a -> Trie b
go RevLazyByteString
q Trie a
l) (RevLazyByteString -> Trie a -> Trie b
go RevLazyByteString
q Trie a
r)
    go RevLazyByteString
q (Arc ByteString
k Maybe a
Nothing  Trie a
t) = ByteString -> Trie b -> Trie b
forall a. ByteString -> Trie a -> Trie a
prependNN ByteString
k (RevLazyByteString -> Trie a -> Trie b
go (RevLazyByteString
q RevLazyByteString -> ByteString -> RevLazyByteString
+>! ByteString
k) Trie a
t)
    go RevLazyByteString
q (Arc ByteString
k (Just a
v) Trie a
t) = ByteString -> Maybe b -> Trie b -> Trie b
forall a. ByteString -> Maybe a -> Trie a -> Trie a
arcNN ByteString
k (ByteString -> a -> Trie a -> Maybe b
f ByteString
q' a
v Trie a
t) (RevLazyByteString -> Trie a -> Trie b
go (ByteString -> RevLazyByteString
fromStrict ByteString
q') Trie a
t)
                            where q' :: ByteString
q' = RevLazyByteString -> ByteString
toStrict (RevLazyByteString
q RevLazyByteString -> ByteString -> RevLazyByteString
+>? ByteString
k)


{-----------------------------------------------------------
-- Basic functions
-----------------------------------------------------------}
-- TODO: probably want to hoist this up top

-- | \(\mathcal{O}(1)\). Construct the empty trie.
empty :: Trie a
{-# INLINE empty #-}
empty :: Trie a
empty = Trie a
forall a. Trie a
Empty


-- | \(\mathcal{O}(1)\). Is the trie empty?
null :: Trie a -> Bool
{-# INLINE null #-}
null :: Trie a -> Bool
null Trie a
Empty = Bool
True
null Trie a
_     = Bool
False


-- | \(\mathcal{O}(1)\). Construct a singleton trie.
singleton :: ByteString -> a -> Trie a
{-# INLINE singleton #-}
singleton :: ByteString -> a -> Trie a
singleton ByteString
k a
v = ByteString -> Maybe a -> Trie a -> Trie a
forall a. ByteString -> Maybe a -> Trie a -> Trie a
Arc ByteString
k (a -> Maybe a
forall a. a -> Maybe a
Just a
v) Trie a
forall a. Trie a
Empty
-- For singletons, don't need to verify invariant on arc length >0


-- | \(\mathcal{O}(n)\). Get count of elements in trie.
size  :: Trie a -> Int
{-# INLINE size #-}
size :: Trie a -> Int
size = Int -> Trie a -> Int
forall a. Int -> Trie a -> Int
size' Int
0

-- This is just @F.foldl' (\n _ -> n+1) 0@ manually inlined\/specialized.
-- Thus, see our implementation of 'foldl'' to see why we use this
-- particular phrasing out of the very many alternatives.
size' :: Int -> Trie a -> Int
size' :: Int -> Trie a -> Int
size' !Int
n Trie a
Empty              = Int
n
size'  Int
n (Arc ByteString
_ Maybe a
Nothing  Trie a
t) = Int -> Trie a -> Int
forall a. Int -> Trie a -> Int
size' Int
n Trie a
t
size'  Int
n (Arc ByteString
_ (Just a
_) Trie a
t) = Int -> Trie a -> Int
forall a. Int -> Trie a -> Int
size' (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Trie a
t
size'  Int
n (Branch Prefix
_ Prefix
_ Trie a
l Trie a
r)   = Int -> Trie a -> Int
forall a. Int -> Trie a -> Int
size' (Int -> Trie a -> Int
forall a. Int -> Trie a -> Int
size' Int
n Trie a
l) Trie a
r


{-----------------------------------------------------------
-- Instances: Foldable
-----------------------------------------------------------}

-- [Note:FoldEta]: For all the folding functions, we take only the
-- two algebra arguments on the left of the \"=\", leaving the
-- 'Trie' argument as a lambda on the right of the \"=\".  This is
-- to allow the functions to be inlined when passed only the two
-- algebra arguments, rather than requiring all three arguments
-- before being inlined.

instance Foldable Trie where
    {-# INLINABLE fold #-}
    fold :: Trie m -> m
fold = Trie m -> m
forall m. Monoid m => Trie m -> m
go
        where
        go :: Trie a -> a
go Trie a
Empty              = a
forall a. Monoid a => a
mempty
        go (Arc ByteString
_ Maybe a
Nothing  Trie a
t) = Trie a -> a
go Trie a
t
        go (Arc ByteString
_ (Just a
v) Trie a
t) = a
v a -> a -> a
forall a. Monoid a => a -> a -> a
`mappend` Trie a -> a
go Trie a
t
        go (Branch Prefix
_ Prefix
_ Trie a
l Trie a
r)   = Trie a -> a
go Trie a
l a -> a -> a
forall a. Monoid a => a -> a -> a
`mappend` Trie a -> a
go Trie a
r
    {-# INLINE foldMap #-}
    foldMap :: (a -> m) -> Trie a -> m
foldMap a -> m
f = Trie a -> m
go
        where
        go :: Trie a -> m
go Trie a
Empty              = m
forall a. Monoid a => a
mempty
        go (Arc ByteString
_ Maybe a
Nothing  Trie a
t) = Trie a -> m
go Trie a
t
        go (Arc ByteString
_ (Just a
v) Trie a
t) = a -> m
f a
v m -> m -> m
forall a. Monoid a => a -> a -> a
`mappend` Trie a -> m
go Trie a
t
        go (Branch Prefix
_ Prefix
_ Trie a
l Trie a
r)   = Trie a -> m
go Trie a
l m -> m -> m
forall a. Monoid a => a -> a -> a
`mappend` Trie a -> m
go Trie a
r
#if MIN_VERSION_base(4,13,0)
    -- TODO: float out this definition so folks can still use it
    -- on earlier versions of base?
    -- TODO: verify order of 'mappend' on some non-commutative monoid!
    {-# INLINE foldMap' #-}
    foldMap' :: (a -> m) -> Trie a -> m
foldMap' a -> m
f = m -> Trie a -> m
go m
forall a. Monoid a => a
mempty
        where
        -- Benchmarking on GHC 9.2.1 indicates that for this function
        -- the (m,t) argument ordering is somewhat (~3%) faster
        -- than the (t,m) order; and both allocate the same.
        -- This differs from the case for 'foldr'' and 'foldl';
        -- though I'm not sure why.
        -- TODO: Once we disable HPC, now it's looking like the
        -- flopped version is faster afterall...
        go :: m -> Trie a -> m
go !m
m Trie a
Empty              = m
m
        go  m
m (Arc ByteString
_ Maybe a
Nothing  Trie a
t) = m -> Trie a -> m
go m
m Trie a
t
        go  m
m (Arc ByteString
_ (Just a
v) Trie a
t) = m -> Trie a -> m
go (m
m m -> m -> m
forall a. Monoid a => a -> a -> a
`mappend` a -> m
f a
v) Trie a
t
        go  m
m (Branch Prefix
_ Prefix
_ Trie a
l Trie a
r)   = m -> Trie a -> m
go (m -> Trie a -> m
go m
m Trie a
l) Trie a
r
#endif
    -- FIXME: (2022.03.06): N.B., the benchmarks are quite erratic
    -- regarding whether this implementation is better than the
    -- 'foldMap'-with-'Endo' definition or not; whichever one is
    -- favored at some particular time is always massively favored
    -- over the other.  Most recently this implementation is being
    -- favored.
    {-# INLINE foldr #-}
    foldr :: (a -> b -> b) -> b -> Trie a -> b
foldr a -> b -> b
f b
z0 = \Trie a
t -> Trie a -> b -> b
go Trie a
t b
z0 -- See [Note:FoldEta].
        where
        go :: Trie a -> b -> b
go Trie a
Empty              = b -> b
forall a. a -> a
id
        go (Arc ByteString
_ Maybe a
Nothing  Trie a
t) =       Trie a -> b -> b
go Trie a
t
        go (Arc ByteString
_ (Just a
v) Trie a
t) = a -> b -> b
f a
v (b -> b) -> (b -> b) -> b -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Trie a -> b -> b
go Trie a
t
        go (Branch Prefix
_ Prefix
_ Trie a
l Trie a
r)   = Trie a -> b -> b
go Trie a
l (b -> b) -> (b -> b) -> b -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Trie a -> b -> b
go Trie a
r
#if MIN_VERSION_base(4,6,0)
    -- TODO: float out this definition so folks can still use it
    -- on earlier versions of base?
    {-# INLINE foldr' #-}
    foldr' :: (a -> b -> b) -> b -> Trie a -> b
foldr' a -> b -> b
f b
z0 = b -> Trie a -> b
go b
z0 -- See [Note:FoldEta].
        where
        -- Benchmarking on GHC 9.2.1 indicates that for this function:
        -- for smaller tries, the (t,z) argument order is ~10% faster
        -- than (z,t) and allocation is the same for both; however,
        -- for larger tries the (t,z) argument order is ~6% slower
        -- than (z,t).
        --
        -- Also, weirdly, benchmarking indicates that the @($!)@
        -- in the Branch case slightly improved things.
        -- TODO: what's going on with the @($!)@; bogus?
        -- TODO: once HPC disabled, now it's saying the unflopped
        -- version without the extra @($!)@ is the faster one!
        -- (unflopped with @($!)@ is only marginally slower; probably
        -- noise).
        go :: b -> Trie a -> b
go !b
z Trie a
Empty              = b
z
        go  b
z (Arc ByteString
_ Maybe a
Nothing  Trie a
t) = b -> Trie a -> b
go b
z Trie a
t
        go  b
z (Arc ByteString
_ (Just a
v) Trie a
t) = a -> b -> b
f a
v (b -> b) -> b -> b
forall a b. (a -> b) -> a -> b
$! b -> Trie a -> b
go b
z Trie a
t
        go  b
z (Branch Prefix
_ Prefix
_ Trie a
l Trie a
r)   = b -> Trie a -> b
go (b -> Trie a -> b
go b
z Trie a
r) Trie a
l
#endif
    {-# INLINE foldl #-}
    foldl :: (b -> a -> b) -> b -> Trie a -> b
foldl b -> a -> b
f b
z0 = \Trie a
t -> Trie a -> b -> b
go Trie a
t b
z0 -- See [Note:FoldEta].
        where
        -- Benchmarking on GHC 9.2.1 indicates that for this function
        -- the (t,z) argument order is slightly faster (~0.8%) and
        -- allocates ~8.4% less, compared to the (z,t) order.
        -- I've no idea why the allocation would differ, especially
        -- when it doesn't for 'foldr'' and 'foldMap''.
        -- TODO: once HPC disabled, now it's showing the flopped
        -- version is ~2x faster! bogus?
        -- TODO: (2022.03.05) Rerun this benchmark on larger tries.
        go :: Trie a -> b -> b
go Trie a
Empty              b
z = b
z
        go (Arc ByteString
_ Maybe a
Nothing  Trie a
t) b
z = Trie a -> b -> b
go Trie a
t b
z
        go (Arc ByteString
_ (Just a
v) Trie a
t) b
z = Trie a -> b -> b
go Trie a
t (b -> a -> b
f b
z a
v)
        go (Branch Prefix
_ Prefix
_ Trie a
l Trie a
r)   b
z = Trie a -> b -> b
go Trie a
r (Trie a -> b -> b
go Trie a
l b
z)
#if MIN_VERSION_base(4,6,0)
    -- TODO: float out this definition so folks can still use it
    -- on earlier versions of base?
    {-# INLINE foldl' #-}
    foldl' :: (b -> a -> b) -> b -> Trie a -> b
foldl' b -> a -> b
f b
z0 = b -> Trie a -> b
go b
z0 -- See [Note:FoldEta].
        where
        -- Benchmarking on GHC 9.2.1 indicates that for this function
        -- the (z,t) argument order is significantly faster (~10%) and
        -- allocates half as much.
        -- TODO: figure out why\/how the allocation could differ so much; bogus?
        -- TODO: figure out why benchmarking indicates the \"flop_bang\"
        -- version is ~4% faster (albeit ~32% more allocation); bogus?
        -- TODO: once HPC disabled, the flopped version is showing ~2x faster; bogus?
        -- TODO: (2022.03.05) Rerun this benchmark on larger tries.
        go :: b -> Trie a -> b
go !b
z Trie a
Empty              = b
z
        go  b
z (Arc ByteString
_ Maybe a
Nothing  Trie a
t) = b -> Trie a -> b
go b
z Trie a
t
        go  b
z (Arc ByteString
_ (Just a
v) Trie a
t) = b -> Trie a -> b
go (b -> a -> b
f b
z a
v) Trie a
t
        go  b
z (Branch Prefix
_ Prefix
_ Trie a
l Trie a
r)   = b -> Trie a -> b
go (b -> Trie a -> b
go b
z Trie a
l) Trie a
r
#endif
    -- TODO: any point in doing foldr1,foldl1?
#if MIN_VERSION_base(4,8,0)
    -- TODO: float out this definition so folks can still use it
    -- on earlier versions of base?
    {-# INLINE length #-}
    length :: Trie a -> Int
length = Trie a -> Int
forall a. Trie a -> Int
size
    {-# INLINE null #-}
    null :: Trie a -> Bool
null   = Trie a -> Bool
forall a. Trie a -> Bool
null -- FIXME: ensure this isn't cyclic definition!
    {-# INLINE toList #-}
    toList :: Trie a -> [a]
toList = Trie a -> [a]
forall a. Trie a -> [a]
elems -- NB: Foldable.toList /= Trie.toList
    {-
    -- TODO: need to move these definitions here...
    -- TODO: may want to give a specialized implementation of 'member' then
    {-# INLINE elem #-}
    elem = member
    -}
    -- TODO: why does IntMap define these two specially, rather than using foldl' or foldl1' ?
    {-# INLINABLE maximum #-}
    maximum :: Trie a -> a
maximum = Trie a -> a
forall a. Ord a => Trie a -> a
go0
        where
        go0 :: Trie a -> a
go0   Trie a
Empty              = String -> a
forall a. HasCallStack => String -> a
error String
"Data.Foldable.maximum @Trie: empty trie"
        go0   (Arc ByteString
_ Maybe a
Nothing  Trie a
t) = Trie a -> a
go0 Trie a
t
        go0   (Arc ByteString
_ (Just a
v) Trie a
t) = a -> Trie a -> a
forall a. Ord a => a -> Trie a -> a
go a
v Trie a
t
        go0   (Branch Prefix
_ Prefix
_ Trie a
l Trie a
r)   = a -> Trie a -> a
forall a. Ord a => a -> Trie a -> a
go (Trie a -> a
go0 Trie a
l) Trie a
r
        go :: a -> Trie a -> a
go !a
w Trie a
Empty              = a
w
        go  a
w (Arc ByteString
_ Maybe a
Nothing  Trie a
t) = a -> Trie a -> a
go a
w Trie a
t
        go  a
w (Arc ByteString
_ (Just a
v) Trie a
t) = a -> Trie a -> a
go (a -> a -> a
forall a. Ord a => a -> a -> a
max a
w a
v) Trie a
t
        go  a
w (Branch Prefix
_ Prefix
_ Trie a
l Trie a
r)   = a -> Trie a -> a
go (a -> Trie a -> a
go a
w Trie a
l) Trie a
r
    {-# INLINABLE minimum #-}
    minimum :: Trie a -> a
minimum = Trie a -> a
forall a. Ord a => Trie a -> a
go0
        where
        go0 :: Trie a -> a
go0   Trie a
Empty              = String -> a
forall a. HasCallStack => String -> a
error String
"Data.Foldable.minimum @Trie: empty trie"
        go0   (Arc ByteString
_ Maybe a
Nothing  Trie a
t) = Trie a -> a
go0 Trie a
t
        go0   (Arc ByteString
_ (Just a
v) Trie a
t) = a -> Trie a -> a
forall a. Ord a => a -> Trie a -> a
go a
v Trie a
t
        go0   (Branch Prefix
_ Prefix
_ Trie a
l Trie a
r)   = a -> Trie a -> a
forall a. Ord a => a -> Trie a -> a
go (Trie a -> a
go0 Trie a
l) Trie a
r
        go :: a -> Trie a -> a
go !a
w Trie a
Empty              = a
w
        go  a
w (Arc ByteString
_ Maybe a
Nothing  Trie a
t) = a -> Trie a -> a
go a
w Trie a
t
        go  a
w (Arc ByteString
_ (Just a
v) Trie a
t) = a -> Trie a -> a
go (a -> a -> a
forall a. Ord a => a -> a -> a
min a
w a
v) Trie a
t
        go  a
w (Branch Prefix
_ Prefix
_ Trie a
l Trie a
r)   = a -> Trie a -> a
go (a -> Trie a -> a
go a
w Trie a
l) Trie a
r
    {-# INLINABLE sum #-}
    sum :: Trie a -> a
sum = (a -> a -> a) -> a -> Trie a -> a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl' a -> a -> a
forall a. Num a => a -> a -> a
(+) a
0
    {-# INLINABLE product #-}
    product :: Trie a -> a
product = (a -> a -> a) -> a -> Trie a -> a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl' a -> a -> a
forall a. Num a => a -> a -> a
(*) a
1
#endif

-- TODO: newtype Keys = K Trie  ; instance Foldable Keys
-- TODO: newtype Assoc = A Trie ; instance Foldable Assoc

{-----------------------------------------------------------
-- Extra folding functions
-----------------------------------------------------------}

-- TODO: be sure to keep this in sync with whatever implementation
-- choice we use for 'F.foldr'; especially since that's the one
-- method of 'Foldable' where we can't improve substantially over
-- the default implementation.
--
-- | Keyed variant of 'F.foldr'.
--
-- __Warning__: This function suffers <Data-Trie-Internal.html#bug25 Bug #25>.
--
-- @since 0.2.2
foldrWithKey :: (ByteString -> a -> b -> b) -> b -> Trie a -> b
{-# INLINE foldrWithKey #-}
foldrWithKey :: (ByteString -> a -> b -> b) -> b -> Trie a -> b
foldrWithKey ByteString -> a -> b -> b
f b
z0 = \Trie a
t -> RevLazyByteString -> Trie a -> b -> b
go RevLazyByteString
Nil Trie a
t b
z0 -- See [Note:FoldEta].
    where
    -- See [Note:LazyRLBS].
    go :: RevLazyByteString -> Trie a -> b -> b
go RevLazyByteString
_ Trie a
Empty              = b -> b
forall a. a -> a
id
    go RevLazyByteString
q (Branch Prefix
_ Prefix
_ Trie a
l Trie a
r)   = RevLazyByteString -> Trie a -> b -> b
go RevLazyByteString
q Trie a
l (b -> b) -> (b -> b) -> b -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RevLazyByteString -> Trie a -> b -> b
go RevLazyByteString
q Trie a
r
    go RevLazyByteString
q (Arc ByteString
k Maybe a
Nothing  Trie a
t) =          RevLazyByteString -> Trie a -> b -> b
go (RevLazyByteString
q RevLazyByteString -> ByteString -> RevLazyByteString
+>! ByteString
k) Trie a
t
    go RevLazyByteString
q (Arc ByteString
k (Just a
v) Trie a
t) = ByteString -> a -> b -> b
f ByteString
q' a
v (b -> b) -> (b -> b) -> b -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RevLazyByteString -> Trie a -> b -> b
go (ByteString -> RevLazyByteString
fromStrict ByteString
q') Trie a
t
                            where q' :: ByteString
q' = RevLazyByteString -> ByteString
toStrict (RevLazyByteString
q RevLazyByteString -> ByteString -> RevLazyByteString
+>? ByteString
k)

-- TODO: probably need to benchmark these separately from the
-- non-keyed variants, since the extra recursive argument will
-- surely sway things like whether to flop or not.
-- TODO: Consider just giving an
-- <https://hackage.haskell.org/package/indexed-traversable-0.1.2/docs/Data-Foldable-WithIndex.html>
-- instance, instead of naming all these separately.  That adds a
-- lot of additional dependencies just to define the class, but...
-- Or maybe give an <https://hackage.haskell.org/package/keys-3.12.3/docs/Data-Key.html>
-- instance. Again, lots of added dependencies just for the class,...
-- Then again, maybe we should just stick with doing everything
-- outside of classes; that way we could introduce a Cabal flag for
-- deciding whether the user wants either of those classes (and
-- should do the same for Witherable).

-- | Keyed variant of 'F.foldr''.
--
-- __Warning__: This function suffers <Data-Trie-Internal.html#bug25 Bug #25>.
--
-- @since 0.2.7
foldrWithKey' :: (ByteString -> a -> b -> b) -> b -> Trie a -> b
{-# INLINE foldrWithKey' #-}
foldrWithKey' :: (ByteString -> a -> b -> b) -> b -> Trie a -> b
foldrWithKey' ByteString -> a -> b -> b
f b
z0 = RevLazyByteString -> b -> Trie a -> b
go RevLazyByteString
Nil b
z0 -- See [Note:FoldEta].
    where
    -- See [Note:LazyRLBS].
    go :: RevLazyByteString -> b -> Trie a -> b
go RevLazyByteString
_ !b
z Trie a
Empty              = b
z
    go RevLazyByteString
q  b
z (Branch Prefix
_ Prefix
_ Trie a
l Trie a
r)   = RevLazyByteString -> b -> Trie a -> b
go RevLazyByteString
q (RevLazyByteString -> b -> Trie a -> b
go RevLazyByteString
q b
z Trie a
r) Trie a
l
    go RevLazyByteString
q  b
z (Arc ByteString
k Maybe a
Nothing  Trie a
t) =           RevLazyByteString -> b -> Trie a -> b
go (RevLazyByteString
q RevLazyByteString -> ByteString -> RevLazyByteString
+>! ByteString
k) b
z Trie a
t
    go RevLazyByteString
q  b
z (Arc ByteString
k (Just a
v) Trie a
t) = ByteString -> a -> b -> b
f ByteString
q' a
v (b -> b) -> b -> b
forall a b. (a -> b) -> a -> b
$! RevLazyByteString -> b -> Trie a -> b
go (ByteString -> RevLazyByteString
fromStrict ByteString
q') b
z Trie a
t
                                where q' :: ByteString
q' = RevLazyByteString -> ByteString
toStrict (RevLazyByteString
q RevLazyByteString -> ByteString -> RevLazyByteString
+>? ByteString
k)

-- | Keyed variant of 'F.foldl'.
--
-- __Warning__: This function suffers <Data-Trie-Internal.html#bug25 Bug #25>.
--
-- @since 0.2.7
foldlWithKey :: (b -> ByteString -> a -> b) -> b -> Trie a -> b
{-# INLINE foldlWithKey #-}
foldlWithKey :: (b -> ByteString -> a -> b) -> b -> Trie a -> b
foldlWithKey b -> ByteString -> a -> b
f b
z0 = RevLazyByteString -> b -> Trie a -> b
go RevLazyByteString
Nil b
z0 -- See [Note:FoldEta].
    where
    -- See [Note:LazyRLBS].
    go :: RevLazyByteString -> b -> Trie a -> b
go RevLazyByteString
_ b
z Trie a
Empty              = b
z
    go RevLazyByteString
q b
z (Branch Prefix
_ Prefix
_ Trie a
l Trie a
r)   = RevLazyByteString -> b -> Trie a -> b
go RevLazyByteString
q (RevLazyByteString -> b -> Trie a -> b
go RevLazyByteString
q b
z Trie a
l) Trie a
r
    go RevLazyByteString
q b
z (Arc ByteString
k Maybe a
Nothing  Trie a
t) = RevLazyByteString -> b -> Trie a -> b
go (RevLazyByteString
q RevLazyByteString -> ByteString -> RevLazyByteString
+>! ByteString
k) b
z Trie a
t
    go RevLazyByteString
q b
z (Arc ByteString
k (Just a
v) Trie a
t) = RevLazyByteString -> b -> Trie a -> b
go (ByteString -> RevLazyByteString
fromStrict ByteString
q') (b -> ByteString -> a -> b
f b
z ByteString
q' a
v) Trie a
t
                                where q' :: ByteString
q' = RevLazyByteString -> ByteString
toStrict (RevLazyByteString
q RevLazyByteString -> ByteString -> RevLazyByteString
+>? ByteString
k)

-- | Keyed variant of 'F.foldl''.
--
-- __Warning__: This function suffers <Data-Trie-Internal.html#bug25 Bug #25>.
--
-- @since 0.2.7
foldlWithKey' :: (b -> ByteString -> a -> b) -> b -> Trie a -> b
{-# INLINE foldlWithKey' #-}
foldlWithKey' :: (b -> ByteString -> a -> b) -> b -> Trie a -> b
foldlWithKey' b -> ByteString -> a -> b
f b
z0 = RevLazyByteString -> b -> Trie a -> b
go RevLazyByteString
Nil b
z0 -- See [Note:FoldEta].
    where
    -- See [Note:LazyRLBS].
    go :: RevLazyByteString -> b -> Trie a -> b
go RevLazyByteString
_ !b
z Trie a
Empty              = b
z
    go RevLazyByteString
q  b
z (Branch Prefix
_ Prefix
_ Trie a
l Trie a
r)   = RevLazyByteString -> b -> Trie a -> b
go RevLazyByteString
q (RevLazyByteString -> b -> Trie a -> b
go RevLazyByteString
q b
z Trie a
l) Trie a
r
    go RevLazyByteString
q  b
z (Arc ByteString
k Maybe a
Nothing  Trie a
t) = RevLazyByteString -> b -> Trie a -> b
go (RevLazyByteString
q RevLazyByteString -> ByteString -> RevLazyByteString
+>! ByteString
k) b
z Trie a
t
    go RevLazyByteString
q  b
z (Arc ByteString
k (Just a
v) Trie a
t) = RevLazyByteString -> b -> Trie a -> b
go (ByteString -> RevLazyByteString
fromStrict ByteString
q') (b -> ByteString -> a -> b
f b
z ByteString
q' a
v) Trie a
t
                                where q' :: ByteString
q' = RevLazyByteString -> ByteString
toStrict (RevLazyByteString
q RevLazyByteString -> ByteString -> RevLazyByteString
+>? ByteString
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)    -- ^ Algebra for arc.
    -> (b -> b -> b)                        -- ^ Algebra for binary branch.
    -> b                                    -- ^ Algebra for empty trie.
    -> Trie a -> b
{-# INLINE cata_ #-}
cata_ :: (ByteString -> Maybe a -> b -> b)
-> (b -> b -> b) -> b -> Trie a -> b
cata_ ByteString -> Maybe a -> b -> b
a b -> b -> b
b b
e = Trie a -> b
go
    where
    go :: Trie a -> b
go Trie a
Empty            = b
e
    go (Arc ByteString
k Maybe a
mv Trie a
t)     = ByteString -> Maybe a -> b -> b
a ByteString
k Maybe a
mv (Trie a -> b
go Trie a
t)
    go (Branch Prefix
_ Prefix
_ Trie a
l Trie a
r) = b -> b -> b
b (Trie a -> b
go Trie a
l) (Trie a -> b
go Trie a
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)  -- ^ Algebra for accepting arcs.
    -> (ByteString -> [b] -> b)     -- ^ Algebra for n-ary branch with prefix.
    -> b                            -- ^ Algebra for empty trie.
    -> Trie a -> b
cata :: (ByteString -> a -> b -> b)
-> (ByteString -> [b] -> b) -> b -> Trie a -> b
cata ByteString -> a -> b -> b
a ByteString -> [b] -> b
b b
e = Trie a -> b
go
    where
    step :: ByteString -> Maybe a -> Trie a -> b
step ByteString
k (Just a
v) Trie a
t           = ByteString -> a -> b -> b
a ByteString
k a
v (Trie a -> b
go Trie a
t)
    step ByteString
k Maybe a
Nothing  Trie a
t           = ByteString -> [b] -> b
b ByteString
k (Trie a -> [b] -> [b]
collect Trie a
t [])
    go :: Trie a -> b
go      Trie a
Empty               = b
e
    go      (Arc ByteString
k Maybe a
mv Trie a
t)        = ByteString -> Maybe a -> Trie a -> b
step ByteString
k Maybe a
mv Trie a
t
    go      (Branch Prefix
_ Prefix
_ Trie a
l Trie a
r)    = ByteString -> [b] -> b
b ByteString
S.empty (Trie a -> [b] -> [b]
collect Trie a
l (Trie a -> [b] -> [b]
collect Trie a
r []))
    -- TODO: would it be profitable to use 'build' for these lists?
    collect :: Trie a -> [b] -> [b]
collect Trie a
Empty            [b]
bs = [b]
bs
    collect (Arc ByteString
k Maybe a
mv Trie a
t)     [b]
bs = ByteString -> Maybe a -> Trie a -> b
step ByteString
k Maybe a
mv Trie a
t b -> [b] -> [b]
forall a. a -> [a] -> [a]
: [b]
bs
    collect (Branch Prefix
_ Prefix
_ Trie a
l Trie a
r) [b]
bs = Trie a -> [b] -> [b]
collect Trie a
l (Trie a -> [b] -> [b]
collect Trie a
r [b]
bs)



{-----------------------------------------------------------
-- Instances: IsList
-----------------------------------------------------------}

#if __GLASGOW_HASKELL__ >= 708
-- |
-- __Warning__: The 'toList' method of this instance suffers
-- <Data-Trie-Internal.html#bug25 Bug #25>.
--
-- @since 0.2.7
instance GHC.Exts.IsList (Trie a) where
    type Item (Trie a) = (ByteString, a)
    fromList :: [Item (Trie a)] -> Trie a
fromList = [Item (Trie a)] -> Trie a
forall a. [(ByteString, a)] -> Trie a
fromList
    toList :: Trie a -> [Item (Trie a)]
toList   = Trie a -> [Item (Trie a)]
forall a. Trie a -> [(ByteString, a)]
toList
#endif


-- /Moved to "Data.Trie.Internal" since 0.2.7/
-- We define this here because 'GHC.Exts.IsList' wants it.
--
-- | Convert association list into a trie.  On key conflict, values
-- earlier in the list shadow later ones.
fromList :: [(ByteString,a)] -> Trie a
{-# INLINE fromList #-}
fromList :: [(ByteString, a)] -> Trie a
fromList = ((ByteString, a) -> Trie a -> Trie a)
-> Trie a -> [(ByteString, a)] -> Trie a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((ByteString -> a -> Trie a -> Trie a)
-> (ByteString, a) -> Trie a -> Trie a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ByteString -> a -> Trie a -> Trie a
forall a. ByteString -> a -> Trie a -> Trie a
insert) Trie a
forall a. Trie a
empty
    where
    insert :: ByteString -> a -> Trie a -> Trie a
insert = (ByteString -> a -> Maybe a -> Maybe a)
-> ByteString -> a -> Trie a -> Trie a
forall a.
(ByteString -> a -> Maybe a -> Maybe a)
-> ByteString -> a -> Trie a -> Trie a
alterBy (\ByteString
_ a
x Maybe a
_ -> a -> Maybe a
forall a. a -> Maybe a
Just a
x)


-- /Moved to "Data.Trie.Internal" since 0.2.7/
-- We define this here simply because so many instances want to use it.
-- TODO: would it be worth defining this directly, for optimizing
-- the case where list fusion doesn't eliminate the list?
--
-- | Convert trie into association list.  The list is ordered
-- according to the keys.
--
-- __Warning__: This function suffers <Data-Trie-Internal.html#bug25 Bug #25>.
toList :: Trie a -> [(ByteString,a)]
{-# INLINE toList #-}
toList :: Trie a -> [(ByteString, a)]
toList = (ByteString -> a -> (ByteString, a)) -> Trie a -> [(ByteString, a)]
forall a b. (ByteString -> a -> b) -> Trie a -> [b]
toListBy (,)


-- cf Data.ByteString.unpack
-- <http://hackage.haskell.org/packages/archive/bytestring/0.9.1.4/doc/html/src/Data-ByteString.html>
--
-- | Convert a trie into a list using a function. Resulting values
-- are in key-sorted order.
--
-- __Warning__: This function suffers <Data-Trie-Internal.html#bug25 Bug #25>.
toListBy :: (ByteString -> a -> b) -> Trie a -> [b]
{-# INLINE toListBy #-}
#if !defined(__GLASGOW_HASKELL__)
-- TODO: should probably inline foldrWithKey
-- TODO: compare performance of that vs both this and the GHC version
toListBy f t = foldrWithKey (((:) .) . f) [] t
#else
-- Written with 'build' to enable the build\/foldr fusion rules.
toListBy :: (ByteString -> a -> b) -> Trie a -> [b]
toListBy ByteString -> a -> b
f Trie a
t = (forall b. (b -> b -> b) -> b -> b) -> [b]
forall a. (forall b. (a -> b -> b) -> b -> b) -> [a]
build ((ByteString -> a -> b) -> Trie a -> (b -> b -> b) -> b -> b
forall a b c.
(ByteString -> a -> b) -> Trie a -> (b -> c -> c) -> c -> c
toListByFB ByteString -> a -> b
f Trie a
t)

-- TODO: should probably have a specialized version for strictness,
-- and a rule to rewrite generic lazy version into it. As per
-- Data.ByteString.unpack and the comments there about strictness
-- and fusion.
toListByFB :: (ByteString -> a -> b) -> Trie a -> (b -> c -> c) -> c -> c
{-# INLINE [0] toListByFB #-}
toListByFB :: (ByteString -> a -> b) -> Trie a -> (b -> c -> c) -> c -> c
toListByFB ByteString -> a -> b
f Trie a
t b -> c -> c
cons c
nil = (ByteString -> a -> c -> c) -> c -> Trie a -> c
forall a b. (ByteString -> a -> b -> b) -> b -> Trie a -> b
foldrWithKey ((b -> c -> c
cons (b -> c -> c) -> (a -> b) -> a -> c -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((a -> b) -> a -> c -> c)
-> (ByteString -> a -> b) -> ByteString -> a -> c -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> a -> b
f) c
nil Trie a
t
#endif

-- /Moved to "Data.Trie.Internal" since 0.2.7/
-- So that we can do list-fusion, and reuse the definition for Foldable
--
-- | Return all values in the trie, in key-sorted order.
--
-- __Note__: Prior to version 0.2.7, this function suffered
-- <Data-Trie-Internal.html#bug25 Bug #25>; but it no longer does.
--
-- @since 0.2.2
elems :: Trie a -> [a]
{-# INLINE elems #-}
#ifdef __GLASGOW_HASKELL__
elems :: Trie a -> [a]
elems Trie a
t = (forall b. (a -> b -> b) -> b -> b) -> [a]
forall a. (forall b. (a -> b -> b) -> b -> b) -> [a]
build (\a -> b -> b
cons b
nil -> (a -> b -> b) -> b -> Trie a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
F.foldr a -> b -> b
cons b
nil Trie a
t)
#else
elems = F.foldr (:) []
#endif


------------------------------------------------------------
------------------------------------------------------------


{-----------------------------------------------------------
-- Query functions (just recurse)
-----------------------------------------------------------}

-- | Generic function to find a value (if it exists) and the subtrie
-- rooted at the prefix. The first function argument is called if and
-- only if a node is exactly reachable by the query; if no node is
-- exactly reachable the default value is used; if the middle of
-- an arc is reached, the second function argument is used.
--
-- This function is intended for internal use. For the public-facing
-- version, see 'Data.Trie.lookupBy'.
--
-- __Note__: /Type changed in 0.2.7/
lookupBy_
    :: (a -> Trie a -> b)   -- ^ The query matches a value.
    -> (Trie a -> b)        -- ^ The query doesn't match, but an extension might.
    -> b                    -- ^ The query doesn't match, nor does any extension.
    -> ByteString -> Trie a -> b
lookupBy_ :: (a -> Trie a -> b)
-> (Trie a -> b) -> b -> ByteString -> Trie a -> b
lookupBy_ a -> Trie a -> b
found Trie a -> b
missing b
clash = ByteString -> Trie a -> b
start
    where
    -- | Deal with epsilon query (when there is no epsilon value)
    start :: ByteString -> Trie a -> b
start ByteString
q t :: Trie a
t@(Branch{}) | ByteString -> Bool
S.null ByteString
q = Trie a -> b
missing Trie a
t
    start ByteString
q Trie a
t                       = ByteString -> Trie a -> b
go ByteString
q Trie a
t
    -- | The main recursion
    go :: ByteString -> Trie a -> b
go ByteString
_    Trie a
Empty       = b
clash
    go ByteString
q   (Arc ByteString
k Maybe a
mv Trie a
t) =
        let (ByteString
_,ByteString
k',ByteString
q')   = ByteString -> ByteString -> (ByteString, ByteString, ByteString)
breakMaximalPrefix ByteString
k ByteString
q
        in case (ByteString -> Bool
S.null ByteString
k', ByteString -> Bool
S.null ByteString
q') of
                (Bool
False, Bool
True)  -> Trie a -> b
missing (ByteString -> Maybe a -> Trie a -> Trie a
forall a. ByteString -> Maybe a -> Trie a -> Trie a
Arc ByteString
k' Maybe a
mv Trie a
t)
                (Bool
False, Bool
False) -> b
clash
                (Bool
True,  Bool
True)  ->
                    case Maybe a
mv of
                    Maybe a
Nothing -> Trie a -> b
missing Trie a
t
                    Just a
v  -> a -> Trie a -> b
found a
v Trie a
t
                (Bool
True,  Bool
False) -> ByteString -> Trie a -> b
go ByteString
q' Trie a
t
    go ByteString
q t_ :: Trie a
t_@(Branch{}) = Trie a -> b
findArc Trie a
t_
        where
        qh :: Prefix
qh = String -> ByteString -> Prefix
errorLogHead String
"lookupBy_" ByteString
q
        -- | \(\mathcal{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 :: Trie a -> b
findArc Trie a
Empty         = String -> b
forall a. String -> a
impossible String
"lookupBy_" -- see [Note1]
        findArc t :: Trie a
t@(Arc{})     = ByteString -> Trie a -> b
go ByteString
q Trie a
t
        findArc (Branch Prefix
p Prefix
m Trie a
l Trie a
r)
            | Prefix -> Prefix -> Prefix -> Bool
nomatch Prefix
qh Prefix
p Prefix
m  = b
clash
            | Prefix -> Prefix -> Bool
zero Prefix
qh Prefix
m       = Trie a -> b
findArc Trie a
l
            | Bool
otherwise       = Trie a -> b
findArc Trie a
r

-- [Note1]: Our use of the 'branch' and 'graft' 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.
--     arc k Nothing  t ≡ singleton k () >> t
--     arc k (Just v) t ≡ singleton k v  >>= unionR t . singleton S.empty
--         (...except 'arc' doesn't do the invariant correction
--           of (>>=) for epsilon'elem't)
--
-- | Return the subtrie containing all keys beginning with a prefix.
submap :: ByteString -> Trie a -> Trie a
{-# INLINE submap #-}
submap :: ByteString -> Trie a -> Trie a
submap ByteString
q
    | ByteString -> Bool
S.null ByteString
q  = Trie a -> Trie a
forall a. a -> a
id
    | Bool
otherwise = (a -> Trie a -> Trie a)
-> (Trie a -> Trie a) -> Trie a -> ByteString -> Trie a -> Trie a
forall a b.
(a -> Trie a -> b)
-> (Trie a -> b) -> b -> ByteString -> Trie a -> b
lookupBy_ (ByteString -> Maybe a -> Trie a -> Trie a
forall a. ByteString -> Maybe a -> Trie a -> Trie a
Arc ByteString
q (Maybe a -> Trie a -> Trie a)
-> (a -> Maybe a) -> a -> Trie a -> Trie a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe a
forall a. a -> Maybe a
Just) (ByteString -> Trie a -> Trie a
forall a. ByteString -> Trie a -> Trie a
prependNN ByteString
q) Trie a
forall a. Trie a
empty ByteString
q

{-
-- TODO: would it be worth it to define this specialization?  The
-- definition is nothing special; but inlining away the first three
-- arguments to 'lookupBy_' does allow to avoid any sort of dynamic
-- dispatch or closures.
lookup :: ByteString -> Trie a -> Maybe a
lookup = start
    where
    -- | Deal with epsilon query (when there is no epsilon value)
    start q t@(Branch{}) | S.null q = Nothing
    start q t                       = go q t
    -- | The main recursion
    go _    Empty       = Nothing
    go q   (Arc k mv t) =
        let (_,k',q')   = breakMaximalPrefix k q
        in case (S.null k', S.null q') of
                (False, _)     -> Nothing
                (True,  True)  -> mv
                (True,  False) -> go q' t
    go q t_@(Branch{}) = findArc t_
        where
        qh = errorLogHead "lookup" q
        -- | \(\mathcal{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 Empty         = impossible "lookup" -- see [Note1]
        findArc t@(Arc{})     = go q t
        findArc (Branch p m l r)
            | nomatch qh p m  = Nothing
            | zero qh m       = findArc l
            | otherwise       = findArc r
-}


-- TODO: would it be worth it to have a variant like 'lookupBy_'
-- which takes the three continuations?


-- According to our "Bench.MatchOne" benchmark, this is in fact
-- much faster than using 'matches_' and relying on list fusion.
--
-- | Given a query, find the longest prefix with an associated value
-- in the trie, returning the length of that prefix and the associated
-- value.
--
-- 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 'Data.Trie.match'.
--
-- @since 0.2.4
match_ :: Trie a -> ByteString -> Maybe (Int, a)
match_ :: Trie a -> ByteString -> Maybe (Int, a)
match_ = (ByteString -> Trie a -> Maybe (Int, a))
-> Trie a -> ByteString -> Maybe (Int, a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ByteString -> Trie a -> Maybe (Int, a)
forall b. ByteString -> Trie b -> Maybe (Int, b)
start
    where
    -- | Deal with epsilon query (when there is no epsilon value)
    start :: ByteString -> Trie b -> Maybe (Int, b)
start ByteString
q (Branch{}) | ByteString -> Bool
S.null ByteString
q = Maybe (Int, b)
forall a. Maybe a
Nothing
    start ByteString
q Trie b
t                     = Int -> ByteString -> Trie b -> Maybe (Int, b)
forall b. Int -> ByteString -> Trie b -> Maybe (Int, b)
match1 Int
0 ByteString
q Trie b
t
        -- TODO: for the non-null Branch case, maybe we should jump directly to 'findArc' (i.e., inline that case of 'match1')
    -- | Find the first match, or return Nothing if there isn't one.
    match1 :: Int -> ByteString -> Trie b -> Maybe (Int, b)
match1 Int
_ ByteString
_ Trie b
Empty        = Maybe (Int, b)
forall a. Maybe a
Nothing
    match1 Int
n ByteString
q (Arc ByteString
k Maybe b
mv Trie b
t) =
        let (ByteString
p,ByteString
k',ByteString
q') = ByteString -> ByteString -> (ByteString, ByteString, ByteString)
breakMaximalPrefix ByteString
k ByteString
q
            !n' :: Int
n'       = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
S.length ByteString
p
        in case (ByteString -> Bool
S.null ByteString
k', ByteString -> Bool
S.null ByteString
q') of
            (Bool
False, Bool
_)    -> Maybe (Int, b)
forall a. Maybe a
Nothing
            (Bool
True, Bool
True)  -> (,) Int
n' (b -> (Int, b)) -> Maybe b -> Maybe (Int, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe b
mv
            (Bool
True, Bool
False) ->
                case Maybe b
mv of
                Maybe b
Nothing -> Int -> ByteString -> Trie b -> Maybe (Int, b)
match1      Int
n' ByteString
q' Trie b
t
                Just b
v  -> Int -> b -> Int -> ByteString -> Trie b -> Maybe (Int, b)
forall b. Int -> b -> Int -> ByteString -> Trie b -> Maybe (Int, b)
matchN Int
n' b
v Int
n' ByteString
q' Trie b
t
    match1 Int
n ByteString
q t_ :: Trie b
t_@(Branch{}) = Trie b -> Maybe (Int, b)
findArc Trie b
t_
        where
        qh :: Prefix
qh = String -> ByteString -> Prefix
errorLogHead String
"match_" ByteString
q
        -- | \(\mathcal{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 :: Trie b -> Maybe (Int, b)
findArc Trie b
Empty         = String -> Maybe (Int, b)
forall a. String -> a
impossible String
"match_" -- see [Note1]
        findArc t :: Trie b
t@(Arc{})     = Int -> ByteString -> Trie b -> Maybe (Int, b)
match1 Int
n ByteString
q Trie b
t
        findArc (Branch Prefix
p Prefix
m Trie b
l Trie b
r)
            | Prefix -> Prefix -> Prefix -> Bool
nomatch Prefix
qh Prefix
p Prefix
m  = Maybe (Int, b)
forall a. Maybe a
Nothing
            | Prefix -> Prefix -> Bool
zero Prefix
qh Prefix
m       = Trie b -> Maybe (Int, b)
findArc Trie b
l
            | Bool
otherwise       = Trie b -> Maybe (Int, b)
findArc Trie b
r
    -- | Find the next match, or return the previous one if there are no more.
    matchN :: Int -> b -> Int -> ByteString -> Trie b -> Maybe (Int, b)
matchN Int
n0 b
v0 Int
_ ByteString
_ Trie b
Empty        = (Int, b) -> Maybe (Int, b)
forall a. a -> Maybe a
Just (Int
n0,b
v0)
    matchN Int
n0 b
v0 Int
n ByteString
q (Arc ByteString
k Maybe b
mv Trie b
t) =
        let (ByteString
p,ByteString
k',ByteString
q') = ByteString -> ByteString -> (ByteString, ByteString, ByteString)
breakMaximalPrefix ByteString
k ByteString
q
            !n' :: Int
n'       = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
S.length ByteString
p
        in case (ByteString -> Bool
S.null ByteString
k', ByteString -> Bool
S.null ByteString
q') of
            (Bool
False, Bool
_)   -> (Int, b) -> Maybe (Int, b)
forall a. a -> Maybe a
Just (Int
n0,b
v0)
            (Bool
True, Bool
True) ->
                case Maybe b
mv of
                Maybe b
Nothing -> (Int, b) -> Maybe (Int, b)
forall a. a -> Maybe a
Just (Int
n0,b
v0)
                Just b
v  -> (Int, b) -> Maybe (Int, b)
forall a. a -> Maybe a
Just (Int
n',b
v)
            (Bool
True, Bool
False) ->
                case Maybe b
mv of
                Maybe b
Nothing -> Int -> b -> Int -> ByteString -> Trie b -> Maybe (Int, b)
matchN Int
n0 b
v0 Int
n' ByteString
q' Trie b
t
                Just b
v  -> Int -> b -> Int -> ByteString -> Trie b -> Maybe (Int, b)
matchN Int
n' b
v  Int
n' ByteString
q' Trie b
t
    matchN Int
n0 b
v0 Int
n ByteString
q t_ :: Trie b
t_@(Branch{}) = Trie b -> Maybe (Int, b)
findArc Trie b
t_
        where
        qh :: Prefix
qh = String -> ByteString -> Prefix
errorLogHead String
"match_" ByteString
q
        -- | \(\mathcal{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 :: Trie b -> Maybe (Int, b)
findArc Trie b
Empty         = String -> Maybe (Int, b)
forall a. String -> a
impossible String
"match_" -- see [Note1]
        findArc t :: Trie b
t@(Arc{})     = Int -> b -> Int -> ByteString -> Trie b -> Maybe (Int, b)
matchN Int
n0 b
v0 Int
n ByteString
q Trie b
t
        findArc (Branch Prefix
p Prefix
m Trie b
l Trie b
r)
            | Prefix -> Prefix -> Prefix -> Bool
nomatch Prefix
qh Prefix
p Prefix
m  = (Int, b) -> Maybe (Int, b)
forall a. a -> Maybe a
Just (Int
n0,b
v0)
            | Prefix -> Prefix -> Bool
zero Prefix
qh Prefix
m       = Trie b -> Maybe (Int, b)
findArc Trie b
l
            | Bool
otherwise       = Trie b -> Maybe (Int, b)
findArc Trie b
r


-- | Given a query, find all prefixes with associated values in the
-- 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 'Data.Trie.matches'.
--
-- @since 0.2.4
matches_ :: Trie a -> ByteString -> [(Int,a)]
matches_ :: Trie a -> ByteString -> [(Int, a)]
matches_ Trie a
t ByteString
q =
#if !defined(__GLASGOW_HASKELL__)
    matchFB_ t q (((:) .) . (,)) []
#else
    (forall b. ((Int, a) -> b -> b) -> b -> b) -> [(Int, a)]
forall a. (forall b. (a -> b -> b) -> b -> b) -> [a]
build (\(Int, a) -> b -> b
cons b
nil -> Trie a -> ByteString -> (Int -> a -> b -> b) -> b -> b
forall a r. Trie a -> ByteString -> (Int -> a -> r -> r) -> r -> r
matchFB_ Trie a
t ByteString
q (((Int, a) -> b -> b
cons ((Int, a) -> b -> b) -> (a -> (Int, a)) -> a -> b -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((a -> (Int, a)) -> a -> b -> b)
-> (Int -> a -> (Int, a)) -> Int -> a -> b -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,)) b
nil)
{-# INLINE matches_ #-}
#endif

matchFB_ :: Trie a -> ByteString -> (Int -> a -> r -> r) -> r -> r
matchFB_ :: Trie a -> ByteString -> (Int -> a -> r -> r) -> r -> r
matchFB_ = \Trie a
t ByteString
q Int -> a -> r -> r
cons r
nil -> (Int -> a -> r -> r) -> ByteString -> Trie a -> r -> r
forall t a. (Int -> t -> a -> a) -> ByteString -> Trie t -> a -> a
matchFB_' Int -> a -> r -> r
cons ByteString
q Trie a
t r
nil
    where
    matchFB_' :: (Int -> t -> a -> a) -> ByteString -> Trie t -> a -> a
matchFB_' Int -> t -> a -> a
cons = ByteString -> Trie t -> a -> a
start
        where
        -- | Deal with epsilon query (when there is no epsilon value)
        start :: ByteString -> Trie t -> a -> a
start ByteString
q (Branch{}) | ByteString -> Bool
S.null ByteString
q = a -> a
forall a. a -> a
id
        start ByteString
q Trie t
t                     = Int -> ByteString -> Trie t -> a -> a
go Int
0 ByteString
q Trie t
t

        -- | The main recursion
        go :: Int -> ByteString -> Trie t -> a -> a
go Int
_ ByteString
_    Trie t
Empty       = a -> a
forall a. a -> a
id
        go Int
n ByteString
q   (Arc ByteString
k Maybe t
mv Trie t
t) =
            let (ByteString
p,ByteString
k',ByteString
q') = ByteString -> ByteString -> (ByteString, ByteString, ByteString)
breakMaximalPrefix ByteString
k ByteString
q
                !n' :: Int
n'       = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
S.length ByteString
p
            in if ByteString -> Bool
S.null ByteString
k'
                then
                    case Maybe t
mv of { Maybe t
Nothing -> a -> a
forall a. a -> a
id; Just t
v  -> Int -> t -> a -> a
cons Int
n' t
v}
                    (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                    if ByteString -> Bool
S.null ByteString
q' then a -> a
forall a. a -> a
id else Int -> ByteString -> Trie t -> a -> a
go Int
n' ByteString
q' Trie t
t
                else a -> a
forall a. a -> a
id
        go Int
n ByteString
q t_ :: Trie t
t_@(Branch{}) = Trie t -> a -> a
findArc Trie t
t_
            where
            qh :: Prefix
qh = String -> ByteString -> Prefix
errorLogHead String
"matches_" ByteString
q
            -- | \(\mathcal{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 :: Trie t -> a -> a
findArc Trie t
Empty         = String -> a -> a
forall a. String -> a
impossible String
"matches_" -- see [Note1]
            findArc t :: Trie t
t@(Arc{})     = Int -> ByteString -> Trie t -> a -> a
go Int
n ByteString
q Trie t
t
            findArc (Branch Prefix
p Prefix
m Trie t
l Trie t
r)
                | Prefix -> Prefix -> Prefix -> Bool
nomatch Prefix
qh Prefix
p Prefix
m  = a -> a
forall a. a -> a
id
                | Prefix -> Prefix -> Bool
zero Prefix
qh Prefix
m       = Trie t -> a -> a
findArc Trie t
l
                | Bool
otherwise       = Trie t -> a -> a
findArc Trie t
r


{-----------------------------------------------------------
-- Simple modification functions (recurse and clone spine)
-----------------------------------------------------------}

-- TODO: We should CPS on Empty to avoid cloning spine if no change.
-- Difficulties arise with the calls to 'branch' and 'arc'. Will
-- have to create a continuation chain, so no savings on memory
-- allocation; but would have savings on held memory, if they're
-- still holding the old one...
--
-- | Generic function to alter a trie by one element with a function
-- to resolve conflicts (or non-conflicts).
alterBy :: (ByteString -> a -> Maybe a -> Maybe a)
         -> ByteString -> a -> Trie a -> Trie a
alterBy :: (ByteString -> a -> Maybe a -> Maybe a)
-> ByteString -> a -> Trie a -> Trie a
alterBy ByteString -> a -> Maybe a -> Maybe a
f ByteString
q a
x = (Maybe a -> Trie a -> (Maybe a, Trie a))
-> ByteString -> Trie a -> Trie a
forall a.
(Maybe a -> Trie a -> (Maybe a, Trie a))
-> ByteString -> Trie a -> Trie a
alterBy_ (\Maybe a
mv Trie a
t -> (ByteString -> a -> Maybe a -> Maybe a
f ByteString
q a
x Maybe a
mv, Trie a
t)) ByteString
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: 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?


-- Not susceptible to [bug26] because it can only delete a single value\/subtrie.
--
-- | A variant of 'alterBy' which also allows modifying the sub-trie.
-- If the function returns @(Just v, t)@ and @lookup 'S.empty' t == Just w@,
-- then the @w@ will be overwritten by @v@.
--
-- @since 0.2.3
-- __Note__: /Type changed in 0.2.6/
alterBy_
    :: (Maybe a -> Trie a -> (Maybe a, Trie a))
    -> ByteString -> Trie a -> Trie a
alterBy_ :: (Maybe a -> Trie a -> (Maybe a, Trie a))
-> ByteString -> Trie a -> Trie a
alterBy_ Maybe a -> Trie a -> (Maybe a, Trie a)
f = ByteString -> Trie a -> Trie a
start
    where
    start :: ByteString -> Trie a -> Trie a
start ByteString
q Trie a
t            | Bool -> Bool
not (ByteString -> Bool
S.null ByteString
q) = ByteString -> Trie a -> Trie a
go ByteString
q Trie a
t
    start ByteString
_ (Arc ByteString
k Maybe a
mv Trie a
s) | ByteString -> Bool
S.null ByteString
k       = Maybe a -> Trie a -> Trie a
forall a. Maybe a -> Trie a -> Trie a
mayEpsilon (Maybe a -> Trie a -> Trie a) -> (Maybe a, Trie a) -> Trie a
forall a b c. (a -> b -> c) -> (a, b) -> c
$$ Maybe a -> Trie a -> (Maybe a, Trie a)
f Maybe a
mv      Trie a
s
    start ByteString
_ Trie a
t                             = Maybe a -> Trie a -> Trie a
forall a. Maybe a -> Trie a -> Trie a
mayEpsilon (Maybe a -> Trie a -> Trie a) -> (Maybe a, Trie a) -> Trie a
forall a b c. (a -> b -> c) -> (a, b) -> c
$$ Maybe a -> Trie a -> (Maybe a, Trie a)
f Maybe a
forall a. Maybe a
Nothing Trie a
t

    -- @go@ is always called with non-null @q@, therefore @nothing@ is too.
    nothing :: ByteString -> Trie a
nothing ByteString
q = ByteString -> Maybe a -> Trie a -> Trie a
forall a. ByteString -> Maybe a -> Trie a -> Trie a
arcNN ByteString
q (Maybe a -> Trie a -> Trie a) -> (Maybe a, Trie a) -> Trie a
forall a b c. (a -> b -> c) -> (a, b) -> c
$$ Maybe a -> Trie a -> (Maybe a, Trie a)
f Maybe a
forall a. Maybe a
Nothing Trie a
forall a. Trie a
Empty

    go :: ByteString -> Trie a -> Trie a
go ByteString
q Trie a
Empty            = ByteString -> Trie a
nothing ByteString
q
    go ByteString
q t :: Trie a
t@(Branch Prefix
p Prefix
m Trie a
l Trie a
r)
        | Prefix -> Prefix -> Prefix -> Bool
nomatch Prefix
qh Prefix
p Prefix
m  =
            case ByteString -> Trie a
nothing ByteString
q of
            Trie a
Empty -> Trie a
t
            Trie a
s     -> Prefix -> Trie a -> Prefix -> Trie a -> Trie a
forall a. Prefix -> Trie a -> Prefix -> Trie a -> Trie a
graft Prefix
p Trie a
t Prefix
qh Trie a
s
        | Prefix -> Prefix -> Bool
zero Prefix
qh Prefix
m       = Prefix -> Prefix -> Trie a -> Trie a -> Trie a
forall a. Prefix -> Prefix -> Trie a -> Trie a -> Trie a
branchL Prefix
p Prefix
m (ByteString -> Trie a -> Trie a
go ByteString
q Trie a
l) Trie a
r
        | Bool
otherwise       = Prefix -> Prefix -> Trie a -> Trie a -> Trie a
forall a. Prefix -> Prefix -> Trie a -> Trie a -> Trie a
branchR Prefix
p Prefix
m Trie a
l (ByteString -> Trie a -> Trie a
go ByteString
q Trie a
r)
        where qh :: Prefix
qh = String -> ByteString -> Prefix
errorLogHead String
"alterBy_" ByteString
q
    go ByteString
q t :: Trie a
t@(Arc ByteString
k Maybe a
mv Trie a
s) =
        let (ByteString
p,ByteString
k',ByteString
q') = ByteString -> ByteString -> (ByteString, ByteString, ByteString)
breakMaximalPrefix ByteString
k ByteString
q in
        case (ByteString -> Bool
S.null ByteString
k', ByteString -> Bool
S.null ByteString
q') of
        (Bool
False, Bool
True)  -> -- add node to middle of Arc
                          ByteString -> Maybe a -> Trie a -> Trie a
forall a. ByteString -> Maybe a -> Trie a -> Trie a
arcNN ByteString
p (Maybe a -> Trie a -> Trie a) -> (Maybe a, Trie a) -> Trie a
forall a b c. (a -> b -> c) -> (a, b) -> c
$$ Maybe a -> Trie a -> (Maybe a, Trie a)
f Maybe a
forall a. Maybe a
Nothing (ByteString -> Maybe a -> Trie a -> Trie a
forall a. ByteString -> Maybe a -> Trie a -> Trie a
Arc ByteString
k' Maybe a
mv Trie a
s)
        (Bool
False, Bool
False) ->
            case ByteString -> Trie a
nothing ByteString
q' of
            Trie a
Empty     -> Trie a
t -- Nothing to add, reuse old Arc
            Branch{}  -> String -> Trie a
forall a. String -> a
impossible String
"alterBy_" -- 'arcNN' can't Branch
            l :: Trie a
l@(Arc{}) ->
                -- Inlined version of @prepend p@, capturing the
                -- invariant that the 'graft' must be a @Branch@.
                (if ByteString -> Bool
S.null ByteString
p then Trie a -> Trie a
forall a. a -> a
id else ByteString -> Maybe a -> Trie a -> Trie a
forall a. ByteString -> Maybe a -> Trie a -> Trie a
Arc ByteString
p Maybe a
forall a. Maybe a
Nothing)
                -- 'arcNN' will always have that the string in @l@
                -- must begin with @q'@, which is non-null here and
                -- therefore @arcPrefix q'@ is equivalent to taking
                -- the 'arcPrefix' of the string in @l@.
                (Trie a -> Trie a) -> Trie a -> Trie a
forall a b. (a -> b) -> a -> b
$ Prefix -> Trie a -> Prefix -> Trie a -> Trie a
forall a. Prefix -> Trie a -> Prefix -> Trie a -> Trie a
graft (ByteString -> Prefix
arcPrefix ByteString
q') Trie a
l (ByteString -> Prefix
arcPrefix ByteString
k') (ByteString -> Maybe a -> Trie a -> Trie a
forall a. ByteString -> Maybe a -> Trie a -> Trie a
Arc ByteString
k' Maybe a
mv Trie a
s)
        (Bool
True, Bool
True)  -> ByteString -> Maybe a -> Trie a -> Trie a
forall a. ByteString -> Maybe a -> Trie a -> Trie a
arcNN ByteString
k (Maybe a -> Trie a -> Trie a) -> (Maybe a, Trie a) -> Trie a
forall a b c. (a -> b -> c) -> (a, b) -> c
$$ Maybe a -> Trie a -> (Maybe a, Trie a)
f Maybe a
mv Trie a
s
        (Bool
True, Bool
False) -> ByteString -> Maybe a -> Trie a -> Trie a
forall a. ByteString -> Maybe a -> Trie a -> Trie a
arcNN ByteString
k Maybe a
mv (ByteString -> Trie a -> Trie a
go ByteString
q' Trie a
s)


-- 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"
-- rather than "Data.Trie"
--
-- | 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 :: (a -> a) -> ByteString -> Trie a -> Trie a
adjust a -> a
f = ByteString -> Trie a -> Trie a
start
    where
    start :: ByteString -> Trie a -> Trie a
start ByteString
q Trie a
t                  | Bool -> Bool
not (ByteString -> Bool
S.null ByteString
q) = ByteString -> Trie a -> Trie a
go ByteString
q Trie a
t
    start ByteString
_ (Arc ByteString
k (Just a
v) Trie a
t) | ByteString -> Bool
S.null ByteString
k       = ByteString -> Maybe a -> Trie a -> Trie a
forall a. ByteString -> Maybe a -> Trie a -> Trie a
Arc ByteString
k (a -> Maybe a
forall a. a -> Maybe a
Just (a -> a
f a
v)) Trie a
t
    start ByteString
_ Trie a
t                                   = Trie a
t

    go :: ByteString -> Trie a -> Trie a
go ByteString
_ Trie a
Empty            = Trie a
forall a. Trie a
Empty
    go ByteString
q t :: Trie a
t@(Branch Prefix
p Prefix
m Trie a
l Trie a
r)
        | Prefix -> Prefix -> Prefix -> Bool
nomatch Prefix
qh Prefix
p Prefix
m  = Trie a
t
        | Prefix -> Prefix -> Bool
zero Prefix
qh Prefix
m       = Prefix -> Prefix -> Trie a -> Trie a -> Trie a
forall a. Prefix -> Prefix -> Trie a -> Trie a -> Trie a
Branch Prefix
p Prefix
m (ByteString -> Trie a -> Trie a
go ByteString
q Trie a
l) Trie a
r
        | Bool
otherwise       = Prefix -> Prefix -> Trie a -> Trie a -> Trie a
forall a. Prefix -> Prefix -> Trie a -> Trie a -> Trie a
Branch Prefix
p Prefix
m Trie a
l (ByteString -> Trie a -> Trie a
go ByteString
q Trie a
r)
        where qh :: Prefix
qh = String -> ByteString -> Prefix
errorLogHead String
"adjust" ByteString
q
    go ByteString
q t :: Trie a
t@(Arc ByteString
k Maybe a
mv Trie a
s) =
        let (ByteString
_,ByteString
k',ByteString
q') = ByteString -> ByteString -> (ByteString, ByteString, ByteString)
breakMaximalPrefix ByteString
k ByteString
q in
        case (ByteString -> Bool
S.null ByteString
k', ByteString -> Bool
S.null ByteString
q') of
        (Bool
False, Bool
_)     -> Trie a
t
        (Bool
True,  Bool
True)  -> ByteString -> Maybe a -> Trie a -> Trie a
forall a. ByteString -> Maybe a -> Trie a -> Trie a
Arc ByteString
k (a -> a
f (a -> a) -> Maybe a -> Maybe a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe a
mv) Trie a
s
        (Bool
True,  Bool
False) -> ByteString -> Maybe a -> Trie a -> Trie a
forall a. ByteString -> Maybe a -> Trie a -> Trie a
Arc ByteString
k Maybe a
mv (ByteString -> Trie a -> Trie a
go ByteString
q' Trie a
s)


{-----------------------------------------------------------
-- Trie-combining functions
-----------------------------------------------------------}

-- TODO: it may be helpful to have a version of 'mergeBy' where the
-- function doesn't return 'Maybe' (i.e., 'Data.Trie.Convenience.unionWith');
-- because knowing we can't delete elements would allow to use true
-- constructors directly, rather than smart constructors that patch
-- up the deletion cases.  Especially since the vast majority of
-- our own uses of 'mergeBy' fall into this category.

-- Not susceptible to [bug26] because it doesn't delete any values.
--
-- Alas, benchmarking indicates that this gives only a very trivial
-- benefit over 'TC.unionWith' as implemented via 'mergeBy'.
--
-- | 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.
wip_unionWith :: (a -> a -> a) -> Trie a -> Trie a -> Trie a
wip_unionWith :: (a -> a -> a) -> Trie a -> Trie a -> Trie a
wip_unionWith a -> a -> a
f = Trie a -> Trie a -> Trie a
start
    where
    -- | Deals with epsilon entries, before recursing into @go@
    -- TODO: for all of these, add assertions that null bytestring entails must be Just; instead of pattern matching on it directly.
    start :: Trie a -> Trie a -> Trie a
start (Arc ByteString
k0 (Just a
v0) Trie a
s0) (Arc ByteString
k1 (Just a
v1) Trie a
s1) | ByteString -> Bool
S.null ByteString
k0 Bool -> Bool -> Bool
&& ByteString -> Bool
S.null ByteString
k1
                                               = a -> Trie a -> Trie a
forall a. a -> Trie a -> Trie a
epsilon (a -> a -> a
f a
v0 a
v1) (Trie a -> Trie a -> Trie a
go Trie a
s0 Trie a
s1)
    start (Arc ByteString
k0 (Just a
v0) Trie a
s0) Trie a
t1 | ByteString -> Bool
S.null ByteString
k0 = a -> Trie a -> Trie a
forall a. a -> Trie a -> Trie a
epsilon a
v0 (Trie a -> Trie a -> Trie a
go Trie a
s0 Trie a
t1)
    start Trie a
t0 (Arc ByteString
k1 (Just a
v1) Trie a
s1) | ByteString -> Bool
S.null ByteString
k1 = a -> Trie a -> Trie a
forall a. a -> Trie a -> Trie a
epsilon a
v1 (Trie a -> Trie a -> Trie a
go Trie a
t0 Trie a
s1)
    start Trie a
t0 Trie a
t1                                = Trie a -> Trie a -> Trie a
go Trie a
t0 Trie a
t1

    -- | The main recursion
    go :: Trie a -> Trie a -> Trie a
go Trie a
Empty Trie a
t1    = Trie a
t1
    go Trie a
t0    Trie a
Empty = Trie a
t0
    -- \(\mathcal{O}(n+m)\) for this part where \(n\) and \(m\) are
    -- sizes of the branchings.
    go t0 :: Trie a
t0@(Branch Prefix
p0 Prefix
m0 Trie a
l0 Trie a
r0)
       t1 :: Trie a
t1@(Branch Prefix
p1 Prefix
m1 Trie a
l1 Trie a
r1)
        | Prefix -> Prefix -> Bool
shorter Prefix
m0 Prefix
m1  = Trie a
union0
        | Prefix -> Prefix -> Bool
shorter Prefix
m1 Prefix
m0  = Trie a
union1
        | Prefix
p0 Prefix -> Prefix -> Bool
forall a. Eq a => a -> a -> Bool
== Prefix
p1       = Prefix -> Prefix -> Trie a -> Trie a -> Trie a
forall a. Prefix -> Prefix -> Trie a -> Trie a -> Trie a
Branch Prefix
p0 Prefix
m0 (Trie a -> Trie a -> Trie a
go Trie a
l0 Trie a
l1) (Trie a -> Trie a -> Trie a
go Trie a
r0 Trie a
r1)
        | Bool
otherwise      = Prefix -> Trie a -> Prefix -> Trie a -> Trie a
forall a. Prefix -> Trie a -> Prefix -> Trie a -> Trie a
graft Prefix
p0 Trie a
t0 Prefix
p1 Trie a
t1
        where
        union0 :: Trie a
union0  | Prefix -> Prefix -> Prefix -> Bool
nomatch Prefix
p1 Prefix
p0 Prefix
m0  = Prefix -> Trie a -> Prefix -> Trie a -> Trie a
forall a. Prefix -> Trie a -> Prefix -> Trie a -> Trie a
graft Prefix
p0 Trie a
t0 Prefix
p1 Trie a
t1
                | Prefix -> Prefix -> Bool
zero Prefix
p1 Prefix
m0        = Prefix -> Prefix -> Trie a -> Trie a -> Trie a
forall a. Prefix -> Prefix -> Trie a -> Trie a -> Trie a
Branch Prefix
p0 Prefix
m0 (Trie a -> Trie a -> Trie a
go Trie a
l0 Trie a
t1) Trie a
r0
                | Bool
otherwise         = Prefix -> Prefix -> Trie a -> Trie a -> Trie a
forall a. Prefix -> Prefix -> Trie a -> Trie a -> Trie a
Branch Prefix
p0 Prefix
m0 Trie a
l0 (Trie a -> Trie a -> Trie a
go Trie a
r0 Trie a
t1)
        union1 :: Trie a
union1  | Prefix -> Prefix -> Prefix -> Bool
nomatch Prefix
p0 Prefix
p1 Prefix
m1  = Prefix -> Trie a -> Prefix -> Trie a -> Trie a
forall a. Prefix -> Trie a -> Prefix -> Trie a -> Trie a
graft Prefix
p0 Trie a
t0 Prefix
p1 Trie a
t1
                | Prefix -> Prefix -> Bool
zero Prefix
p0 Prefix
m1        = Prefix -> Prefix -> Trie a -> Trie a -> Trie a
forall a. Prefix -> Prefix -> Trie a -> Trie a -> Trie a
Branch Prefix
p1 Prefix
m1 (Trie a -> Trie a -> Trie a
go Trie a
t0 Trie a
l1) Trie a
r1
                | Bool
otherwise         = Prefix -> Prefix -> Trie a -> Trie a -> Trie a
forall a. Prefix -> Prefix -> Trie a -> Trie a -> Trie a
Branch Prefix
p1 Prefix
m1 Trie a
l1 (Trie a -> Trie a -> Trie a
go Trie a
t0 Trie a
r1)
    --
    go t0 :: Trie a
t0@(Arc ByteString
k0 Maybe a
mv0 Trie a
s0)
       t1 :: Trie a
t1@(Arc ByteString
k1 Maybe a
mv1 Trie a
s1)
        = ByteString
-> Trie a
-> ByteString
-> Trie a
-> (ByteString -> ByteString -> ByteString -> Trie a)
-> Trie a
forall a.
ByteString
-> Trie a
-> ByteString
-> Trie a
-> (ByteString -> ByteString -> ByteString -> Trie a)
-> Trie a
arcMerge ByteString
k0 Trie a
t0 ByteString
k1 Trie a
t1 ((ByteString -> ByteString -> ByteString -> Trie a) -> Trie a)
-> (ByteString -> ByteString -> ByteString -> Trie a) -> Trie a
forall a b. (a -> b) -> a -> b
$ \ ByteString
pre ByteString
k0' ByteString
k1' ->
            let {-# INLINE t0' #-}
                t0' :: Trie a
t0' = ByteString -> Maybe a -> Trie a -> Trie a
forall a. ByteString -> Maybe a -> Trie a -> Trie a
Arc ByteString
k0' Maybe a
mv0 Trie a
s0
                {-# INLINE t1' #-}
                t1' :: Trie a
t1' = ByteString -> Maybe a -> Trie a -> Trie a
forall a. ByteString -> Maybe a -> Trie a -> Trie a
Arc ByteString
k1' Maybe a
mv1 Trie a
s1
            in
            case (ByteString -> Bool
S.null ByteString
k0', ByteString -> Bool
S.null ByteString
k1') of
            (Bool
True, Bool
True)  -> ByteString -> Maybe a -> Trie a -> Trie a
forall a. ByteString -> Maybe a -> Trie a -> Trie a
arcNN ByteString
pre ((a -> a -> Maybe a) -> Maybe a -> Maybe a -> Maybe a
forall a. (a -> a -> Maybe a) -> Maybe a -> Maybe a -> Maybe a
mergeMaybe (\a
v0 a
v1 -> a -> Maybe a
forall a. a -> Maybe a
Just (a -> a -> a
f a
v0 a
v1)) Maybe a
mv0 Maybe a
mv1) (Trie a -> Trie a -> Trie a
go Trie a
s0 Trie a
s1) -- TODO: if both arcs are reject, then both @s0,s1@ are branches so we can simplify the 'arcNN' to avoid the case analysis in 'prependNN'.
            (Bool
True, Bool
False) -> ByteString -> Maybe a -> Trie a -> Trie a
forall a. ByteString -> Maybe a -> Trie a -> Trie a
Arc ByteString
pre Maybe a
mv0 (Trie a -> Trie a -> Trie a
go Trie a
s0  Trie a
t1')
            (Bool
False,Bool
True)  -> ByteString -> Maybe a -> Trie a -> Trie a
forall a. ByteString -> Maybe a -> Trie a -> Trie a
Arc ByteString
pre Maybe a
mv1 (Trie a -> Trie a -> Trie a
go Trie a
t0' Trie a
s1)
            (Bool
False,Bool
False) -> ByteString
-> ByteString -> Trie a -> ByteString -> Trie a -> Trie a
forall a.
ByteString
-> ByteString -> Trie a -> ByteString -> Trie a -> Trie a
wye ByteString
pre ByteString
k0' Trie a
t0' ByteString
k1' Trie a
t1'
    go t0 :: Trie a
t0@(Arc ByteString
k0 Maybe a
_ Trie a
_)
       t1 :: Trie a
t1@(Branch Prefix
p1 Prefix
m1 Trie a
l Trie a
r)
        | Prefix -> Prefix -> Prefix -> Bool
nomatch Prefix
p0 Prefix
p1 Prefix
m1 = Prefix -> Trie a -> Prefix -> Trie a -> Trie a
forall a. Prefix -> Trie a -> Prefix -> Trie a -> Trie a
graft Prefix
p1 Trie a
t1  Prefix
p0 Trie a
t0
        | Prefix -> Prefix -> Bool
zero Prefix
p0 Prefix
m1       = Prefix -> Prefix -> Trie a -> Trie a -> Trie a
forall a. Prefix -> Prefix -> Trie a -> Trie a -> Trie a
Branch Prefix
p1 Prefix
m1 (Trie a -> Trie a -> Trie a
go Trie a
t0 Trie a
l) Trie a
r
        | Bool
otherwise        = Prefix -> Prefix -> Trie a -> Trie a -> Trie a
forall a. Prefix -> Prefix -> Trie a -> Trie a -> Trie a
Branch Prefix
p1 Prefix
m1 Trie a
l (Trie a -> Trie a -> Trie a
go Trie a
t0 Trie a
r)
        where p0 :: Prefix
p0 = ByteString -> Prefix
arcPrefix ByteString
k0
    go t0 :: Trie a
t0@(Branch Prefix
p0 Prefix
m0 Trie a
l Trie a
r)
       t1 :: Trie a
t1@(Arc ByteString
k1 Maybe a
_ Trie a
_)
        | Prefix -> Prefix -> Prefix -> Bool
nomatch Prefix
p1 Prefix
p0 Prefix
m0 = Prefix -> Trie a -> Prefix -> Trie a -> Trie a
forall a. Prefix -> Trie a -> Prefix -> Trie a -> Trie a
graft Prefix
p0 Trie a
t0  Prefix
p1 Trie a
t1
        | Prefix -> Prefix -> Bool
zero Prefix
p1 Prefix
m0       = Prefix -> Prefix -> Trie a -> Trie a -> Trie a
forall a. Prefix -> Prefix -> Trie a -> Trie a -> Trie a
Branch Prefix
p0 Prefix
m0 (Trie a -> Trie a -> Trie a
go Trie a
l Trie a
t1) Trie a
r
        | Bool
otherwise        = Prefix -> Prefix -> Trie a -> Trie a -> Trie a
forall a. Prefix -> Prefix -> Trie a -> Trie a -> Trie a
Branch Prefix
p0 Prefix
m0 Trie a
l (Trie a -> Trie a -> Trie a
go Trie a
r Trie a
t1)
        where p1 :: Prefix
p1 = ByteString -> Prefix
arcPrefix ByteString
k1


-- FIXME: See [bug26].
-- TEST CASES: foldr (unionL . uncurry singleton) empty t
--             foldr (uncurry insert) empty t
--    where t = map (\s -> (pk s, 0))
--                  ["heat","hello","hoi","apple","appa","hell","appb","appc"]
--
-- | 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).
mergeBy :: (a -> a -> Maybe a) -> Trie a -> Trie a -> Trie a
mergeBy :: (a -> a -> Maybe a) -> Trie a -> Trie a -> Trie a
mergeBy a -> a -> Maybe a
f = Trie a -> Trie a -> Trie a
start
    where
    -- | Deals with epsilon entries, before recursing into @go@
    -- TODO: for all of these, add assertions that null bytestring entails must be Just; instead of pattern matching on it directly.
    start :: Trie a -> Trie a -> Trie a
start (Arc ByteString
k0 (Just a
v0) Trie a
s0) (Arc ByteString
k1 (Just a
v1) Trie a
s1) | ByteString -> Bool
S.null ByteString
k0 Bool -> Bool -> Bool
&& ByteString -> Bool
S.null ByteString
k1
                                               = Maybe a -> Trie a -> Trie a
forall a. Maybe a -> Trie a -> Trie a
mayEpsilon (a -> a -> Maybe a
f a
v0 a
v1) (Trie a -> Trie a -> Trie a
go Trie a
s0 Trie a
s1)
    start (Arc ByteString
k0 (Just a
v0) Trie a
s0) Trie a
t1 | ByteString -> Bool
S.null ByteString
k0 = a -> Trie a -> Trie a
forall a. a -> Trie a -> Trie a
epsilon a
v0 (Trie a -> Trie a -> Trie a
go Trie a
s0 Trie a
t1)
    start Trie a
t0 (Arc ByteString
k1 (Just a
v1) Trie a
s1) | ByteString -> Bool
S.null ByteString
k1 = a -> Trie a -> Trie a
forall a. a -> Trie a -> Trie a
epsilon a
v1 (Trie a -> Trie a -> Trie a
go Trie a
t0 Trie a
s1)
    start Trie a
t0 Trie a
t1                                = Trie a -> Trie a -> Trie a
go Trie a
t0 Trie a
t1

    -- | The main recursion
    go :: Trie a -> Trie a -> Trie a
go Trie a
Empty Trie a
t1    = Trie a
t1
    go Trie a
t0    Trie a
Empty = Trie a
t0
    -- \(\mathcal{O}(n+m)\) for this part where \(n\) and \(m\) are
    -- sizes of the branchings.
    go t0 :: Trie a
t0@(Branch Prefix
p0 Prefix
m0 Trie a
l0 Trie a
r0)
       t1 :: Trie a
t1@(Branch Prefix
p1 Prefix
m1 Trie a
l1 Trie a
r1)
        | Prefix -> Prefix -> Bool
shorter Prefix
m0 Prefix
m1  = Trie a
union0
        | Prefix -> Prefix -> Bool
shorter Prefix
m1 Prefix
m0  = Trie a
union1
        | Prefix
p0 Prefix -> Prefix -> Bool
forall a. Eq a => a -> a -> Bool
== Prefix
p1       = Prefix -> Prefix -> Trie a -> Trie a -> Trie a
forall a. Prefix -> Prefix -> Trie a -> Trie a -> Trie a
branch Prefix
p0 Prefix
m0 (Trie a -> Trie a -> Trie a
go Trie a
l0 Trie a
l1) (Trie a -> Trie a -> Trie a
go Trie a
r0 Trie a
r1)
        | Bool
otherwise      = Prefix -> Trie a -> Prefix -> Trie a -> Trie a
forall a. Prefix -> Trie a -> Prefix -> Trie a -> Trie a
graft Prefix
p0 Trie a
t0 Prefix
p1 Trie a
t1
        where
        union0 :: Trie a
union0  | Prefix -> Prefix -> Prefix -> Bool
nomatch Prefix
p1 Prefix
p0 Prefix
m0  = Prefix -> Trie a -> Prefix -> Trie a -> Trie a
forall a. Prefix -> Trie a -> Prefix -> Trie a -> Trie a
graft Prefix
p0 Trie a
t0 Prefix
p1 Trie a
t1
                | Prefix -> Prefix -> Bool
zero Prefix
p1 Prefix
m0        = Prefix -> Prefix -> Trie a -> Trie a -> Trie a
forall a. Prefix -> Prefix -> Trie a -> Trie a -> Trie a
branchL Prefix
p0 Prefix
m0 (Trie a -> Trie a -> Trie a
go Trie a
l0 Trie a
t1) Trie a
r0
                | Bool
otherwise         = Prefix -> Prefix -> Trie a -> Trie a -> Trie a
forall a. Prefix -> Prefix -> Trie a -> Trie a -> Trie a
branchR Prefix
p0 Prefix
m0 Trie a
l0 (Trie a -> Trie a -> Trie a
go Trie a
r0 Trie a
t1)
        union1 :: Trie a
union1  | Prefix -> Prefix -> Prefix -> Bool
nomatch Prefix
p0 Prefix
p1 Prefix
m1  = Prefix -> Trie a -> Prefix -> Trie a -> Trie a
forall a. Prefix -> Trie a -> Prefix -> Trie a -> Trie a
graft Prefix
p0 Trie a
t0 Prefix
p1 Trie a
t1
                | Prefix -> Prefix -> Bool
zero Prefix
p0 Prefix
m1        = Prefix -> Prefix -> Trie a -> Trie a -> Trie a
forall a. Prefix -> Prefix -> Trie a -> Trie a -> Trie a
branchL Prefix
p1 Prefix
m1 (Trie a -> Trie a -> Trie a
go Trie a
t0 Trie a
l1) Trie a
r1
                | Bool
otherwise         = Prefix -> Prefix -> Trie a -> Trie a -> Trie a
forall a. Prefix -> Prefix -> Trie a -> Trie a -> Trie a
branchR Prefix
p1 Prefix
m1 Trie a
l1 (Trie a -> Trie a -> Trie a
go Trie a
t0 Trie a
r1)
    --
    go t0 :: Trie a
t0@(Arc ByteString
k0 Maybe a
mv0 Trie a
s0)
       t1 :: Trie a
t1@(Arc ByteString
k1 Maybe a
mv1 Trie a
s1)
        = ByteString
-> Trie a
-> ByteString
-> Trie a
-> (ByteString -> ByteString -> ByteString -> Trie a)
-> Trie a
forall a.
ByteString
-> Trie a
-> ByteString
-> Trie a
-> (ByteString -> ByteString -> ByteString -> Trie a)
-> Trie a
arcMerge ByteString
k0 Trie a
t0 ByteString
k1 Trie a
t1 ((ByteString -> ByteString -> ByteString -> Trie a) -> Trie a)
-> (ByteString -> ByteString -> ByteString -> Trie a) -> Trie a
forall a b. (a -> b) -> a -> b
$ \ ByteString
pre ByteString
k0' ByteString
k1' ->
            let {-# INLINE t0' #-}
                t0' :: Trie a
t0' = ByteString -> Maybe a -> Trie a -> Trie a
forall a. ByteString -> Maybe a -> Trie a -> Trie a
Arc ByteString
k0' Maybe a
mv0 Trie a
s0
                {-# INLINE t1' #-}
                t1' :: Trie a
t1' = ByteString -> Maybe a -> Trie a -> Trie a
forall a. ByteString -> Maybe a -> Trie a -> Trie a
Arc ByteString
k1' Maybe a
mv1 Trie a
s1
            in
            -- TODO: can be smarter than 'arcNN' here...
            case (ByteString -> Bool
S.null ByteString
k0', ByteString -> Bool
S.null ByteString
k1') of
            (Bool
True, Bool
True)  -> ByteString -> Maybe a -> Trie a -> Trie a
forall a. ByteString -> Maybe a -> Trie a -> Trie a
arcNN ByteString
pre ((a -> a -> Maybe a) -> Maybe a -> Maybe a -> Maybe a
forall a. (a -> a -> Maybe a) -> Maybe a -> Maybe a -> Maybe a
mergeMaybe a -> a -> Maybe a
f Maybe a
mv0 Maybe a
mv1) (Trie a -> Trie a -> Trie a
go Trie a
s0 Trie a
s1)
            (Bool
True, Bool
False) -> ByteString -> Maybe a -> Trie a -> Trie a
forall a. ByteString -> Maybe a -> Trie a -> Trie a
arcNN ByteString
pre Maybe a
mv0 (Trie a -> Trie a -> Trie a
go Trie a
s0  Trie a
t1')
            (Bool
False,Bool
True)  -> ByteString -> Maybe a -> Trie a -> Trie a
forall a. ByteString -> Maybe a -> Trie a -> Trie a
arcNN ByteString
pre Maybe a
mv1 (Trie a -> Trie a -> Trie a
go Trie a
t0' Trie a
s1)
            (Bool
False,Bool
False) -> ByteString
-> ByteString -> Trie a -> ByteString -> Trie a -> Trie a
forall a.
ByteString
-> ByteString -> Trie a -> ByteString -> Trie a -> Trie a
wye ByteString
pre ByteString
k0' Trie a
t0' ByteString
k1' Trie a
t1'
    go t0 :: Trie a
t0@(Arc ByteString
k0 Maybe a
_ Trie a
_)
       t1 :: Trie a
t1@(Branch Prefix
p1 Prefix
m1 Trie a
l Trie a
r)
        | Prefix -> Prefix -> Prefix -> Bool
nomatch Prefix
p0 Prefix
p1 Prefix
m1 = Prefix -> Trie a -> Prefix -> Trie a -> Trie a
forall a. Prefix -> Trie a -> Prefix -> Trie a -> Trie a
graft Prefix
p1 Trie a
t1  Prefix
p0 Trie a
t0
        | Prefix -> Prefix -> Bool
zero Prefix
p0 Prefix
m1       = Prefix -> Prefix -> Trie a -> Trie a -> Trie a
forall a. Prefix -> Prefix -> Trie a -> Trie a -> Trie a
branchL Prefix
p1 Prefix
m1 (Trie a -> Trie a -> Trie a
go Trie a
t0 Trie a
l) Trie a
r
        | Bool
otherwise        = Prefix -> Prefix -> Trie a -> Trie a -> Trie a
forall a. Prefix -> Prefix -> Trie a -> Trie a -> Trie a
branchR Prefix
p1 Prefix
m1 Trie a
l (Trie a -> Trie a -> Trie a
go Trie a
t0 Trie a
r)
        where p0 :: Prefix
p0 = ByteString -> Prefix
arcPrefix ByteString
k0
    go t0 :: Trie a
t0@(Branch Prefix
p0 Prefix
m0 Trie a
l Trie a
r)
       t1 :: Trie a
t1@(Arc ByteString
k1 Maybe a
_ Trie a
_)
        | Prefix -> Prefix -> Prefix -> Bool
nomatch Prefix
p1 Prefix
p0 Prefix
m0 = Prefix -> Trie a -> Prefix -> Trie a -> Trie a
forall a. Prefix -> Trie a -> Prefix -> Trie a -> Trie a
graft Prefix
p0 Trie a
t0  Prefix
p1 Trie a
t1
        | Prefix -> Prefix -> Bool
zero Prefix
p1 Prefix
m0       = Prefix -> Prefix -> Trie a -> Trie a -> Trie a
forall a. Prefix -> Prefix -> Trie a -> Trie a -> Trie a
branchL Prefix
p0 Prefix
m0 (Trie a -> Trie a -> Trie a
go Trie a
l Trie a
t1) Trie a
r
        | Bool
otherwise        = Prefix -> Prefix -> Trie a -> Trie a -> Trie a
forall a. Prefix -> Prefix -> Trie a -> Trie a -> Trie a
branchR Prefix
p0 Prefix
m0 Trie a
l (Trie a -> Trie a -> Trie a
go Trie a
r Trie a
t1)
        where p1 :: Prefix
p1 = ByteString -> Prefix
arcPrefix ByteString
k1


mergeMaybe :: (a -> a -> Maybe a) -> Maybe a -> Maybe a -> Maybe a
{-# INLINE mergeMaybe #-}
mergeMaybe :: (a -> a -> Maybe a) -> Maybe a -> Maybe a -> Maybe a
mergeMaybe a -> a -> Maybe a
_ Maybe a
Nothing      Maybe a
Nothing  = Maybe a
forall a. Maybe a
Nothing
mergeMaybe a -> a -> Maybe a
_ Maybe a
Nothing mv1 :: Maybe a
mv1@(Just a
_)  = Maybe a
mv1
mergeMaybe a -> a -> Maybe a
_ mv0 :: Maybe a
mv0@(Just a
_) Maybe a
Nothing  = Maybe a
mv0
mergeMaybe a -> a -> Maybe a
f (Just a
v0)   (Just a
v1) = a -> a -> Maybe a
f a
v0 a
v1


-- FIXME: See [bug26].
-- | 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 :: (a -> b -> Maybe c) -> Trie a -> Trie b -> Trie c
intersectBy a -> b -> Maybe c
f = Trie a -> Trie b -> Trie c
start
    where
    -- | Deals with epsilon entries, before recursing into @go@
    start :: Trie a -> Trie b -> Trie c
start (Arc ByteString
k0 Maybe a
mv0 Trie a
s0) (Arc ByteString
k1 Maybe b
mv1 Trie b
s1) | ByteString -> Bool
S.null ByteString
k0 Bool -> Bool -> Bool
&& ByteString -> Bool
S.null ByteString
k1
        = Maybe c -> Trie c -> Trie c
forall a. Maybe a -> Trie a -> Trie a
mayEpsilon ((a -> b -> Maybe c) -> Maybe a -> Maybe b -> Maybe c
forall a b c. (a -> b -> Maybe c) -> Maybe a -> Maybe b -> Maybe c
intersectMaybe a -> b -> Maybe c
f Maybe a
mv0 Maybe b
mv1) (Trie a -> Trie b -> Trie c
go Trie a
s0 Trie b
s1)
    start (Arc ByteString
k0 (Just a
_) Trie a
s0) Trie b
t1 | ByteString -> Bool
S.null ByteString
k0 = Trie a -> Trie b -> Trie c
go Trie a
s0 Trie b
t1
    start Trie a
t0 (Arc ByteString
k1 (Just b
_) Trie b
s1) | ByteString -> Bool
S.null ByteString
k1 = Trie a -> Trie b -> Trie c
go Trie a
t0 Trie b
s1
    start Trie a
t0 Trie b
t1                               = Trie a -> Trie b -> Trie c
go Trie a
t0 Trie b
t1

    -- | The main recursion
    go :: Trie a -> Trie b -> Trie c
go Trie a
Empty Trie b
_    =  Trie c
forall a. Trie a
Empty
    go Trie a
_    Trie b
Empty =  Trie c
forall a. Trie a
Empty
    go t0 :: Trie a
t0@(Branch Prefix
p0 Prefix
m0 Trie a
l0 Trie a
r0)
       t1 :: Trie b
t1@(Branch Prefix
p1 Prefix
m1 Trie b
l1 Trie b
r1)
        | Prefix -> Prefix -> Bool
shorter Prefix
m0 Prefix
m1 = Trie c
isect0
        | Prefix -> Prefix -> Bool
shorter Prefix
m1 Prefix
m0 = Trie c
isect1
        | Prefix
p0 Prefix -> Prefix -> Bool
forall a. Eq a => a -> a -> Bool
== Prefix
p1      = Prefix -> Prefix -> Trie c -> Trie c -> Trie c
forall a. Prefix -> Prefix -> Trie a -> Trie a -> Trie a
branch Prefix
p0 Prefix
m0 (Trie a -> Trie b -> Trie c
go Trie a
l0 Trie b
l1) (Trie a -> Trie b -> Trie c
go Trie a
r0 Trie b
r1)
        | Bool
otherwise     = Trie c
forall a. Trie a
Empty
        where
        isect0 :: Trie c
isect0  | Prefix -> Prefix -> Prefix -> Bool
nomatch Prefix
p1 Prefix
p0 Prefix
m0  = Trie c
forall a. Trie a
Empty
                | Prefix -> Prefix -> Bool
zero Prefix
p1 Prefix
m0        = Trie a -> Trie b -> Trie c
go Trie a
l0 Trie b
t1
                | Bool
otherwise         = Trie a -> Trie b -> Trie c
go Trie a
r0 Trie b
t1
        isect1 :: Trie c
isect1  | Prefix -> Prefix -> Prefix -> Bool
nomatch Prefix
p0 Prefix
p1 Prefix
m1  = Trie c
forall a. Trie a
Empty
                | Prefix -> Prefix -> Bool
zero Prefix
p0 Prefix
m1        = Trie a -> Trie b -> Trie c
go Trie a
t0 Trie b
l1
                | Bool
otherwise         = Trie a -> Trie b -> Trie c
go Trie a
t0 Trie b
r1
    go (Arc ByteString
k0 Maybe a
mv0 Trie a
s0)
       (Arc ByteString
k1 Maybe b
mv1 Trie b
s1)
        -- We can simplify 'getMask' to 'xor' here, avoiding the
        -- cost of the 'highestBitMask'; because we don't care about
        -- the actual mask itself, just the nonzero-ness.
        | Prefix -> Prefix -> Prefix
forall a. Bits a => a -> a -> a
xor (ByteString -> Prefix
arcPrefix ByteString
k0) (ByteString -> Prefix
arcPrefix ByteString
k1) Prefix -> Prefix -> Bool
forall a. Eq a => a -> a -> Bool
/= Prefix
0 = Trie c
forall a. Trie a
Empty
        | Bool
otherwise =
            let (ByteString
pre,ByteString
k0',ByteString
k1') = ByteString -> ByteString -> (ByteString, ByteString, ByteString)
breakMaximalPrefix ByteString
k0 ByteString
k1 in
            if ByteString -> Bool
S.null ByteString
pre
            then String -> Trie c
forall a. HasCallStack => String -> a
error String
"intersectBy: no mask, but no prefix string"
            else
                let {-# INLINE t0' #-}
                    t0' :: Trie a
t0' = ByteString -> Maybe a -> Trie a -> Trie a
forall a. ByteString -> Maybe a -> Trie a -> Trie a
Arc ByteString
k0' Maybe a
mv0 Trie a
s0
                    {-# INLINE t1' #-}
                    t1' :: Trie b
t1' = ByteString -> Maybe b -> Trie b -> Trie b
forall a. ByteString -> Maybe a -> Trie a -> Trie a
Arc ByteString
k1' Maybe b
mv1 Trie b
s1
                in
                -- TODO: be smarter about the recursion and 'prependNN'
                case (ByteString -> Bool
S.null ByteString
k0', ByteString -> Bool
S.null ByteString
k1') of
                (Bool
True, Bool
True)  -> ByteString -> Maybe c -> Trie c -> Trie c
forall a. ByteString -> Maybe a -> Trie a -> Trie a
arcNN ByteString
pre ((a -> b -> Maybe c) -> Maybe a -> Maybe b -> Maybe c
forall a b c. (a -> b -> Maybe c) -> Maybe a -> Maybe b -> Maybe c
intersectMaybe a -> b -> Maybe c
f Maybe a
mv0 Maybe b
mv1) (Trie a -> Trie b -> Trie c
go Trie a
s0 Trie b
s1)
                (Bool
True, Bool
False) -> ByteString -> Trie c -> Trie c
forall a. ByteString -> Trie a -> Trie a
prependNN ByteString
pre (Trie a -> Trie b -> Trie c
go Trie a
s0  Trie b
t1')
                (Bool
False,Bool
True)  -> ByteString -> Trie c -> Trie c
forall a. ByteString -> Trie a -> Trie a
prependNN ByteString
pre (Trie a -> Trie b -> Trie c
go Trie a
t0' Trie b
s1)
                (Bool
False,Bool
False) -> ByteString -> Trie c -> Trie c
forall a. ByteString -> Trie a -> Trie a
prependNN ByteString
pre (Trie a -> Trie b -> Trie c
go Trie a
t0' Trie b
t1')
    go t0 :: Trie a
t0@(Arc ByteString
k0 Maybe a
_ Trie a
_)
       (Branch Prefix
p1 Prefix
m1 Trie b
l Trie b
r)
        | Prefix -> Prefix -> Prefix -> Bool
nomatch Prefix
p0 Prefix
p1 Prefix
m1 = Trie c
forall a. Trie a
Empty
        | Prefix -> Prefix -> Bool
zero Prefix
p0 Prefix
m1       = Trie a -> Trie b -> Trie c
go Trie a
t0 Trie b
l
        | Bool
otherwise        = Trie a -> Trie b -> Trie c
go Trie a
t0 Trie b
r
        where p0 :: Prefix
p0 = ByteString -> Prefix
arcPrefix ByteString
k0
    go (Branch Prefix
p0 Prefix
m0 Trie a
l Trie a
r)
       t1 :: Trie b
t1@(Arc ByteString
k1 Maybe b
_ Trie b
_)
        | Prefix -> Prefix -> Prefix -> Bool
nomatch Prefix
p1 Prefix
p0 Prefix
m0 = Trie c
forall a. Trie a
Empty
        | Prefix -> Prefix -> Bool
zero Prefix
p1 Prefix
m0       = Trie a -> Trie b -> Trie c
go Trie a
l Trie b
t1
        | Bool
otherwise        = Trie a -> Trie b -> Trie c
go Trie a
r Trie b
t1
        where p1 :: Prefix
p1 = ByteString -> Prefix
arcPrefix ByteString
k1


intersectMaybe :: (a -> b -> Maybe c) -> Maybe a -> Maybe b -> Maybe c
{-# INLINE intersectMaybe #-}
intersectMaybe :: (a -> b -> Maybe c) -> Maybe a -> Maybe b -> Maybe c
intersectMaybe a -> b -> Maybe c
f (Just a
v0) (Just b
v1) = a -> b -> Maybe c
f a
v0 b
v1
intersectMaybe a -> b -> Maybe c
_ Maybe a
_         Maybe b
_         = Maybe c
forall a. Maybe a
Nothing


-- TODO(github#23): add 'differenceBy'


{-----------------------------------------------------------
-- Priority-queue functions
-----------------------------------------------------------}
-- TODO: should verify that all of these are now free of the quadratic
-- slowdown from reconstructing keys. They should be, but just to
-- verify that some new quadratic hasn't accidentally crept in...

-- | Return the lexicographically smallest 'ByteString' and the
-- value it's mapped to; or 'Nothing' for the empty trie.  When one
-- entry is a prefix of another, the prefix will be returned.
--
-- __Note__: Prior to version 0.2.7, this function suffered
-- <Data-Trie-Internal.html#bug25 Bug #25>; but it no longer does.
--
-- @since 0.2.2
minAssoc :: Trie a -> Maybe (ByteString, a)
minAssoc :: Trie a -> Maybe (ByteString, a)
minAssoc = RevLazyByteString -> Trie a -> Maybe (ByteString, a)
forall b. RevLazyByteString -> Trie b -> Maybe (ByteString, b)
go RevLazyByteString
Nil
    where
    go :: RevLazyByteString -> Trie b -> Maybe (ByteString, b)
go !RevLazyByteString
_ Trie b
Empty              = Maybe (ByteString, b)
forall a. Maybe a
Nothing
    go  RevLazyByteString
q (Arc ByteString
k (Just b
v) Trie b
_) = (ByteString, b) -> Maybe (ByteString, b)
forall a. a -> Maybe a
Just (RevLazyByteString -> ByteString
toStrict (RevLazyByteString
q RevLazyByteString -> ByteString -> RevLazyByteString
+>? ByteString
k), b
v)
    go  RevLazyByteString
q (Arc ByteString
k Maybe b
Nothing  Trie b
t) = RevLazyByteString -> Trie b -> Maybe (ByteString, b)
go (RevLazyByteString
q RevLazyByteString -> ByteString -> RevLazyByteString
+>! ByteString
k) Trie b
t
    go  RevLazyByteString
q (Branch Prefix
_ Prefix
_ Trie b
l Trie b
_)   = RevLazyByteString -> Trie b -> Maybe (ByteString, b)
go RevLazyByteString
q Trie b
l


-- | Return the lexicographically largest 'ByteString' and the
-- value it's mapped to; or 'Nothing' for the empty trie.  When one
-- entry is a prefix of another, the longer one will be returned.
--
-- __Note__: Prior to version 0.2.7, this function suffered
-- <Data-Trie-Internal.html#bug25 Bug #25>; but it no longer does.
--
-- @since 0.2.2
maxAssoc :: Trie a -> Maybe (ByteString, a)
maxAssoc :: Trie a -> Maybe (ByteString, a)
maxAssoc = RevLazyByteString -> Trie a -> Maybe (ByteString, a)
forall b. RevLazyByteString -> Trie b -> Maybe (ByteString, b)
go RevLazyByteString
Nil
    where
    go :: RevLazyByteString -> Trie b -> Maybe (ByteString, b)
go !RevLazyByteString
_ Trie b
Empty                  = Maybe (ByteString, b)
forall a. Maybe a
Nothing
    go  RevLazyByteString
q (Arc ByteString
k (Just b
v) Trie b
Empty) = (ByteString, b) -> Maybe (ByteString, b)
forall a. a -> Maybe a
Just (RevLazyByteString -> ByteString
toStrict (RevLazyByteString
q RevLazyByteString -> ByteString -> RevLazyByteString
+>? ByteString
k), b
v)
    go  RevLazyByteString
q (Arc ByteString
k (Just b
_) Trie b
t)     = RevLazyByteString -> Trie b -> Maybe (ByteString, b)
go (RevLazyByteString
q RevLazyByteString -> ByteString -> RevLazyByteString
+>? ByteString
k) Trie b
t
    go  RevLazyByteString
q (Arc ByteString
k Maybe b
Nothing  Trie b
t)     = RevLazyByteString -> Trie b -> Maybe (ByteString, b)
go (RevLazyByteString
q RevLazyByteString -> ByteString -> RevLazyByteString
+>! ByteString
k) Trie b
t
    go  RevLazyByteString
q (Branch Prefix
_ Prefix
_ Trie b
_ Trie b
r)       = RevLazyByteString -> Trie b -> Maybe (ByteString, b)
go RevLazyByteString
q Trie b
r


mapView :: (Trie a -> Trie a)
        -> Maybe (ByteString, a, Trie a) -> Maybe (ByteString, a, Trie a)
{-# INLINE mapView #-}
mapView :: (Trie a -> Trie a)
-> Maybe (ByteString, a, Trie a) -> Maybe (ByteString, a, Trie a)
mapView Trie a -> Trie a
_ Maybe (ByteString, a, Trie a)
Nothing        = Maybe (ByteString, a, Trie a)
forall a. Maybe a
Nothing
mapView Trie a -> Trie a
f (Just (ByteString
k,a
v,Trie a
t)) = (ByteString, a, Trie a) -> Maybe (ByteString, a, Trie a)
forall a. a -> Maybe a
Just (ByteString
k,a
v, Trie a -> Trie a
f Trie a
t)


-- Not susceptible to [bug26] because it can only delete a single value.
--
-- | Update the 'minAssoc' and return the old 'minAssoc'.
--
-- __Note__: Prior to version 0.2.7, this function suffered
-- <Data-Trie-Internal.html#bug25 Bug #25>; but it no longer does.
--
-- @since 0.2.2
updateMinViewBy :: (ByteString -> a -> Maybe a)
                -> Trie a -> Maybe (ByteString, a, Trie a)
updateMinViewBy :: (ByteString -> a -> Maybe a)
-> Trie a -> Maybe (ByteString, a, Trie a)
updateMinViewBy ByteString -> a -> Maybe a
f = RevLazyByteString -> Trie a -> Maybe (ByteString, a, Trie a)
go RevLazyByteString
Nil
    where
    go :: RevLazyByteString -> Trie a -> Maybe (ByteString, a, Trie a)
go !RevLazyByteString
_ Trie a
Empty              = Maybe (ByteString, a, Trie a)
forall a. Maybe a
Nothing
    go  RevLazyByteString
q (Arc ByteString
k (Just a
v) Trie a
t) = let q' :: ByteString
q' = RevLazyByteString -> ByteString
toStrict (RevLazyByteString
q RevLazyByteString -> ByteString -> RevLazyByteString
+>? ByteString
k)
                               in (ByteString, a, Trie a) -> Maybe (ByteString, a, Trie a)
forall a. a -> Maybe a
Just (ByteString
q',a
v, ByteString -> Maybe a -> Trie a -> Trie a
forall a. ByteString -> Maybe a -> Trie a -> Trie a
arc ByteString
k (ByteString -> a -> Maybe a
f ByteString
q' a
v) Trie a
t)
    go  RevLazyByteString
q (Arc ByteString
k Maybe a
Nothing  Trie a
t) = (Trie a -> Trie a)
-> Maybe (ByteString, a, Trie a) -> Maybe (ByteString, a, Trie a)
forall a.
(Trie a -> Trie a)
-> Maybe (ByteString, a, Trie a) -> Maybe (ByteString, a, Trie a)
mapView (ByteString -> Trie a -> Trie a
forall a. ByteString -> Trie a -> Trie a
prependNN ByteString
k) (RevLazyByteString -> Trie a -> Maybe (ByteString, a, Trie a)
go (RevLazyByteString
q RevLazyByteString -> ByteString -> RevLazyByteString
+>! ByteString
k) Trie a
t)
    go  RevLazyByteString
q (Branch Prefix
p Prefix
m Trie a
l Trie a
r)   = (Trie a -> Trie a)
-> Maybe (ByteString, a, Trie a) -> Maybe (ByteString, a, Trie a)
forall a.
(Trie a -> Trie a)
-> Maybe (ByteString, a, Trie a) -> Maybe (ByteString, a, Trie a)
mapView (\Trie a
l' -> Prefix -> Prefix -> Trie a -> Trie a -> Trie a
forall a. Prefix -> Prefix -> Trie a -> Trie a -> Trie a
branchL Prefix
p Prefix
m Trie a
l' Trie a
r) (RevLazyByteString -> Trie a -> Maybe (ByteString, a, Trie a)
go RevLazyByteString
q Trie a
l)


-- Not susceptible to [bug26] because it can only delete a single value.
--
-- | Update the 'maxAssoc' and return the old 'maxAssoc'.
--
-- __Note__: Prior to version 0.2.7, this function suffered
-- <Data-Trie-Internal.html#bug25 Bug #25>; but it no longer does.
--
-- @since 0.2.2
updateMaxViewBy :: (ByteString -> a -> Maybe a)
                -> Trie a -> Maybe (ByteString, a, Trie a)
updateMaxViewBy :: (ByteString -> a -> Maybe a)
-> Trie a -> Maybe (ByteString, a, Trie a)
updateMaxViewBy ByteString -> a -> Maybe a
f = RevLazyByteString -> Trie a -> Maybe (ByteString, a, Trie a)
go RevLazyByteString
Nil
    where
    go :: RevLazyByteString -> Trie a -> Maybe (ByteString, a, Trie a)
go !RevLazyByteString
_ Trie a
Empty                  = Maybe (ByteString, a, Trie a)
forall a. Maybe a
Nothing
    go  RevLazyByteString
q (Arc ByteString
k (Just a
v) Trie a
Empty) = let q' :: ByteString
q' = RevLazyByteString -> ByteString
toStrict (RevLazyByteString
q RevLazyByteString -> ByteString -> RevLazyByteString
+>? ByteString
k)
                                   in (ByteString, a, Trie a) -> Maybe (ByteString, a, Trie a)
forall a. a -> Maybe a
Just (ByteString
q',a
v, ByteString -> Maybe a -> Trie a -> Trie a
forall a. ByteString -> Maybe a -> Trie a -> Trie a
arc ByteString
k (ByteString -> a -> Maybe a
f ByteString
q' a
v) Trie a
forall a. Trie a
Empty)
    go  RevLazyByteString
q (Arc ByteString
k mv :: Maybe a
mv@(Just a
_) Trie a
t)  = (Trie a -> Trie a)
-> Maybe (ByteString, a, Trie a) -> Maybe (ByteString, a, Trie a)
forall a.
(Trie a -> Trie a)
-> Maybe (ByteString, a, Trie a) -> Maybe (ByteString, a, Trie a)
mapView (ByteString -> Maybe a -> Trie a -> Trie a
forall a. ByteString -> Maybe a -> Trie a -> Trie a
Arc ByteString
k Maybe a
mv) (RevLazyByteString -> Trie a -> Maybe (ByteString, a, Trie a)
go (RevLazyByteString
q RevLazyByteString -> ByteString -> RevLazyByteString
+>? ByteString
k) Trie a
t)
    go  RevLazyByteString
q (Arc ByteString
k Maybe a
Nothing     Trie a
t)  = (Trie a -> Trie a)
-> Maybe (ByteString, a, Trie a) -> Maybe (ByteString, a, Trie a)
forall a.
(Trie a -> Trie a)
-> Maybe (ByteString, a, Trie a) -> Maybe (ByteString, a, Trie a)
mapView (ByteString -> Trie a -> Trie a
forall a. ByteString -> Trie a -> Trie a
prepend ByteString
k)   (RevLazyByteString -> Trie a -> Maybe (ByteString, a, Trie a)
go (RevLazyByteString
q RevLazyByteString -> ByteString -> RevLazyByteString
+>! ByteString
k) Trie a
t)
    go  RevLazyByteString
q (Branch Prefix
p Prefix
m Trie a
l Trie a
r)       = (Trie a -> Trie a)
-> Maybe (ByteString, a, Trie a) -> Maybe (ByteString, a, Trie a)
forall a.
(Trie a -> Trie a)
-> Maybe (ByteString, a, Trie a) -> Maybe (ByteString, a, Trie a)
mapView (Prefix -> Prefix -> Trie a -> Trie a -> Trie a
forall a. Prefix -> Prefix -> Trie a -> Trie a -> Trie a
branchR Prefix
p Prefix
m Trie a
l) (RevLazyByteString -> Trie a -> Maybe (ByteString, a, Trie a)
go RevLazyByteString
q Trie a
r)

------------------------------------------------------------
------------------------------------------------------- fin.