diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -52,7 +52,6 @@ language extensions. The complete list of extensions used is: * CPP -* ForeignFunctionInterface * MagicHash * NoImplicitPrelude diff --git a/bytestring-trie.cabal b/bytestring-trie.cabal --- a/bytestring-trie.cabal +++ b/bytestring-trie.cabal @@ -1,5 +1,5 @@ ------------------------------------------------------------ --- wren gayle romano ~ 2019.02.23 +-- wren gayle romano ~ 2019.02.25 ------------------------------------------------------------ -- By and large Cabal >=1.2 is fine; but @@ -10,7 +10,7 @@ Build-Type: Simple Name: bytestring-trie -Version: 0.2.4.3 +Version: 0.2.5.0 Stability: provisional Homepage: http://wrengr.org Author: wren gayle romano @@ -53,22 +53,15 @@ GHC ==7.8.1, GHC ==7.8.2, GHC ==7.8.3, GHC ==7.8.4, GHC ==7.10.1, GHC ==7.10.2, GHC ==7.10.3, GHC ==8.0.1, GHC ==8.0.2, - GHC ==8.2.1, GHC ==8.2.2 - -- TODO: re-enable these and get them to work. - -- GHC ==8.4.1, GHC ==8.4.2, GHC ==8.4.3, - -- GHC ==8.6.1, GHC ==8.6.2 + GHC ==8.2.1, GHC ==8.2.2, + GHC ==8.4.1, GHC ==8.4.2, GHC ==8.4.3, + GHC ==8.6.1, GHC ==8.6.2 Source-Repository head Type: git Location: https://github.com/wrengr/bytestring-trie.git ------------------------------------------------------------ -Flag useCinternal - Default: False - Description: Use optimized C implementation for indexOfDifference. - See notes in Data.Trie.ByteStringInternal. - ------------------------------------------------------------- Library Hs-Source-Dirs: src Exposed-Modules: Data.Trie @@ -77,15 +70,12 @@ Other-Modules: Data.Trie.BitTwiddle , Data.Trie.ByteStringInternal , Data.Trie.Errors - Build-Depends: base >= 4 && < 4.11 - , bytestring >= 0.9 && < 0.11 - , binary + -- The lower bounds are more restrictive than necessary. + -- But then, we don't maintain any CI tests for older + -- versions, so these are the lowest bounds we've verified. + Build-Depends: base >= 4.5 && < 4.13 + , bytestring >= 0.9.2 && < 0.11 + , binary >= 0.5.1 && < 0.8.7 - if flag(useCinternal) - C-Sources: src/Data/Trie/ByteStringInternal/indexOfDifference.c - CC-Options: -O3 - Cpp-Options: -D__USE_C_INTERNAL__ --- Also need to add stuff to run Configure.hs, FWIW - ------------------------------------------------------------ ------------------------------------------------------- fin. diff --git a/src/Data/Trie/ByteStringInternal.hs b/src/Data/Trie/ByteStringInternal.hs --- a/src/Data/Trie/ByteStringInternal.hs +++ b/src/Data/Trie/ByteStringInternal.hs @@ -1,29 +1,16 @@ -{- -The C algorithm does not appear to give notable performance -improvements, at least when building tries based on /usr/dict on -little-endian 32-bit machines. The implementation also appears -somewhat buggy (cf test/TrieFile.hs) and using the FFI complicates -distribution. - -{-# LANGUAGE CPP, ForeignFunctionInterface #-} -{-# CFILES ByteStringInternal/indexOfDifference.c #-} --} - {-# OPTIONS_GHC -Wall -fwarn-tabs #-} - ----------------------------------------------------------------- --- ~ 2009.02.06 +------------------------------------------------------------ +-- ~ 2019.02.25 -- | -- Module : Data.Trie.ByteStringInternal --- Copyright : Copyright (c) 2008--2015 wren gayle romano +-- Copyright : Copyright (c) 2008--2019 wren gayle romano -- License : BSD3 -- Maintainer : wren@community.haskell.org -- Stability : experimental --- Portability : portable +-- Portability : GHC-only -- -- Helper functions on 'ByteString's for "Data.Trie.Internal". ----------------------------------------------------------------- - +------------------------------------------------------------ module Data.Trie.ByteStringInternal ( ByteString, ByteStringElem @@ -31,41 +18,35 @@ ) where import qualified Data.ByteString as S -import Data.ByteString.Internal (ByteString(..), inlinePerformIO) +import Data.ByteString.Internal (ByteString(PS)) import Data.Word - -import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) -import Foreign.Ptr (Ptr, plusPtr) -import Foreign.Storable (Storable(..)) - -{- -#ifdef __USE_C_INTERNAL__ -import Foreign.C.Types (CInt) -import Control.Monad (liftM) -#endif --} - ----------------------------------------------------------------- +import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) +import Foreign.Ptr (Ptr, plusPtr) +import Foreign.Storable (Storable(..)) +-- This module name is since @__GLASGOW_HASKELL__ >= 611@. +import GHC.IO (unsafeDupablePerformIO) +------------------------------------------------------------ -- | Associated type of 'ByteString' -type ByteStringElem = Word8 +type ByteStringElem = Word8 ----------------------------------------------------------------- +------------------------------------------------------------ -- | Returns the longest shared prefix and the two remaining suffixes -- for a pair of strings. -- -- > s == (\(pre,s',z') -> pre `append` s') (breakMaximalPrefix s z) -- > z == (\(pre,s',z') -> pre `append` z') (breakMaximalPrefix s z) - -breakMaximalPrefix :: ByteString -> ByteString - -> (ByteString, ByteString, ByteString) breakMaximalPrefix + :: ByteString + -> ByteString + -> (ByteString, ByteString, ByteString) +breakMaximalPrefix str1@(PS s1 off1 len1) str2@(PS s2 off2 len2) | len1 == 0 = (S.empty, S.empty, str2) | len2 == 0 = (S.empty, str1, S.empty) - | otherwise = inlinePerformIO $ + | otherwise = unsafeDupablePerformIO $ withForeignPtr s1 $ \p1 -> withForeignPtr s2 $ \p2 -> do i <- indexOfDifference @@ -77,44 +58,45 @@ else newPS s2 off2 i let s1' = newPS s1 (off1 + i) (len1 - i) let s2' = newPS s2 (off2 + i) (len2 - i) - + return $! (,,) !$ pre !$ s1' !$ s2' --- | C-style pointer addition, without the liberal type of 'plusPtr'. +-- | Get the 'sizeOf' the type, without requiring @-XScopedTypeVariables@ +-- nor making a spurious call to 'unsafePerformIO' or similar. +sizeOfPtr :: Storable a => Ptr a -> Int +sizeOfPtr = sizeOf . (undefined :: Ptr a -> a) +{-# INLINE sizeOfPtr #-} + +-- | C-style pointer addition, without the excessively liberal type +-- of 'plusPtr'. ptrElemOff :: Storable a => Ptr a -> Int -> Ptr a +ptrElemOff p i = p `plusPtr` (i * sizeOfPtr p) {-# INLINE ptrElemOff #-} -ptrElemOff p i = - p `plusPtr` (i * sizeOf (undefined `asTypeOf` inlinePerformIO (peek p))) +-- | Smart-constructor to share 'S.empty' as appropriate. newPS :: ForeignPtr ByteStringElem -> Int -> Int -> ByteString +newPS s o l = if l <= 0 then S.empty else PS s o l {-# INLINE newPS #-} -newPS s o l = - if l <= 0 then S.empty else PS s o l -- | fix associativity bug (!$) :: (a -> b) -> a -> b -{-# INLINE (!$) #-} (!$) = ($!) +{-# INLINE (!$) #-} ----------------------------------------------------------------- +------------------------------------------------------------ +-- This naive algorithm doesn't depend on architecture details. We +-- could speed things up (in theory) by checking a natural word at +-- a time and then falling back to checking each byte once the +-- mismatched word is found. But in practice that doesn't seem to +-- actually speed things up. +-- -- | Calculates the first index where values differ. - -indexOfDifference :: Ptr ByteStringElem -> Ptr ByteStringElem -> Int -> IO Int -{- -#ifdef __USE_C_INTERNAL__ - -indexOfDifference p q i = - liftM fromIntegral $! c_indexOfDifference p q (fromIntegral i) - --- This could probably be not IO, but the wrapper requires that anyways... -foreign import ccall unsafe "ByteStringInternal/indexOfDifference.h indexOfDifference" - c_indexOfDifference :: Ptr ByteStringElem -> Ptr ByteStringElem -> CInt -> IO CInt - -#else --} - --- Use the naive algorithm which doesn't depend on architecture details +indexOfDifference + :: Ptr ByteStringElem + -> Ptr ByteStringElem + -> Int + -> IO Int indexOfDifference p1 p2 limit = goByte 0 where goByte n = @@ -125,9 +107,6 @@ if c1 == c2 then goByte $! n+1 else return n -{- -#endif --} ----------------------------------------------------------------- ------------------------------------------------------------ fin. +------------------------------------------------------------ +------------------------------------------------------- fin. diff --git a/src/Data/Trie/ByteStringInternal/indexOfDifference.c b/src/Data/Trie/ByteStringInternal/indexOfDifference.c deleted file mode 100644 --- a/src/Data/Trie/ByteStringInternal/indexOfDifference.c +++ /dev/null @@ -1,175 +0,0 @@ -/* ------------------------------------------------------------- --- ~ 2009.01.07 --- | --- Module : Data.Trie.ByteStringInternal.indexOfDifference --- Copyright : Copyright (c) 2008--2015 wren gayle romano --- License : BSD3 --- Maintainer : wren@community.haskell.org --- Stability : beta --- Portability : portable --- --- More efficient implementation (in theory) than testing characters --- byte by byte. However, the gains seem to be minimal and ---more --- importantly--- there seem to be obscure bugs that only show up --- in extensive testing (e.g. running TrieFile on /usr/dict). Maybe --- worth pursuing further, especially if SSE's 126-bit registers --- or GCC's vectors can be leveraged in a portable way. -------------------------------------------------------------- */ - -/* Defines certain architecture characteristics. - * Created by Configure.hs */ -#include "indexOfDifference.h" - -typedef unsigned char Word8; -typedef unsigned short Word16; -typedef unsigned long Word32; -typedef unsigned long long Word64; - -/* Hopefully this makes Nat the most optimal size, or the same as int */ -#ifdef __hDataTrie_Nat64__ - typedef Word64 Nat; -# define MIN_NAT ((Nat) 0x8000000000000000ull) -#elif defined(__hDataTrie_Nat32__) - typedef Word32 Nat; -# define MIN_NAT ((Nat) 0x80000000) -#else - /* No definition. Unknown architecture. - * Maybe it'd be worth supporting 16-bit as well...? - * or maybe fail back to 8-bit? */ -#endif - -/* cf also */ -#define NAT_MISALIGNMENT(p) (((int)(p)) % sizeof(Nat)) - - -#define READ_WORD8(p) (*((Word8*) (p))) -#define READ_NAT(p) (*((Nat*) (p))) - - -/* ---------------------------------------------------------- */ -/* Compare up to the first @limit@ bytes of @p1@ against @p2@ - * and return the first index where they differ. */ - -/* TODO: Consider replacing loops by Duff's Device, or similar - */ - -int indexOfDifference(const void* p1, const void* p2, const int limit) { - /* @i@ measures how many bytes are shared, - * Thus it's the 0-based index of difference. */ - int i = 0; - if (limit <= 0) return 0; - - - /* Munge until Nat-aligned (They seem to always be). - * Should fail back to this naive version on unknown arch */ - { - int x1 = NAT_MISALIGNMENT(p1); - int x2 = NAT_MISALIGNMENT(p2); - if (x1 != x2) { - /* FIX: what if they're misaligned differently? - * For now we'll use Word8 all the way */ - x1 = limit; - } - while (i < x1) { - if (READ_WORD8(p1+i) == READ_WORD8(p2+i)) { - i += sizeof(Word8); - } else { - return i; - } - } - if (x1 == limit) { - return limit; - } else { - /* Fall through */ - } - } - - - /* Check one Nat at a time until we find a mismatch */ - Nat diff; - do { - diff = READ_NAT(p1+i) ^ READ_NAT(p2+i); - - /* If the diff is valid and zero, then increment the loop */ - if (i + sizeof(Nat) <= limit && diff == 0) { - i += sizeof(Nat); - } else { - break; - } - } while (i < limit); - - - /* Trim incomplete Nat at the end of the strings */ - if (i + sizeof(Nat) > limit) { - #ifdef __hDataTrie_isLittleEndian__ - diff &= ((1 << ((limit-i) * 8*sizeof(Word8))) - 1); - #else - diff &= MIN_NAT >> ((limit-i) * 8*sizeof(Word8) - 1); - #endif - - if (0 == diff) return limit; - } - - - /* Found a difference. Do binary search to identify first - * byte in Nat which doesn't match. */ - Word32 w32; - #ifdef __hDataTrie_Nat64__ - # ifdef __hDataTrie_isLittleEndian__ - const Word32 first32 = (Word32) (diff & 0x00000000FFFFFFFFull); - # else - const Word32 first32 = (Word32)((diff & 0xFFFFFFFF00000000ull) >> 32); - # endif - if (0 == first32) { - i += 4; - # ifdef __hDataTrie_isLittleEndian__ - w32 = (Word32)((diff & 0xFFFFFFFF00000000ull) >> 32); - # else - w32 = (Word32) (diff & 0x00000000FFFFFFFFull); - # endif - } else { - w32 = first32; - } - #elif defined(__hDataTrie_Nat32__) - w32 = diff; - #else - /* WTF? */ - #endif - - - Word16 w16; - #if defined(__hDataTrie_Nat32__) || defined(__hDataTrie_Nat64__) - # ifdef __hDataTrie_isLittleEndian__ - const Word16 first16 = (Word16) (w32 & 0x0000FFFF); - # else - const Word16 first16 = (Word16)((w32 & 0xFFFF0000) >> 16); - # endif - if (0 == first16) { - i += 2; - # ifdef __hDataTrie_isLittleEndian__ - w16 = (Word16)((w32 & 0xFFFF0000) >> 16); - # else - w16 = (Word16) (w32 & 0x0000FFFF); - # endif - } else { - w16 = first16; - } - #else - /* WTF? */ - #endif - - - Word8 w8; - #ifdef __hDataTrie_isLittleEndian__ - const Word8 first8 = (Word8) (w16 & 0x00FF); - #else - const Word8 first8 = (Word8)((w16 & 0xFF00) >> 8); - #endif - if (0 == first8) { - i += 1; - } - - return i; -} -/* ---------------------------------------------------------- */ -/* ----------------------------------------------------- fin. */ diff --git a/src/Data/Trie/Internal.hs b/src/Data/Trie/Internal.hs --- a/src/Data/Trie/Internal.hs +++ b/src/Data/Trie/Internal.hs @@ -2,16 +2,16 @@ {-# OPTIONS_GHC -Wall -fwarn-tabs -fno-warn-unused-imports #-} {-# LANGUAGE NoImplicitPrelude #-} --- For list fusion on toListBy, and for applicative hiding +-- For list fusion on toListBy, and guarding `base` versions. {-# LANGUAGE CPP #-} ----------------------------------------------------------------- --- ~ 2014.10.09 +------------------------------------------------------------ +-- ~ 2019.02.24 -- | -- Module : Data.Trie.Internal --- Copyright : Copyright (c) 2008--2015 wren gayle romano +-- Copyright : Copyright (c) 2008--2019 wren gayle romano -- License : BSD3 --- Maintainer : wren@community.haskell.org +-- Maintainer : wren@cpan.org -- Stability : provisional -- Portability : portable (with CPP) -- @@ -20,32 +20,32 @@ -- from "Data.Trie", which is the preferred API for users. This -- module is for developers who need deeper (and potentially fragile) -- access to the abstract type. ----------------------------------------------------------------- +------------------------------------------------------------ module Data.Trie.Internal ( -- * Data types Trie(), showTrie - + -- * Functions for 'ByteString's , breakMaximalPrefix - + -- * Basic functions , empty, null, singleton, size - + -- * Conversion and folding functions , foldrWithKey, toListBy - + -- * Query functions , lookupBy_, submap , match_, matches_ - + -- * Single-value modification , alterBy, alterBy_, adjustBy - + -- * Combining tries , mergeBy - + -- * Mapping functions , mapBy , filterMap @@ -53,7 +53,7 @@ , contextualMap' , contextualFilterMap , contextualMapBy - + -- * Priority-queue functions , minAssoc, maxAssoc , updateMinViewBy, updateMaxViewBy @@ -67,7 +67,9 @@ import Data.Trie.BitTwiddle import Data.Binary - +#if MIN_VERSION_base(4,9,0) +import Data.Semigroup (Semigroup(..)) +#endif import Data.Monoid (Monoid(..)) import Control.Monad (liftM, liftM3, liftM4) import Control.Monad (ap) @@ -78,13 +80,13 @@ #ifdef __GLASGOW_HASKELL__ import GHC.Exts (build) #endif ----------------------------------------------------------------- ----------------------------------------------------------------- +------------------------------------------------------------ +------------------------------------------------------------ -{--------------------------------------------------------------- +{----------------------------------------------------------- -- 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 @@ -173,9 +175,9 @@ -- TODO? add Ord instance like Data.Map? -{--------------------------------------------------------------- +{----------------------------------------------------------- -- Trie instances: serialization et cetera ----------------------------------------------------------------} +-----------------------------------------------------------} -- This instance does not unveil the innards of our abstract type. -- It doesn't emit truly proper Haskell code though, since ByteStrings @@ -191,7 +193,7 @@ showTrie t = shows' id t "" where spaces f = map (const ' ') (f "") - + shows' _ Empty = (".\n"++) shows' ss (Branch p m l r) = let s' = ("--"++) . shows p . (","++) . shows m . ("-+"++) @@ -213,7 +215,7 @@ put Empty = do put (0 :: Word8) put (Arc k m t) = do put (1 :: Word8); put k; put m; put t put (Branch p m l r) = do put (2 :: Word8); put p; put m; put l; put r - + get = do tag <- get :: Get Word8 case tag of 0 -> return Empty @@ -221,9 +223,9 @@ _ -> liftM4 Branch get get get get -{--------------------------------------------------------------- +{----------------------------------------------------------- -- Trie instances: Abstract Nonsense ----------------------------------------------------------------} +-----------------------------------------------------------} instance Functor Trie where fmap f = go @@ -289,7 +291,7 @@ -- 3. (m >>= f) >>= g == m >>= (\x -> f x >>= g) instance Monad Trie where return = singleton S.empty - + (>>=) Empty _ = empty (>>=) (Branch p m l r) f = branch p m (l >>= f) (r >>= f) (>>=) (Arc k Nothing t) f = arc k Nothing (t >>= f) @@ -298,6 +300,17 @@ unionL = mergeBy (\x _ -> Just x) +#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. +instance (Semigroup a) => Semigroup (Trie a) where + (<>) = mergeBy $ \x y -> Just (x <> y) + -- TODO: optimized implementations of: + -- sconcat :: NonEmpty a -> a + -- stimes :: Integral b => b -> a -> a +#endif + -- This instance is more sensible than Data.IntMap and Data.Map's instance (Monoid a) => Monoid (Trie a) where mempty = empty @@ -328,9 +341,9 @@ -} -{--------------------------------------------------------------- +{----------------------------------------------------------- -- Extra mapping functions ----------------------------------------------------------------} +-----------------------------------------------------------} -- | Apply a function to all values, potentially removing them. filterMap :: (a -> Maybe b) -> Trie a -> Trie b @@ -397,9 +410,9 @@ go q (Branch p m l r) = branch p m (go q l) (go q r) -{--------------------------------------------------------------- +{----------------------------------------------------------- -- Smart constructors and helper functions for building tries ----------------------------------------------------------------} +-----------------------------------------------------------} -- | Smart constructor to prune @Empty@ from @Branch@es. branch :: Prefix -> Mask -> Trie a -> Trie a -> Trie a @@ -449,9 +462,9 @@ getPrefix Empty = error "getPrefix: no Prefix of Empty" -{--------------------------------------------------------------- +{----------------------------------------------------------- -- Error messages ----------------------------------------------------------------} +-----------------------------------------------------------} -- TODO: shouldn't we inline the logic and just NOINLINE the string constant? There are only three use sites, which themselves aren't inlined... errorLogHead :: String -> ByteString -> ByteStringElem @@ -461,12 +474,12 @@ | otherwise = S.head q ----------------------------------------------------------------- ----------------------------------------------------------------- +------------------------------------------------------------ +------------------------------------------------------------ -{--------------------------------------------------------------- +{----------------------------------------------------------- -- Basic functions ----------------------------------------------------------------} +-----------------------------------------------------------} -- | /O(1)/, Construct the empty trie. empty :: Trie a @@ -501,12 +514,12 @@ size' (Arc _ (Just _) t) f n = size' t f $! n + 1 -{--------------------------------------------------------------- --- Conversion functions ----------------------------------------------------------------} +{----------------------------------------------------------- +-- Conversion functions +-----------------------------------------------------------} -- Still rather inefficient --- +-- -- TODO: rewrite list-catenation to be lazier (real CPS instead of -- function building? is the function building really better than -- (++) anyways?) @@ -563,9 +576,9 @@ #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 @@ -582,10 +595,10 @@ -- | Deal with epsilon query (when there is no epsilon value) lookupBy_' q t@(Branch _ _ _ _) | S.null q = f Nothing t lookupBy_' q t = go q t - + -- | The main recursion go _ Empty = z - + go q (Arc k mv t) = let (_,k',q') = breakMaximalPrefix k q in case (not $ S.null k', S.null q') of @@ -593,11 +606,11 @@ (True, False) -> z (False, True) -> f mv t (False, False) -> go q' t - + go q t_@(Branch _ _ _ _) = findArc t_ where qh = errorLogHead "lookupBy_" q - + -- | /O(min(m,W))/, where /m/ is number of @Arc@s in this -- branching, and /W/ is the word size of the Prefix,Mask type. findArc (Branch p m l r) @@ -626,7 +639,7 @@ submap' Nothing Empty = errorEmptyAfterNothing "submap" submap' Nothing (Arc _ _ _) = errorArcAfterNothing "submap" submap' mx t = Arc q mx t - + errorInvariantBroken :: String -> String -> a {-# NOINLINE errorInvariantBroken #-} errorInvariantBroken s e = error (s ++ ": Invariant was broken" ++ e') @@ -659,10 +672,10 @@ -- | Deal with epsilon query (when there is no epsilon value) start q (Branch _ _ _ _) | S.null q = Nothing start q t = goNothing 0 q t - + -- | The initial recursion goNothing _ _ Empty = Nothing - + goNothing n q (Arc k mv t) = let (p,k',q') = breakMaximalPrefix k q n' = n + S.length p @@ -676,11 +689,11 @@ Nothing -> goNothing n' q' t Just v -> goJust n' v n' q' t else Nothing - + goNothing n q t_@(Branch _ _ _ _) = findArc t_ where qh = errorLogHead "match_" q - + -- | /O(min(m,W))/, where /m/ is number of @Arc@s in this -- branching, and /W/ is the word size of the Prefix,Mask type. findArc (Branch p m l r) @@ -689,10 +702,10 @@ | otherwise = findArc r findArc t@(Arc _ _ _) = goNothing n q t findArc Empty = Nothing - + -- | The main recursion goJust n0 v0 _ _ Empty = Just (n0,v0) - + goJust n0 v0 n q (Arc k mv t) = let (p,k',q') = breakMaximalPrefix k q n' = n + S.length p @@ -709,11 +722,11 @@ Nothing -> goJust n0 v0 n' q' t Just v -> goJust n' v n' q' t else Just (n0,v0) - + goJust n0 v0 n q t_@(Branch _ _ _ _) = findArc t_ where qh = errorLogHead "match_" q - + -- | /O(min(m,W))/, where /m/ is number of @Arc@s in this -- branching, and /W/ is the word size of the Prefix,Mask type. findArc (Branch p m l r) @@ -748,10 +761,10 @@ -- | Deal with epsilon query (when there is no epsilon value) start q (Branch _ _ _ _) | S.null q = id start q t = go 0 q t - + -- | The main recursion go _ _ Empty = id - + go n q (Arc k mv t) = let (p,k',q') = breakMaximalPrefix k q n' = n + S.length p @@ -762,11 +775,11 @@ . if S.null q' then id else go n' q' t else id - + go n q t_@(Branch _ _ _ _) = findArc t_ where qh = errorLogHead "matches_" q - + -- | /O(min(m,W))/, where /m/ is number of @Arc@s in this -- branching, and /W/ is the word size of the Prefix,Mask type. findArc (Branch p m l r) @@ -777,9 +790,9 @@ findArc Empty = id -{--------------------------------------------------------------- +{----------------------------------------------------------- -- Single-value 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 @@ -796,7 +809,7 @@ -- TODO: benchmark to be sure that this doesn't introduce unforseen performance costs because of the uncurrying etc. --- | A variant of 'alterBy' which also allows modifying the sub-trie. +-- | A variant of 'alterBy' which also allows modifying the sub-trie. alterBy_ :: (ByteString -> a -> Maybe a -> Trie a -> (Maybe a, Trie a)) -> ByteString -> a -> Trie a -> Trie a alterBy_ f_ q_ x_ @@ -805,22 +818,22 @@ where f = f_ q_ x_ nothing q = uncurry (arc q) (f Nothing Empty) - + alterEpsilon t_@Empty = uncurry (arc q_) (f Nothing t_) alterEpsilon t_@(Branch _ _ _ _) = uncurry (arc q_) (f Nothing t_) alterEpsilon t_@(Arc k mv t) | S.null k = uncurry (arc q_) (f mv t) | otherwise = uncurry (arc q_) (f Nothing t_) - - + + go q Empty = nothing q - + go q t@(Branch p m l r) | nomatch qh p m = branchMerge p t qh (nothing q) | zero qh m = branch p m (go q l) r | otherwise = branch p m l (go q r) where qh = errorLogHead "alterBy" q - + go q t_@(Arc k mv t) = let (p,k',q') = breakMaximalPrefix k q in case (not $ S.null k', S.null q') of @@ -832,11 +845,11 @@ l -> arc' (branchMerge (getPrefix l) l (getPrefix r) r) where r = Arc k' mv t - + -- inlined version of 'arc' arc' | S.null p = id | otherwise = Arc p Nothing - + (False, True) -> uncurry (arc k) (f mv t) (False, False) -> arc k mv (go q' t) @@ -853,19 +866,19 @@ | otherwise = go q_ where f = f_ q_ x_ - + adjustEpsilon (Arc k (Just v) t) | S.null k = Arc k (Just (f v)) t adjustEpsilon t_ = t_ - + go _ Empty = Empty - + go q t@(Branch p m l r) | nomatch qh p m = t | zero qh m = Branch p m (go q l) r | otherwise = Branch p m l (go q r) where qh = errorLogHead "adjustBy" q - + go q t_@(Arc k mv t) = let (_,k',q') = breakMaximalPrefix k q in case (not $ S.null k', S.null q') of @@ -875,9 +888,9 @@ (False, False) -> Arc k mv (go q' t) -{--------------------------------------------------------------- +{----------------------------------------------------------- -- Trie-combining functions ----------------------------------------------------------------} +-----------------------------------------------------------} -- TEST CASES: foldr (unionL . uncurry singleton) empty t -- foldr (uncurry insert) empty t @@ -907,12 +920,12 @@ (Arc k1 mv1@(Just _) t1) | S.null k1 = arc k1 mv1 (go t1 t0_) mergeBy' t0_ t1_ = go t0_ t1_ - - + + -- | The main recursion go Empty t1 = t1 go t0 Empty = t0 - + -- /O(n+m)/ for this part where /n/ and /m/ are sizes of the branchings go t0@(Branch p0 m0 l0 r0) t1@(Branch p1 m1 l1 r1) @@ -924,11 +937,11 @@ union0 | nomatch p1 p0 m0 = branchMerge p0 t0 p1 t1 | zero p1 m0 = branch p0 m0 (go l0 t1) r0 | otherwise = branch p0 m0 l0 (go r0 t1) - + union1 | nomatch p0 p1 m1 = branchMerge p0 t0 p1 t1 | zero p0 m1 = branch p1 m1 (go t0 l1) r1 | otherwise = branch p1 m1 l1 (go t0 r1) - + -- We combine these branches of 'go' in order to clarify where the definitions of 'p0', 'p1', 'm'', 'p'' are relevant. However, this may introduce inefficiency in the pattern matching automaton... -- TODO: check. And get rid of 'go'' if it does. go t0_ t1_ = go' t0_ t1_ @@ -937,7 +950,7 @@ p1 = getPrefix t1_ m' = branchMask p0 p1 p' = mask p0 m' - + go' (Arc k0 mv0 t0) (Arc k1 mv1 t1) | m' == 0 = @@ -962,7 +975,7 @@ | nomatch p1 p0 m0 = branchMerge p0 t0_ p1 t1_ | zero p1 m0 = branch p0 m0 (go l t1_) r | otherwise = branch p0 m0 l (go r t1_) - + -- Inlined branchMerge. Both tries are disjoint @Arc@s now. go' _ _ | zero p0 m' = Branch p' m' t0_ t1_ go' _ _ = Branch p' m' t1_ t0_ @@ -976,9 +989,9 @@ mergeMaybe f (Just v0) (Just v1) = f v0 v1 -{--------------------------------------------------------------- +{----------------------------------------------------------- -- Priority-queue functions ----------------------------------------------------------------} +-----------------------------------------------------------} minAssoc :: Trie a -> Maybe (ByteString, a) minAssoc = go S.empty @@ -1025,5 +1038,5 @@ go q (Arc k mv t) = mapView (arc k mv) (go (S.append q k) t) go q (Branch p m l r) = mapView (branch p m l) (go q r) ----------------------------------------------------------------- ------------------------------------------------------------ fin. +------------------------------------------------------------ +------------------------------------------------------- fin.