text-trie (empty) → 0.2.5.0
raw patch · 20 files changed
+2874/−0 lines, 20 filesdep +HUnitdep +QuickCheckdep +basesetup-changed
Dependencies added: HUnit, QuickCheck, base, binary, bytestring, bytestring-trie, microbench, silently, smallcheck, text, text-trie
Files
- AUTHORS +20/−0
- CHANGELOG +5/−0
- LICENSE +33/−0
- README.md +70/−0
- Setup.hs +7/−0
- src/Data/Text/Internal/Word16.hs +47/−0
- src/Data/Trie/Errors.hs +30/−0
- src/Data/Trie/Text.hs +190/−0
- src/Data/Trie/Text/BitTwiddle.hs +178/−0
- src/Data/Trie/Text/Convenience.hs +238/−0
- src/Data/Trie/Text/Internal.hs +1065/−0
- src/Data/Trie/TextInternal.hs +40/−0
- test/Data/Trie/Text/Test.hs +478/−0
- test/Data/Trie/TextInternal/Test.hs +51/−0
- test/FromListBench.hs +60/−0
- test/FromListBench/Text.hs +58/−0
- test/FromListBench/Text/Encode.hs +60/−0
- test/TrieFile/Text.hs +89/−0
- test/test-text-trie.hs +50/−0
- text-trie.cabal +105/−0
+ AUTHORS view
@@ -0,0 +1,20 @@+=== Haskell text-trie package AUTHORS/THANKS file ===++The text-trie package was adapted from bytestring-trie by michael j. klein and is+released under the terms in the LICENSE file.+++The bytestring-trie package was written by wren gayle romano and is+released under the terms in the LICENSE file. I would also like to+give thanks to the following contributers:++Maxime Henrion --- for the Binary (Trie a) instance and extensive+ debugging work including almost all of the QuickCheck properties.++Don Stewart --- for fostering the idea and offering feedback on+ when the unsafe is safe in the internals of ByteStrings.++Mark Wotton --- for benchmarking work comparing Trie to Map ByteString,+ and for debugging.++Gregory Crosswhite --- finding the critical bug in mergeBy
+ CHANGELOG view
@@ -0,0 +1,5 @@+0.2.5.0 (2019.04.02):+- Fixed things to compile with stack lts-13.15+- Modified ByteString cases to use Text+- Modified tests to use Text Trie (e.g. change `Ord` instance to the one produced by `toList16`)+- Modified functions that accept/return built `Text` to use `Data.Text.Lazy`
+ LICENSE view
@@ -0,0 +1,33 @@+Copyright (c) 2008--2013, wren gayle romano, 2019 michael j. klein+ALL RIGHTS RESERVED.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of the copyright holders nor the names of+ other contributors may be used to endorse or promote products+ derived from this software without specific prior written+ permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS+FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE+COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,+BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.+
+ README.md view
@@ -0,0 +1,70 @@+text-trie+===============+[](https://hackage.haskell.org/package/text-trie) +[](https://travis-ci.org/michaeljklein/text-trie) ++The `text-trie` package is a lightweight adaptation of `bytestring-trie` to `Text`.++For the differences in performance, see [bench.md](https://github.com/michaeljklein/text-trie/blob/text-trie/bench.md).+++## bytestring-trie++The [bytestring-trie](https://github.com/wrengr/bytestring-trie) package provides an efficient implementation+of tries mapping `ByteString` to values. The implementation is+based on Okasaki's big-endian patricia trees, à la `IntMap`. We+first trie on the elements of `ByteString` and then trie on the+big-endian bit representation of those elements. Patricia trees+have efficient algorithms for union and other merging operations,+but they're also quick for lookups and insertions.++If you are only interested in being able to associate individual+`ByteString`s to values, then you may prefer the `hashmap` package+which is faster for those only needing a map-like structure. This+package is intended for those who need the extra capabilities that+a trie-like structure can offer (e.g., structure sharing to reduce+memory costs for highly redundant keys, taking the submap of all+keys with a given prefix, contextual mapping, extracting the minimum+and maximum keys, etc.)+++## Install++This is a simple package and should be easy to install. You should+be able to use one of the following standard methods to install it.++```bash+ -- With stack and without the source:+ $> stack install text-trie+ + -- With stack and with the source already:+ $> cd text-trie+ $> stack install+ +```+++## Portability++The implementation only relies on a few basic+language extensions and `DeriveGeneric`. The complete list of extensions used is:++* `CPP`+* `MagicHash`+* `NoImplicitPrelude`+* `StandaloneDeriving`+* `DeriveGeneric`+++## Links++- [Hackage](http://hackage.haskell.org/package/text-trie)+- [GitHub](https://github.com/michaeljklein/text-trie)++- `bytestring-trie`+ * [Website](http://wrengr.org/)+ * [Blog](http://winterkoninkje.dreamwidth.org/)+ * [Twitter](https://twitter.com/wrengr)+ * [Hackage](http://hackage.haskell.org/package/bytestring-trie)+ * [GitHub](https://github.com/wrengr/bytestring-trie)+
+ Setup.hs view
@@ -0,0 +1,7 @@+#!/usr/bin/env runhaskell++module Main (main) where+import Distribution.Simple++main :: IO ()+main = defaultMain
+ src/Data/Text/Internal/Word16.hs view
@@ -0,0 +1,47 @@+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}+{-# LANGUAGE BangPatterns #-}++----------------------------------------------------------------+-- ~ 2019.04.11+-- |+-- Module : Data.Trie.Text.Convenience+-- Copyright : Copyright (c) 2019 michael j. klein+-- License : BSD3+-- Maintainer : lambdamichael@gmail.com+-- Stability : experimental+--+-- Methods for accessing `Text` in terms of its constituent `Word16`'s+----------------------------------------------------------------++module Data.Text.Internal.Word16 where++import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Internal as TI+import qualified Data.Text.Unsafe as TU+import qualified Data.Text.Array as TA+import Data.Word (Word16)++head16 :: Text -> Word16+{-# INLINE [0] head16 #-}+head16 (TI.Text xs i0 _) = xs `TA.unsafeIndex` i0++tail16 :: Text -> Maybe Text+{-# INLINE [1] tail16 #-}+tail16 xs =+ if T.null xs+ then Nothing+ else Just $ TU.dropWord16 1 xs++toList16 :: Text -> [Word16]+toList16 xs =+ case tail16 xs of+ Nothing -> []+ Just ys -> head16 xs : toList16 ys++-- | Length of `Text` in `Word16`'s+-- length16 xs == length (toList16 xs)+length16 :: Text -> Int+{-# INLINE [0] length16 #-}+length16 (TI.Text _ off len) = len - off+
+ src/Data/Trie/Errors.hs view
@@ -0,0 +1,30 @@+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}++----------------------------------------------------------------+-- ~ 2011.02.12+-- |+-- Module : Data.Trie.Errors+-- Copyright : Copyright (c) 2008--2015 wren gayle romano+-- License : BSD3+-- Maintainer : wren@community.haskell.org+-- Stability : experimental+-- Portability : portable+--+-- Internal convenience functions for giving error messages.+----------------------------------------------------------------++module Data.Trie.Errors+ ( impossible+ ) where++----------------------------------------------------------------+----------------------------------------------------------------++-- | The impossible happened. Use this instead of 'undefined' just in case.+impossible :: String -> a+{-# NOINLINE impossible #-}+impossible fn =+ error $ "Data.Trie." ++ fn ++ ": the impossible happened. This is a bug, please report it to the maintainer."++----------------------------------------------------------------+----------------------------------------------------------- fin.
+ src/Data/Trie/Text.hs view
@@ -0,0 +1,190 @@+-- To make GHC stop warning about the Prelude+{-# OPTIONS_GHC -Wall -fwarn-tabs -fno-warn-unused-imports #-}+{-# LANGUAGE NoImplicitPrelude #-}+----------------------------------------------------------------+-- ~ 2019.04.03+-- |+-- Module : Data.Trie.Text+-- Copyright : Copyright (c) 2008--2015 wren gayle romano, 2019 michael j. klein+-- License : BSD3+-- Maintainer : lambdamichael@gmail.com+-- Stability : experimental+--+-- An efficient implementation of finite maps from strings to values.+-- The implementation is based on /big-endian patricia trees/, like+-- "Data.IntMap". We first trie on the `Word16` elements of `T.Text`+-- and then trie on the big-endian bit representation of those+-- elements. For further details, see+--+-- * Original implementation: `bytestring-trie`+-- <https://github.com/wrengr/bytestring-trie>+--+-- * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\",+-- Workshop on ML, September 1998, pages 77-86,+-- <http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.37.5452>+--+-- * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve/+-- /Information Coded In Alphanumeric/\", Journal of the ACM, 15(4),+-- October 1968, pages 514-534.+--+-- This module aims to provide an austere interface, while being+-- detailed enough for most users. For an extended interface with+-- many additional functions, see "Data.Trie.Text.Convenience". For+-- functions that give more detailed (potentially abstraction-breaking)+-- access to the data strucuture, or for experimental functions+-- which aren't quite ready for the public API, see "Data.Trie.Text.Internal".+----------------------------------------------------------------++module Data.Trie.Text+ (+ -- * Data type+ Trie()++ -- * Basic functions+ , empty, null, singleton, size++ -- * Conversion functions+ , fromList, toListBy, toList, keys, elems++ -- * Query functions+ , lookupBy, lookup, member, submap, match, matches++ -- * Single-value modification+ , alterBy, insert, adjust, delete++ -- * Combining tries+ , mergeBy, unionL, unionR++ -- * Mapping functions+ , mapBy, filterMap+ ) where++import Prelude hiding (null, lookup)+import qualified Prelude (null, lookup)++import Data.Trie.Text.Internal+import Data.Trie.Errors (impossible)++import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Lazy as L++import Data.Maybe (isJust)+import Control.Monad (liftM)+----------------------------------------------------------------+----------------------------------------------------------------+++{---------------------------------------------------------------+-- Conversion functions+---------------------------------------------------------------}++-- | Convert association list into a trie. On key conflict, values+-- earlier in the list shadow later ones.+fromList :: [(Text,a)] -> Trie a+{-# INLINE fromList #-}+fromList = foldr (uncurry insert) empty+++-- | Convert trie into association list. Keys will be in sorted order.+toList :: Trie a -> [(L.Text,a)]+{-# INLINE toList #-}+toList = toListBy (,)++-- FIX? should 'keys' and 'elems' move to Data.Trie.Convenience instead?++-- | Return all keys in the trie, in sorted order.+keys :: Trie a -> [L.Text]+{-# INLINE keys #-}+keys = toListBy const++-- | Return all values in the trie, in sorted order according to the keys.+elems :: Trie a -> [a]+{-# INLINE elems #-}+elems = toListBy (flip const)++{---------------------------------------------------------------+-- Query functions (just recurse)+---------------------------------------------------------------}++-- | Generic function to find a value (if it exists) and the subtrie+-- rooted at the prefix.+lookupBy :: (Maybe a -> Trie a -> b) -> Text -> Trie a -> b+{-# INLINE lookupBy #-}+lookupBy f = lookupBy_ f (f Nothing empty) (f Nothing)++-- | Return the value associated with a query string if it exists.+lookup :: Text -> Trie a -> Maybe a+{-# INLINE lookup #-}+lookup = lookupBy_ const Nothing (const Nothing)+++-- TODO? move to "Data.Trie.Convenience"?+-- | Does a string have a value in the trie?+member :: Text -> Trie a -> Bool+{-# INLINE member #-}+member q = isJust . lookup q++-- | Given a query, find the longest prefix with an associated value+-- in the trie, returning that prefix, it's value, and the remaining+-- string.+match :: Trie a -> Text -> Maybe (Text, a, Text)+match t q =+ case match_ t q of+ Nothing -> Nothing+ Just (n,x) ->+ case T.splitAt n q of+ (p,q') -> Just (p, x, q')++-- | Given a query, find all prefixes with associated values in the+-- trie, returning the prefixes, their values, and their remaining+-- strings. This function is a good producer for list fusion.+matches :: Trie a -> Text -> [(Text, a, Text)]+{-# INLINE matches #-}+matches t q = map f (matches_ t q)+ where+ f (n,x) =+ case T.splitAt n q of+ (p,q') -> (p, x, q')++{---------------------------------------------------------------+-- Single-value modification functions (recurse and clone spine)+---------------------------------------------------------------}++-- | Insert a new key. If the key is already present, overrides the+-- old value+insert :: Text -> a -> Trie a -> Trie a+{-# INLINE insert #-}+insert = alterBy (\_ x _ -> Just x)++-- | Apply a function to the value at a key.+adjust :: (a -> a) -> Text -> Trie a -> Trie a+{-# INLINE adjust #-}+adjust f q = adjustBy (\_ _ -> f) q (impossible "adjust")+-- TODO: benchmark vs the definition with alterBy/liftM+++-- | Remove the value stored at a key.+delete :: Text -> Trie a -> Trie a+{-# INLINE delete #-}+delete q = alterBy (\_ _ _ -> Nothing) q (impossible "delete")++{---------------------------------------------------------------+-- Trie-combining functions+---------------------------------------------------------------}++-- | Combine two tries, resolving conflicts by choosing the value+-- from the left trie.+unionL :: Trie a -> Trie a -> Trie a+{-# INLINE unionL #-}+unionL = mergeBy (\x _ -> Just x)++-- | Combine two tries, resolving conflicts by choosing the value+-- from the right trie.+unionR :: Trie a -> Trie a -> Trie a+{-# INLINE unionR #-}+unionR = mergeBy (\_ y -> Just y)++----------------------------------------------------------------+----------------------------------------------------------- fin.+
+ src/Data/Trie/Text/BitTwiddle.hs view
@@ -0,0 +1,178 @@+{-# OPTIONS_GHC -Wall -fwarn-tabs -fno-warn-name-shadowing #-}++-- The MagicHash is for unboxed primitives (-fglasgow-exts also works)+{-# LANGUAGE CPP, MagicHash #-}+{-# LANGUAGE BangPatterns #-}++----------------------------------------------------------------+-- ~ 2019.04.03+-- |+-- Module : Data.Trie.BitTwiddle+-- Copyright : Copyright (c) 2002 Daan Leijen, 2019 michael j. klein+-- License : BSD3+-- Maintainer : lambdamichael@gmail.com+-- Stability : experimental+--+-- Functions to treat 'Word' as a bit-vector for big-endian patricia+-- trees. This code is duplicated from "Data.IntMap". The only+-- differences are that some of the conversion functions are+-- specialized to 'Word8' for bytestrings, instead of being specialized+-- to 'Int'.+----------------------------------------------------------------++module Data.Trie.Text.BitTwiddle+ ( Prefix, Mask++ , zero, nomatch++ , mask, shorter, branchMask+ ) where++import Data.Trie.TextInternal (TextElem)++import Data.Bits++#if __GLASGOW_HASKELL__ >= 503+import GHC.Exts (Int(..), uncheckedShiftRL# )+import GHC.Word (Word16(..))+#elif __GLASGOW_HASKELL__+import GlaExts ( Word8(..), Int(..), uncheckedShiftRL# )+import GHC.Word (Word16(..))+#else+import Data.Word (Word16(..))+#endif++----------------------------------------------------------------++type KeyElem = TextElem+type Prefix = KeyElem+type Mask = KeyElem+++uncheckedShiftRL :: Word16 -> Int -> Word16+{-# INLINE [0] uncheckedShiftRL #-}+#if __GLASGOW_HASKELL__+-- GHC: use unboxing to get @uncheckedShiftRL@ inlined.+uncheckedShiftRL (W16# x) (I# i) = W16# (uncheckedShiftRL# x i)+#else+uncheckedShiftRL x i = shiftR x i+#endif+++{---------------------------------------------------------------+-- Endian independent bit twiddling (Trie endianness, not architecture)+---------------------------------------------------------------}++-- | Is the value under the mask zero?+zero :: KeyElem -> Mask -> Bool+{-# INLINE [0] zero #-}+zero !i !m = i .&. m == 0+++-- | Does a value /not/ match some prefix, for all the bits preceding+-- a masking bit? (Hence a subtree matching the value doesn't exist.)+nomatch :: KeyElem -> Prefix -> Mask -> Bool+{-# INLINE [0] nomatch #-}+nomatch !i !p !m = mask i m /= p++mask :: KeyElem -> Mask -> Prefix+{-# INLINE [0] mask #-}+mask !i !m = maskW i m+++{---------------------------------------------------------------+-- Big endian operations (Trie endianness, not architecture)+---------------------------------------------------------------}++-- | Get mask by setting all bits higher than the smallest bit in+-- @m@. Then apply that mask to @i@.+maskW :: Word16 -> Word16 -> Prefix+{-# INLINE [0] maskW #-}+maskW !i !m = i .&. (complement (m-1) `xor` m)+-- TODO: try the alternatives mentioned in the Containers paper:+-- \i m -> natToElem (i .&. (negate m - m))+-- \i m -> natToElem (i .&. (m * complement 1))+-- N.B. these return /all/ the low bits, and therefore they are not equal functions for all m. They are, however, equal when only one bit of m is set.+++-- | Determine whether the first mask denotes a shorter prefix than+-- the second.+shorter :: Mask -> Mask -> Bool+{-# INLINE [0] shorter #-}+shorter !m1 !m2 = m1 > m2++++-- | Determine first differing bit of two prefixes.+branchMask :: Prefix -> Prefix -> Mask+{-# INLINE [0] branchMask #-}+branchMask !p1 !p2+ = highestBitMask (p1 `xor` p2)+++{---------------------------------------------------------------+ Finding the highest bit (mask) in a word [x] can be done efficiently+ in three ways:+ * convert to a floating point value and the mantissa tells us the+ [log2(x)] that corresponds with the highest bit position. The+ mantissa is retrieved either via the standard C function [frexp]+ or by some bit twiddling on IEEE compatible numbers (float).+ Note that one needs to use at least [double] precision for an+ accurate mantissa of 32 bit numbers.+ * use bit twiddling, a logarithmic sequence of bitwise or's and+ shifts (bit).+ * use processor specific assembler instruction (asm).++ The most portable way would be [bit], but is it efficient enough?+ I have measured the cycle counts of the different methods on an+ AMD Athlon-XP 1800 (~ Pentium III 1.8Ghz) using the RDTSC+ instruction:++ highestBitMask: method cycles+ --------------+ frexp 200+ float 33+ bit 11+ asm 12++ highestBit: method cycles+ --------------+ frexp 195+ float 33+ bit 11+ asm 11++ Wow, the bit twiddling is on today's RISC like machines even+ faster than a single CISC instruction (BSR)!+---------------------------------------------------------------}++{---------------------------------------------------------------+ [highestBitMask] returns a word where only the highest bit is+ set. It is found by first setting all bits in lower positions+ than the highest bit and than taking an exclusive or with the+ original value. Allthough the function may look expensive, GHC+ compiles this into excellent C code that subsequently compiled+ into highly efficient machine code. The algorithm is derived from+ Jorg Arndt's FXT library.+---------------------------------------------------------------}+-- highestBitMask !x+-- = case (x .|. uncheckedShiftRL x 1) of+-- !x -> case (x .|. uncheckedShiftRL x 2) of+-- !x -> case (x .|. uncheckedShiftRL x 4) of+-- !x -> case (x .|. uncheckedShiftRL x 8) of+-- -- !x -> case (x .|. uncheckedShiftRL x 16) of+-- -- !x -> case (x .|. uncheckedShiftRL x 32) of -- for 64 bit platforms+-- !x -> (x `xor` uncheckedShiftRL x 1)+highestBitMask :: Word16 -> Word16+{-# INLINE [0] highestBitMask #-}+highestBitMask !x0 =+ let !x1 = x0 .|. uncheckedShiftRL x0 1 in+ let !x2 = x1 .|. uncheckedShiftRL x1 2 in+ let !x3 = x2 .|. uncheckedShiftRL x2 4 in+ let !x4 = x3 .|. uncheckedShiftRL x3 8 in+ (x4 `xor` uncheckedShiftRL x4 1)+++----------------------------------------------------------------+----------------------------------------------------------- fin.+
+ src/Data/Trie/Text/Convenience.hs view
@@ -0,0 +1,238 @@+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}++----------------------------------------------------------------+-- ~ 2019.04.03+-- |+-- Module : Data.Trie.Text.Convenience+-- Copyright : Copyright (c) 2008--2015 wren gayle romano, 2019 michael j. klein+-- License : BSD3+-- Maintainer : lambdamichael@gmail.com+-- Stability : experimental+--+-- Additional convenience functions. In order to keep "Data.Trie.Text"+-- concise, non-essential and uncommonly used functions have been+-- moved here. Most of these functions simplify the generic functions+-- from "Data.Trie.Text", following after the interface for "Data.Map"+-- and "Data.IntMap".+----------------------------------------------------------------++module Data.Trie.Text.Convenience+ (+ -- * Conversion functions ('fromList' variants)+ -- $fromList+ fromListL, fromListR, fromListS+ , fromListWith, fromListWith'+ , fromListWithL, fromListWithL'++ -- * Query functions ('lookupBy' variants)+ , lookupWithDefault++ -- * Inserting values ('alterBy' variants)+ , insertIfAbsent+ , insertWith, insertWith'+ , insertWithKey, insertWithKey'++ -- * Updating and adjusting values ('alterBy' and 'adjustBy' variants)+ , adjustWithKey+ , update, updateWithKey++ -- * Combining tries ('mergeBy' variants)+ , disunion+ , unionWith, unionWith'+ ) where++import Data.Trie.Text+import Data.Trie.Text.Internal (lookupBy_, adjustBy)+import Data.Trie.Errors (impossible)+import Data.Text (Text)+import Data.List (foldl', sortBy)+import Data.Ord (comparing)++----------------------------------------------------------------+----------------------------------------------------------------+-- $fromList+-- Just like 'fromList' all of these functions convert an association+-- list into a trie, with earlier values shadowing later ones when+-- keys conflict. Depending on the order of keys in the list, there+-- can be as much as 5x speed difference between the left and right+-- variants. Yet, performance is about the same when matching+-- best-case to best-case and worst-case to worst-case (which is+-- which is swapped when reversing the list or changing which+-- function is used).+++-- | A left-fold version of 'fromList'. If you run into issues with+-- stack overflows when using 'fromList' or 'fromListR', then you+-- should use this function instead.+fromListL :: [(Text,a)] -> Trie a+{-# INLINE fromListL #-}+fromListL = foldl' (flip . uncurry $ insertIfAbsent) empty++-- | An explicitly right-fold variant of 'fromList'. It is a good+-- consumer for list fusion. Worst-case behavior is somewhat worse+-- than worst-case for 'fromListL'. The 'fromList' function is+-- currently just an alias for 'fromListR'.+fromListR :: [(Text,a)] -> Trie a+{-# INLINE [0] fromListR #-}+fromListR = fromList -- == foldr (uncurry insert) empty+++-- TODO: compare performance against a fromListL variant, adjusting the sort appropriately+--+-- | This variant sorts the list before folding over it. This adds+-- /O(n log n)/ overhead and requires the whole list be in memory+-- at once, but it ensures that the list is in best-case order. The+-- benefits generally outweigh the costs.+fromListS :: [(Text,a)] -> Trie a+{-# INLINE fromListS #-}+fromListS = fromListR . sortBy (comparing fst)++-- | A variant of 'fromListR' that takes a function for combining+-- values on conflict. The first argument to the combining function+-- is the ``new'' value from the initial portion of the list; the+-- second argument is the value that has been accumulated into the+-- trie from the tail of the list (just like the first argument to+-- 'foldr'). Thus, @fromList = fromListWith const@.+fromListWith :: (a -> a -> a) -> [(Text,a)] -> Trie a+{-# INLINE fromListWith #-}+fromListWith f = foldr (uncurry $ alterBy g) empty+ where+ g _ v Nothing = Just v+ g _ v (Just w) = Just (f v w)++-- | A variant of 'fromListWith' which applies the combining+-- function strictly. This function is a good consumer for list+-- fusion. If you need list fusion and are running into stack+-- overflow problems with 'fromListWith', then this function may+-- solve the problem.+fromListWith' :: (a -> a -> a) -> [(Text,a)] -> Trie a+{-# INLINE fromListWith' #-}+fromListWith' f = foldr (uncurry $ alterBy g') empty+ where+ g' _ v Nothing = Just v+ g' _ v (Just w) = Just $! f v w++-- | A left-fold variant of 'fromListWith'. Note that the arguments+-- to the combining function are swapped: the first is the value+-- in the trie which has been accumulated from the initial part of+-- the list; the second argument is the ``new'' value from the+-- remaining tail of the list (just like the first argument to+-- 'foldl'). Thus, @fromListL = fromListWithL const@.+fromListWithL :: (a -> a -> a) -> [(Text,a)] -> Trie a+{-# INLINE fromListWithL #-}+fromListWithL f = foldl' (flip . uncurry $ alterBy flipG) empty+ where+ flipG _ v Nothing = Just v+ flipG _ v (Just w) = Just (f w v)+++-- | A variant of 'fromListWithL' which applies the combining+-- function strictly.+fromListWithL' :: (a -> a -> a) -> [(Text,a)] -> Trie a+{-# INLINE fromListWithL' #-}+fromListWithL' f = foldl' (flip . uncurry $ alterBy flipG') empty+ where+ flipG' _ v Nothing = Just v+ flipG' _ v (Just w) = Just $! f w v+++----------------------------------------------------------------+-- | Lookup a key, returning a default value if it's not found.+lookupWithDefault :: a -> Text -> Trie a -> a+lookupWithDefault def = lookupBy_ f def (const def)+ where+ f Nothing _ = def+ f (Just v) _ = v+++----------------------------------------------------------------++-- | Insert a new key, retaining old value on conflict.+insertIfAbsent :: Text -> a -> Trie a -> Trie a+insertIfAbsent =+ alterBy $ \_ x mv ->+ case mv of+ Nothing -> Just x+ Just _ -> mv+++-- | Insert a new key, with a function to resolve conflicts.+insertWith :: (a -> a -> a) -> Text -> a -> Trie a -> Trie a+insertWith f =+ alterBy $ \_ x mv ->+ case mv of+ Nothing -> Just x+ Just v -> Just (f x v)+++-- | A variant of 'insertWith' which applies the combining function+-- strictly.+insertWith' :: (a -> a -> a) -> Text -> a -> Trie a -> Trie a+insertWith' f =+ alterBy $ \_ x mv ->+ case mv of+ Nothing -> Just x+ Just v -> Just $! f x v+++-- | A variant of 'insertWith' which also provides the key to the+-- combining function.+insertWithKey :: (Text -> a -> a -> a) -> Text -> a -> Trie a -> Trie a+insertWithKey f =+ alterBy $ \k x mv ->+ case mv of+ Nothing -> Just x+ Just v -> Just (f k x v)+++-- | A variant of 'insertWithKey' which applies the combining+-- function strictly.+insertWithKey' :: (Text -> a -> a -> a) -> Text -> a -> Trie a -> Trie a+insertWithKey' f =+ alterBy $ \k x mv ->+ case mv of+ Nothing -> Just x+ Just v -> Just $! f k x v+++----------------------------------------------------------------+-- | Apply a function to change the value at a key.+adjustWithKey :: (Text -> a -> a) -> Text -> Trie a -> Trie a+adjustWithKey f q =+ adjustBy (\k _ -> f k) q (impossible "Convenience.adjustWithKey")+++-- | Apply a function to the value at a key, possibly removing it.+update :: (a -> Maybe a) -> Text -> Trie a -> Trie a+update f q =+ alterBy (\_ _ mx -> mx >>= f) q (impossible "Convenience.update")+++-- | A variant of 'update' which also provides the key to the function.+updateWithKey :: (Text -> a -> Maybe a) -> Text -> Trie a -> Trie a+updateWithKey f q =+ alterBy (\k _ mx -> mx >>= f k) q (impossible "Convenience.updateWithKey")+++----------------------------------------------------------------++-- | Combine two tries, a la symmetric difference. If they define+-- the same key, it is removed; otherwise it is retained with the+-- value it has in whichever trie.+disunion :: Trie a -> Trie a -> Trie a+disunion = mergeBy (\_ _ -> Nothing)+++-- | Combine two tries, using a function to resolve conflicts.+unionWith :: (a -> a -> a) -> Trie a -> Trie a -> Trie a+unionWith f = mergeBy (\x y -> Just (f x y))+++-- | A variant of 'unionWith' which applies the combining function+-- strictly.+unionWith' :: (a -> a -> a) -> Trie a -> Trie a -> Trie a+unionWith' f = mergeBy (\x y -> Just $! f x y)++----------------------------------------------------------------+----------------------------------------------------------- fin.+
+ src/Data/Trie/Text/Internal.hs view
@@ -0,0 +1,1065 @@+-- To make GHC stop warning about the Prelude+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}+{-# LANGUAGE NoImplicitPrelude #-}++-- For list fusion on toListBy, and guarding `base` versions.+{-# LANGUAGE CPP #-}+#ifdef __GLASGOW_HASKELL__+{-# LANGUAGE StandaloneDeriving, DeriveGeneric #-}+#endif++------------------------------------------------------------+-- ~ 2019.04.03+-- |+-- Module : Data.Trie.Text.Internal+-- Copyright : Copyright (c) 2008--2015 wren gayle romano, 2019 michael j. klein+-- License : BSD3+-- Maintainer : lambdamichael@gmail.com+-- Stability : experimental+--+-- 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 potentially fragile)+-- access to the abstract type.+------------------------------------------------------------++module Data.Trie.Text.Internal+ (+ -- * Data types+ Trie(), showTrie++ -- * Functions for 'Text'+ , 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+ , contextualMap+ , contextualMap'+ , contextualFilterMap+ , contextualMapBy++ -- * Priority-queue functions+ , minAssoc, maxAssoc+ , updateMinViewBy, updateMaxViewBy+ ) where++import Prelude hiding (null, lookup)++import Data.Trie.Text.BitTwiddle+import Data.Trie.TextInternal++import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Lazy as L+import Data.Text.Internal.Word16 (head16, length16)++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)+import Control.Applicative (Applicative(..), (<$>))+import Data.Foldable (Foldable(foldMap))+import Data.Traversable (Traversable(traverse))++#ifdef __GLASGOW_HASKELL__+import GHC.Exts (build)+import GHC.Generics (Generic, Generic1)+#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+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) -- Invariant: Must be Branch+data Arc a = Arc ByteString (Node a) -- Invariant: never empty string+data ArcSet a = None+ | One {KeyElem} (Arc a)+ | Branch {Prefix} {Mask} (ArcSet a) (ArcSet a)+data Trie a = Empty+ | Start ByteString (Node a) -- Maybe empty string [1]++[1] If we maintain the invariants on how Nodes recurse, then we+can't simply have Start(Node a) because we may have a shared prefix+where the prefix itself is not Accept'ed.+++-- Squash Arc into One:+-- (pure good)+data Node a = Accept a (ArcSet a)+ | Reject (Branch a)+data ArcSet a = None+ | Arc ByteString (Node a)+ | Branch {Prefix} {Mask} (ArcSet a) (ArcSet a)+data Trie a = Empty+ | Start ByteString (Node a)+++-- Squash Node together:+-- (most likely good)+data Node a = Node (Maybe a) (ArcSet a)+data ArcSet a = None+ | Arc ByteString (Node a)+ | Branch {Prefix} {Mask} (ArcSet a) (ArcSet a)+data Trie a = Empty+ | Start ByteString (Node a)+++-- Squash Empty/None and Arc/Start together:+-- (This complicates invariants about non-empty strings and Node's+-- recursion, but those can be circumvented by using smart+-- constructors.)+data Node a = Node (Maybe a) (ArcSet a)+data Trie a = Empty+ | Arc ByteString (Node a)+ | Branch {Prefix} {Mask} (Trie a) (Trie a)+++-- Squash Node into Arc:+-- (By this point, pure good)+-- Unseen invariants:+-- * ByteString non-empty, unless Arc is absolute root of tree+-- * If (Maybe a) is Nothing, then (Trie a) is Branch+-- * With views, we could re-expand Arc into accepting and+-- nonaccepting variants+--+-- [2] Maybe we shouldn't unpack the ByteString. We could specialize+-- or inline the breakMaximalPrefix function to prevent constructing+-- a new ByteString from the parts...+-}+-- | 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 = Empty+ | Arc {-# UNPACK #-} !Text+ !(Maybe a)+ !(Trie a)+ | Branch {-# UNPACK #-} !Prefix+ {-# UNPACK #-} !Mask+ !(Trie a)+ !(Trie a)+ deriving Eq++#ifdef __GLASGOW_HASKELL__+deriving instance Generic1 Trie+deriving instance Generic a => Generic (Trie a)+#endif+++-- 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+-- are printed as (ASCII) Strings, but that's not our fault. (Also+-- 'fromList' is in "Data.Trie" instead of here.)+instance (Show a) => Show (Trie a) where+ showsPrec p t = showParen (p > 10)+ $ ("Data.Trie.fromList "++) . shows (toListBy (,) t)++-- | Visualization fuction for debugging.+showTrie :: (Show a) => Trie a -> String+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 . ("-+" ++)+ ss' = ss . (tail (spaces s') ++)+ in s' .+ shows' (ss' . ("|" ++)) l .+ ss' . ("|\n" ++) . ss' . ("`" ++) . shows' (ss' . (" " ++)) r+ shows' ss (Arc k mv t') =+ let s' =+ ("--" ++) .+ shows k .+ maybe id (\v -> ("-(" ++) . shows v . (")" ++)) mv . ("--" ++)+ in s' . shows' (ss . (spaces s' ++)) t'+++-- TODO?? a Read instance? hrm... should I?++-- TODO: consider an instance more like the new one for Data.Map. Better?+instance (Binary a) => Binary (Trie a) where+ 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+ 1 -> liftM3 Arc get get get+ _ -> liftM4 Branch get get get get+++{-----------------------------------------------------------+-- Trie instances: Abstract Nonsense+-----------------------------------------------------------}++instance Functor Trie where+ fmap f = go+ where+ go Empty = Empty+ go (Arc k Nothing t) = Arc k Nothing (go t)+ go (Arc k (Just v) t) = Arc k (Just (f v)) (go t)+ go (Branch p m l r) = Branch p m (go l) (go r)++instance Foldable Trie where+ foldMap f = go+ where+ go Empty = mempty+ go (Arc _ Nothing t) = go t+ go (Arc _ (Just v) t) = f v `mappend` go t+ go (Branch _ _ l r) = go l `mappend` go r++-- TODO: newtype Keys = K Trie ; instance Foldable Keys+-- TODO: newtype Assoc = A Trie ; instance Foldable Assoc++instance Traversable Trie where+ traverse f = go+ where+ go Empty = pure Empty+ go (Arc k Nothing t) = Arc k Nothing <$> go t+ go (Arc k (Just v) t) = Arc k . Just <$> f v <*> go t+ go (Branch p m l r) = Branch p m <$> go l <*> go r++instance Applicative Trie where+ pure = return+ (<*>) = ap++-- 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)+instance Monad Trie where+ return = singleton T.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)+ (>>=) (Arc k (Just v) t) f = arc k Nothing (f v `unionL` (t >>= f))+ where+ 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+ mappend = mergeBy $ \x y -> Just (x `mappend` y)++-- 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 functions+-----------------------------------------------------------}++-- | Apply a function to all values, potentially removing them.+filterMap :: (a -> Maybe b) -> Trie a -> Trie b+filterMap f = go+ where+ go Empty = empty+ go (Arc k Nothing t) = arc k Nothing (go t)+ go (Arc k (Just v) t) = arc k (f v) (go t)+ go (Branch p m l r) = branch p m (go l) (go r)+++-- | Generic version of 'fmap'. This function is notably more+-- expensive than 'fmap' or 'filterMap' because we have to reconstruct+-- the keys.+mapBy :: (Text -> a -> Maybe b) -> Trie a -> Trie b+mapBy f = go T.empty+ where+ go _ Empty = empty+ go q (Arc k Nothing t) = arc k Nothing (go q' t) where q' = T.append q k+ go q (Arc k (Just v) t) = arc k (f q' v) (go q' t) where q' = T.append q k+ go q (Branch p m l r) = branch p m (go q l) (go q r)++-- | A variant of 'fmap' which provides access to the subtrie rooted+-- at each value.+contextualMap :: (a -> Trie a -> b) -> Trie a -> Trie b+contextualMap f = go+ where+ go Empty = Empty+ go (Arc k Nothing t) = Arc k Nothing (go t)+ go (Arc k (Just v) t) = Arc k (Just (f v t)) (go t)+ go (Branch p m l r) = Branch p m (go l) (go r)+++-- | A variant of 'contextualMap' which applies the function strictly.+contextualMap' :: (a -> Trie a -> b) -> Trie a -> Trie b+contextualMap' f = go+ where+ go Empty = Empty+ go (Arc k Nothing t) = Arc k Nothing (go t)+ go (Arc k (Just v) t) = Arc k (Just $! f v t) (go t)+ go (Branch p m l r) = Branch p m (go l) (go r)+++-- | A contextual variant of 'filterMap'.+contextualFilterMap :: (a -> Trie a -> Maybe b) -> Trie a -> Trie b+contextualFilterMap f = go+ where+ go Empty = empty+ go (Arc k Nothing t) = arc k Nothing (go t)+ go (Arc k (Just v) t) = arc k (f v t) (go t)+ go (Branch p m l r) = branch p m (go l) (go r)++-- | A contextual variant of 'mapBy'. Again note that this is+-- expensive since we must reconstruct the keys.+contextualMapBy :: (Text -> a -> Trie a -> Maybe b) -> Trie a -> Trie b+contextualMapBy f = go T.empty+ where+ go _ Empty = empty+ go q (Arc k Nothing t) = arc k Nothing (go (T.append q k) t)+ go q (Arc k (Just v) t) = let q' = T.append q k+ in arc k (f q' v t) (go q' t)+ 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+{-# INLINE branch #-}+branch _ _ Empty r = r+branch _ _ l Empty = l+branch p m l r = Branch p m l r+++-- | Smart constructor to prune @Arc@s that lead nowhere.+-- N.B if mv=Just then doesn't check whether t=epsilon. It's up to callers to ensure that invariant isn't broken.+arc :: Text -> Maybe a -> Trie a -> Trie a+{-# INLINE arc #-}+arc k mv@(Just _) t = Arc k mv t+arc _ Nothing Empty = Empty+arc k Nothing t@(Branch _ _ _ _)+ | T.null k = t+ | otherwise = Arc k Nothing t+arc k Nothing (Arc k' mv' t') = Arc (T.append k k') mv' t'++++-- | Smart constructor to join two tries into a @Branch@ with maximal+-- prefix sharing. Requires knowing the prefixes, but can combine+-- either @Branch@es or @Arc@s.+--+-- N.B. /do not/ use if prefixes could match entirely!+branchMerge :: Prefix -> Trie a -> Prefix -> Trie a -> Trie a+{-# INLINE branchMerge #-}+branchMerge _ Empty _ t2 = t2+branchMerge _ t1 _ Empty = t1+branchMerge p1 t1 p2 t2+ | zero p1 m = Branch p m t1 t2+ | otherwise = Branch p m t2 t1+ where+ m = branchMask p1 p2+ p = mask p1 m++-- It would be better if Arc 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 :(+getPrefix :: Trie a -> Prefix+{-# INLINE getPrefix #-}+getPrefix (Branch p _ _ _) = p+getPrefix (Arc k _ _)+ | T.null k = 0 -- for lack of a better value+ | otherwise = head16 k+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 -> Text -> TextElem+{-# NOINLINE errorLogHead #-}+errorLogHead fn q+ | T.null q = error $ "Data.Trie.Internal." ++ fn ++": found null subquery"+ | otherwise = head16 q+++------------------------------------------------------------+------------------------------------------------------------++{-----------------------------------------------------------+-- Basic functions+-----------------------------------------------------------}++-- | /O(1)/, Construct the empty trie.+empty :: Trie a+{-# INLINE [0] empty #-}+empty = Empty+++-- | /O(1)/, Is the trie empty?+null :: Trie a -> Bool+{-# INLINE [1] null #-}+null Empty = True+null _ = False+++-- | /O(1)/, Construct a singleton trie.+singleton :: Text -> a -> Trie a+{-# INLINE [0] singleton #-}+singleton k v = Arc k (Just v) Empty+-- For singletons, don't need to verify invariant on arc length >0++-- | /O(n)/, Get count of elements in trie.+size :: Trie a -> Int+{-# INLINE size #-}+size t = size' t id 0+++-- | /O(n)/, CPS accumulator helper for calculating 'size'.+size' :: Trie a -> (Int -> Int) -> Int -> Int+size' Empty f n = f n+size' (Branch _ _ l r) f n = size' l (size' r f) n+size' (Arc _ Nothing t) f n = size' t f n+size' (Arc _ (Just _) t) f n = size' t f $! n + 1++++{-----------------------------------------------------------+-- 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?)+-- N.B. If our manual definition of foldr/foldl (using function+-- application) is so much faster than the default Endo definition+-- (using function composition), then we should make this use+-- application instead too.+--+-- TODO: the @q@ accumulator should be lazy ByteString and only+-- forced by @fcons@. It's already non-strict, but we should ensure+-- O(n) not O(n^2) when it's forced.+--+-- BUG: not safe for deep strict @fcons@, only for WHNF-strict like (:)+-- Where to put the strictness to amortize it?+--+-- | Convert a trie into a list (in key-sorted order) using a+-- function, folding the list as we go.+foldrWithKey :: (L.Text -> a -> b -> b) -> b -> Trie a -> b+foldrWithKey fcons nil = \t -> go L.empty t nil+ where+ go _ Empty = id+ go q (Branch _ _ l r) = go q l . go q r+ go q (Arc k mv t) =+ case mv of+ Nothing -> rest+ Just v -> fcons k' v . rest+ where+ rest = go k' t+ k' = L.append q (L.fromStrict k)++++-- 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.+toListBy :: (L.Text -> 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 f t = build (toListByFB f 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 :: (L.Text -> a -> b) -> Trie a -> (b -> c -> c) -> c -> c+{-# INLINE [0] toListByFB #-}+toListByFB f t cons nil = foldrWithKey ((cons .) . f) nil t+#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 @lookupBy@ in "Data.Trie".+lookupBy_ :: (Maybe a -> Trie a -> b) -> b -> (Trie a -> b)+ -> Text -> Trie a -> b+lookupBy_ f z a = lookupBy_'+ where+ -- | Deal with epsilon query (when there is no epsilon value)+ lookupBy_' q t@(Branch _ _ _ _) | T.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 $ T.null k', T.null q') of+ (True, True) -> a (Arc k' mv t)+ (True, False) -> z+ (False, True) -> f mv t+ (False, False) -> go q' t++ go q t_@(Branch _ _ _ _) = findArc t_+ where+ qh = errorLogHead "lookupBy_" q++ -- | /O(min(m,W))/, where /m/ is number of @Arc@s in this+ -- branching, and /W/ is the word size of the Prefix,Mask type.+ findArc (Branch p m l r)+ | nomatch qh p m = z+ | zero qh m = findArc l+ | otherwise = findArc r+ findArc t@(Arc _ _ _) = go q t+ findArc Empty = z+++++-- 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 :: Text -> Trie a -> Trie a+{-# INLINE submap #-}+submap q = lookupBy_ (arc q) empty (arc q Nothing) q+{- -- Disable superfluous error checking.+ -- @submap'@ would replace the first argument to @lookupBy_@+ where+ submap' Nothing Empty = errorEmptyAfterNothing "submap"+ submap' Nothing (Arc _ _ _) = errorArcAfterNothing "submap"+ submap' mx t = Arc q mx t++errorInvariantBroken :: String -> String -> a+{-# NOINLINE errorInvariantBroken #-}+errorInvariantBroken s e = error (s ++ ": Invariant was broken" ++ e')+ where+ e' = if Prelude.null e then e else ", found: " ++ e++errorArcAfterNothing :: String -> a+{-# NOINLINE errorArcAfterNothing #-}+errorArcAfterNothing s = errorInvariantBroken s "Arc after Nothing"++errorEmptyAfterNothing :: String -> a+{-# NOINLINE errorEmptyAfterNothing #-}+errorEmptyAfterNothing s = errorInvariantBroken s "Empty after Nothing"+-- -}+++-- TODO: would it be worth it to have a variant like 'lookupBy_' which takes the three continuations?++-- | 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 @match@ in "Data.Trie".+match_ :: Trie a -> Text -> Maybe (Int, a)+match_ = flip start+ where+ -- | Deal with epsilon query (when there is no epsilon value)+ start q (Branch _ _ _ _) | T.null q = Nothing+ start q t = goNothing 0 q t++ -- | The initial recursion+ goNothing _ _ Empty = Nothing++ goNothing n q (Arc k mv t) =+ case T.commonPrefixes k q of+ Nothing ->+ if T.null k+ then+ if T.null q+ then (,) n <$> mv+ else+ case mv of+ Nothing -> goNothing n q t+ Just v -> goJust n v n q t+ else Nothing+ Just (p,k',q') ->+ let n' = n + length16 p+ in n' `seq`+ if T.null k'+ then+ if T.null q'+ then (,) n' <$> mv+ else+ case mv of+ Nothing -> goNothing n' q' t+ Just v -> goJust n' v n' q' t+ else Nothing++ goNothing n q t_@(Branch _ _ _ _) = findArc t_+ where+ qh = errorLogHead "match_" q++ -- | /O(min(m,W))/, where /m/ is number of @Arc@s in this+ -- branching, and /W/ is the word size of the Prefix,Mask type.+ findArc (Branch p m l r)+ | nomatch qh p m = Nothing+ | zero qh m = findArc l+ | otherwise = findArc r+ findArc t@(Arc _ _ _) = goNothing n q t+ findArc Empty = Nothing++ -- | The main recursion+ goJust n0 v0 _ _ Empty = Just (n0,v0)++ goJust n0 v0 n q (Arc k mv t) =+ case T.commonPrefixes k q of+ Nothing ->+ if T.null k+ then+ if T.null q+ then+ case mv of+ Nothing -> Just (n0,v0)+ Just v -> Just (n,v)+ else+ case mv of+ Nothing -> goJust n0 v0 n q t+ Just v -> goJust n v n q t+ else Just (n0,v0)+ Just (p,k',q') ->+ let n' = n + length16 p+ in n' `seq`+ if T.null k'+ then+ if T.null q'+ then+ case mv of+ Nothing -> Just (n0,v0)+ Just v -> Just (n',v)+ else+ case mv of+ Nothing -> goJust n0 v0 n' q' t+ Just v -> goJust n' v n' q' t+ else Just (n0,v0)++ goJust n0 v0 n q t_@(Branch _ _ _ _) = findArc t_+ where+ qh = errorLogHead "match_" q++ -- | /O(min(m,W))/, where /m/ is number of @Arc@s in this+ -- branching, and /W/ is the word size of the Prefix,Mask type.+ findArc (Branch p m l r)+ | nomatch qh p m = Just (n0,v0)+ | zero qh m = findArc l+ | otherwise = findArc r+ findArc t@(Arc _ _ _) = goJust n0 v0 n q t+ findArc Empty = Just (n0,v0)++++-- | Given a query, find all prefixes with associated values in the+-- trie, returning their lengths and values. This function is a+-- good producer for list fusion.+--+-- This function may not have the most useful return type. For a+-- version that returns the prefix itself as well as the remaining+-- string, see @matches@ in "Data.Trie".+matches_ :: Trie a -> Text -> [(Int,a)]+matches_ t q =+#if !defined(__GLASGOW_HASKELL__)+ matchFB_ t q (((:) .) . (,)) []+#else+ build (\cons nil -> matchFB_ t q ((cons .) . (,)) nil)+{-# INLINE matches_ #-}+#endif++matchFB_ :: Trie a -> Text -> (Int -> a -> r -> r) -> r -> r+matchFB_ = \t q cons nil -> matchFB_' cons q t nil+ where+ matchFB_' cons = start+ where+ -- | Deal with epsilon query (when there is no epsilon value)+ start q (Branch _ _ _ _) | T.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 -- foobar+ n' = n + length16 p+ in n' `seq`+ if T.null k'+ then+ case mv of { Nothing -> id; Just v -> cons n' v}+ .+ if T.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)+ | nomatch qh p m = id+ | zero qh m = findArc l+ | otherwise = findArc r+ findArc t@(Arc _ _ _) = go n q t+ 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+-- 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 :: (Text -> a -> Maybe a -> Maybe a)+ -> Text -> a -> Trie a -> Trie a+alterBy f = alterBy_ (\k v mv t -> (f k v mv, t))+-- 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.++++-- | A variant of 'alterBy' which also allows modifying the sub-trie.+alterBy_ :: (Text -> a -> Maybe a -> Trie a -> (Maybe a, Trie a))+ -> Text -> a -> Trie a -> Trie a+alterBy_ f_ q_ x_+ | T.null q_ = alterEpsilon+ | otherwise = go q_+ 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) | T.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 $ T.null k', T.null q') of+ (True, True) -> -- add node to middle of arc+ uncurry (arc p) (f Nothing (Arc k' mv t))+ (True, False) ->+ case nothing q' of+ Empty -> t_ -- Nothing to add, reuse old arc+ l -> arc' (branchMerge (getPrefix l) l (getPrefix r) r)+ where+ r = Arc k' mv t++ -- inlined version of 'arc'+ arc' | T.null p = id+ | otherwise = Arc p Nothing++ (False, True) -> uncurry (arc k) (f mv t)+ (False, False) -> arc k mv (go q' t)+++-- | Alter the value associated with a given key. If the key is not+-- present, then the trie is returned unaltered. See 'alterBy' if+-- you are interested in inserting new keys or deleting old keys.+-- Because this function does not need to worry about changing the+-- trie structure, it is somewhat faster than 'alterBy'.+adjustBy :: (Text -> a -> a -> a)+ -> Text -> a -> Trie a -> Trie a+adjustBy f_ q_ x_+ | T.null q_ = adjustEpsilon+ | otherwise = go q_+ where+ f = f_ q_ x_++ adjustEpsilon (Arc k (Just v) t) | T.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 $ T.null k', T.null q') of+ (True, True) -> t_ -- don't break arc inline+ (True, False) -> t_ -- don't break arc branching+ (False, True) -> Arc k (liftM f mv) t+ (False, False) -> Arc k mv (go q' t)+++{-----------------------------------------------------------+-- Trie-combining functions+-----------------------------------------------------------}++-- 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"]+--+-- | Combine 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 f = mergeBy'+ where+ -- | Deals with epsilon entries, before recursing into @go@+ mergeBy'+ t0_@(Arc k0 mv0 t0)+ t1_@(Arc k1 mv1 t1)+ | T.null k0 && T.null k1 = arc k0 (mergeMaybe f mv0 mv1) (go t0 t1)+ | T.null k0 = arc k0 mv0 (go t0 t1_)+ | T.null k1 = arc k1 mv1 (go t1 t0_)+ mergeBy'+ (Arc k0 mv0@(Just _) t0)+ t1_@(Branch _ _ _ _)+ | T.null k0 = arc k0 mv0 (go t0 t1_)+ mergeBy'+ t0_@(Branch _ _ _ _)+ (Arc k1 mv1@(Just _) t1)+ | T.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)+ | shorter m0 m1 = union0+ | shorter m1 m0 = union1+ | p0 == p1 = branch p0 m0 (go l0 l1) (go r0 r1)+ | otherwise = branchMerge p0 t0 p1 t1+ where+ 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_+ where+ p0 = getPrefix t0_+ p1 = getPrefix t1_+ m' = branchMask p0 p1+ p' = mask p0 m'++ go' (Arc k0 mv0 t0)+ (Arc k1 mv1 t1)+ | m' == 0 =+ let (pre,k0',k1') = breakMaximalPrefix k0 k1 in+ if T.null pre+ then error "mergeBy: no mask, but no prefix string"+ else let {-# INLINE arcMerge #-}+ arcMerge mv' t1' t2' = arc pre mv' (go t1' t2')+ in case (T.null k0', T.null k1') of+ (True, True) -> arcMerge (mergeMaybe f mv0 mv1) t0 t1+ (True, False) -> arcMerge mv0 t0 (Arc k1' mv1 t1)+ (False,True) -> arcMerge mv1 (Arc k0' mv0 t0) t1+ (False,False) -> arcMerge Nothing (Arc k0' mv0 t0)+ (Arc k1' mv1 t1)+ go' (Arc _ _ _)+ (Branch _p1 m1 l r)+ | nomatch p0 p1 m1 = branchMerge p1 t1_ p0 t0_+ | zero p0 m1 = branch p1 m1 (go t0_ l) r+ | otherwise = branch p1 m1 l (go t0_ r)+ go' (Branch _p0 m0 l r)+ (Arc _ _ _)+ | 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_++++mergeMaybe :: (a -> a -> Maybe a) -> Maybe a -> Maybe a -> Maybe a+{-# INLINE mergeMaybe #-}+mergeMaybe _ Nothing Nothing = Nothing+mergeMaybe _ Nothing mv1@(Just _) = mv1+mergeMaybe _ mv0@(Just _) Nothing = mv0+mergeMaybe f (Just v0) (Just v1) = f v0 v1+++{-----------------------------------------------------------+-- Priority-queue functions+-----------------------------------------------------------}++minAssoc :: Trie a -> Maybe (Text, a)+minAssoc = go T.empty+ where+ go _ Empty = Nothing+ go q (Arc k (Just v) _) = Just (T.append q k,v)+ go q (Arc k Nothing t) = go (T.append q k) t+ go q (Branch _ _ l _) = go q l+++maxAssoc :: Trie a -> Maybe (Text, a)+maxAssoc = go T.empty+ where+ go _ Empty = Nothing+ go q (Arc k (Just v) Empty) = Just (T.append q k,v)+ go q (Arc k _ t) = go (T.append q k) t+ go q (Branch _ _ _ r) = go q r+++mapView :: (Trie a -> Trie a)+ -> Maybe (Text, a, Trie a) -> Maybe (Text, a, Trie a)+mapView _ Nothing = Nothing+mapView f (Just (k,v,t)) = Just (k,v, f t)+++updateMinViewBy :: (Text -> a -> Maybe a)+ -> Trie a -> Maybe (Text, a, Trie a)+updateMinViewBy f = go T.empty+ where+ go _ Empty = Nothing+ go q (Arc k (Just v) t) = let q' = T.append q k+ in Just (q',v, arc k (f q' v) t)+ go q (Arc k Nothing t) = mapView (arc k Nothing) (go (T.append q k) t)+ go q (Branch p m l r) = mapView (\l' -> branch p m l' r) (go q l)++updateMaxViewBy :: (Text -> a -> Maybe a)+ -> Trie a -> Maybe (Text, a, Trie a)+updateMaxViewBy f = go T.empty+ where+ go _ Empty = Nothing+ go q (Arc k (Just v) Empty) = let q' = T.append q k+ in Just (q',v, arc k (f q' v) Empty)+ go q (Arc k mv t) = mapView (arc k mv) (go (T.append q k) t)+ go q (Branch p m l r) = mapView (branch p m l) (go q r)++------------------------------------------------------------+------------------------------------------------------- fin.+
+ src/Data/Trie/TextInternal.hs view
@@ -0,0 +1,40 @@+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}+------------------------------------------------------------+-- ~ 2019.04.03+-- |+-- Module : Data.Trie.TextInternal+-- Copyright : Copyright (c) 2008--2015 wren gayle romano, 2019 michael j. klein+-- License : BSD3+-- Maintainer : lambdamichael@gmail.com+-- Stability : experimental+--+-- Helper functions on 'ByteString's for "Data.Trie.Internal".+------------------------------------------------------------++module Data.Trie.TextInternal+ ( Text, TextElem+ , breakMaximalPrefix+ ) where++import Data.Text (Text)+import qualified Data.Text as T++import Data.Word++------------------------------------------------------------+-- | Associated type of 'Text'+type TextElem = Word16++-- | `T.commonPrefixes` unless `Nothing`,+-- in which case @(`T.empty`, x, y)@ is returned+breakMaximalPrefix+ :: Text+ -> Text+ -> (Text, Text, Text)+{-# INLINE [0] breakMaximalPrefix #-}+breakMaximalPrefix x y =+ maybe (T.empty, x, y) id $+ T.commonPrefixes x y++------------------------------------------------------------+------------------------------------------------------- fin.
+ test/Data/Trie/Text/Test.hs view
@@ -0,0 +1,478 @@+{-# OPTIONS_GHC -Wall -fwarn-tabs -fno-warn-orphans #-}+{-# LANGUAGE CPP+ , MultiParamTypeClasses+ , FlexibleInstances+ , FlexibleContexts+ , TypeSynonymInstances+ #-}+{-# LANGUAGE StandaloneDeriving, DeriveGeneric #-}++----------------------------------------------------------------+-- ~ 2019.04.03+-- |+-- Module : Data.Trie.Test+-- Copyright : Copyright (c) 2008--2015 wren gayle romano, 2019 michael j. klein+-- License : BSD3+-- Maintainer : lambdamichael@gmail.com+-- Stability : experimental+--+-- Testing 'Trie's.+----------------------------------------------------------------+module Data.Trie.Text.Test (test) where++import qualified Data.Trie.Text as Tr+import qualified Data.Trie.Text.Convenience as TC+import qualified Data.Text as T+import qualified Data.Text.Lazy as L+import Data.Text.Internal.Word16 (toList16, length16)++import qualified Test.HUnit as HU+import qualified Test.QuickCheck as QC+import qualified Test.QuickCheck.Arbitrary as QCA+import qualified Test.SmallCheck as SC+import qualified Test.SmallCheck.Series as SCS+-- import qualified Test.LazySmallCheck as LSC+-- import qualified Test.SparseCheck as PC++import Data.Function+import Data.List (nubBy, sortOn)+import GHC.Generics+import System.IO.Silently (capture)+----------------------------------------------------------------+----------------------------------------------------------------++----------------------------------------------------------------+deriving instance Generic Int++test :: IO ()+test = do+ putStrLn ""+ putStrLn (replicate 80 '~')++ putStrLn "hunit:"+ _ <- HU.runTestTT $ HU.TestList+ [ test_Union+ , test_Submap+ , test_Insert+ , test_Delete+ ]+ putStrLn ""++ putStrLn "quickcheck @ Int (Text):"+ putStrLn "prop_insert"+ checkQuick 500 (prop_insert :: Str -> Int -> Tr.Trie Int -> Bool)+ putStrLn "prop_singleton"+ checkQuick 5000 (prop_singleton :: Str -> Int -> Bool)+ putStrLn "prop_size_insert"+ checkQuick 500 (prop_size_insert :: Str -> Int -> Tr.Trie Int -> QC.Property)+ putStrLn "prop_size_delete"+ checkQuick 500 (prop_size_delete :: Str -> Int -> Tr.Trie Int -> QC.Property)+ putStrLn "prop_insert_delete"+ checkQuick 500 (prop_insert_delete :: Str -> Int -> Tr.Trie Int -> QC.Property)+ putStrLn "prop_delete_lookup"+ checkQuick 500 (prop_delete_lookup :: Str -> Tr.Trie Int -> QC.Property)+ putStrLn "prop_submap1"+ checkQuick 500 (prop_submap1 :: Str -> Tr.Trie Int -> Bool)+ putStrLn "prop_submap2"+ checkQuick 500 (prop_submap2 :: Str -> Tr.Trie Int -> Bool)+ putStrLn "prop_submap3"+ checkQuick 500 (prop_submap3 :: Str -> Tr.Trie Int -> Bool)++ putStrLn "prop_toList"+ checkQuick 500 (prop_toList :: Tr.Trie Int -> QC.Property)+ putStrLn "prop_fromList_takes_first"+ checkQuick 500 (prop_fromList_takes_first :: [(Str, Int)] -> QC.Property)+ putStrLn "prop_fromListR_takes_first"+ checkQuick 500 (prop_fromListR_takes_first :: [(Str, Int)] -> QC.Property)+ putStrLn "prop_fromListL_takes_first"+ checkQuick 500 (prop_fromListL_takes_first :: [(Str, Int)] -> QC.Property)+ putStrLn "prop_fromListS_takes_first"+ checkQuick 500 (prop_fromListS_takes_first :: [(Str, Int)] -> QC.Property)+ putStrLn "prop_fromListWithConst_takes_first"+ checkQuick 500 (prop_fromListWithConst_takes_first :: [(Str, Int)] -> QC.Property)+ putStrLn "prop_fromListWithLConst_takes_first"+ checkQuick 500 (prop_fromListWithLConst_takes_first :: [(Str, Int)] -> QC.Property)+ putStrLn ""++ putStrLn "prop_length16_is_length_toList16"+ checkQuick 500 (prop_length16_is_length_toList16 :: Str -> QC.Property)+ putStrLn ""++ putStrLn "smallcheck @ () (Text):" -- Beware the exponential!+ putStrLn "prop_insert"+ checkSmall 3 (prop_insert :: Str -> () -> Tr.Trie () -> Bool)+ putStrLn "prop_singleton"+ checkSmall 7 (prop_singleton :: Str -> () -> Bool)+ putStrLn "prop_size_insert"+ checkSmall 3 (prop_size_insert :: Str -> () -> Tr.Trie () -> SC.Property IO)+ putStrLn "prop_size_delete"+ checkSmall 3 (prop_size_delete :: Str -> () -> Tr.Trie () -> SC.Property IO)+ putStrLn "prop_insert_delete"+ checkSmall 3 (prop_insert_delete :: Str -> () -> Tr.Trie () -> SC.Property IO)+ putStrLn "prop_delete_lookup"+ checkSmall 3 (prop_delete_lookup :: Str -> Tr.Trie () -> SC.Property IO)+ putStrLn "prop_submap1"+ checkSmall 3 (prop_submap1 :: Str -> Tr.Trie () -> Bool)+ putStrLn "prop_submap2"+ checkSmall 3 (prop_submap2 :: Str -> Tr.Trie () -> Bool)+ putStrLn ""++ where+#ifdef __USE_QUICKCHECK_1__+ checkQuick n =+ QC.check (QC.defaultConfig+ { QC.configMaxTest = n+ , QC.configMaxFail = 1000 `max` 10*n+ })+#else+ checkQuick n =+ QC.quickCheckWith (QC.stdArgs+ { QC.maxSize = n+ , QC.maxSuccess = n+ , QC.maxDiscardRatio = 1000 `max` 10*n+ })+#endif+ checkSmall d f = SC.smallCheck d f >> putStrLn ""+++testEqual :: (Show a, Eq a) => String -> a -> a -> HU.Test+testEqual s a b =+ HU.TestLabel s $ HU.TestCase $ HU.assertEqual "" a b++----------------------------------------------------------------+-- Because we avoid epsilons everywhere else, need to make sure 'mergeBy' gets it right+test_Union :: HU.Test+test_Union = HU.TestLabel "epsilon union"+ $ HU.TestList+ [ testEqual "left" (e1 `Tr.unionL` e2) e1+ , testEqual "right" (e1 `Tr.unionR` e2) e2 -- meh, why not+ , testEqual "unionR regression" (tLeft `Tr.unionR` tRight) tRightResult+ , testEqual "unionL regression" (tLeft `Tr.unionL` tRight) tLeftResult+ ]+ where+ e1 = Tr.singleton T.empty (4::Int)+ e2 = Tr.singleton T.empty (2::Int)++ -- Regression test against bug filed by Gregory Crosswhite on 2010.06.10 against version 0.2.1.1.+ a, b :: T.Text+ a = T.pack $ read "\"\231^\179\160Y\134Gr\158<)&\222\217#\156\""+ b = T.pack $ read "\"\172\193\GSp\222\174GE\186\151\DC1#P\213\147\SI\""+ tLeft = Tr.fromList [(a,1::Int),(b,0::Int)]+ tRight = Tr.fromList [(a,2::Int)]+ tRightResult = Tr.fromList [(a,2::Int),(b,0::Int)]+ tLeftResult = Tr.fromList [(a,1::Int),(b,0::Int)]+++----------------------------------------------------------------+test_Submap :: HU.Test+test_Submap = HU.TestLabel "submap"+ $ HU.TestList+ [ nullSubmap "split on arc fails" fi True+ , nullSubmap "prefix of arc matches" fo False+ , nullSubmap "suffix of empty fails" food True+ , nullSubmap "missing branch fails" bag True+ , nullSubmap "at a branch matches" ba False+ ]+ where+ t = vocab2trie ["foo", "bar", "baz"]+ fi = T.pack "fi"+ fo = T.pack "fo"+ food = T.pack "food"+ ba = T.pack "ba"+ bag = T.pack "bag"++ nullSubmap s q b = testEqual s (Tr.null $ Tr.submap q t) b++ vocab2trie = Tr.fromList . flip zip [(0::Int)..] . map T.pack++----------------------------------------------------------------+-- requires Eq (Trie a) and, in case it fails, Show (Trie a)+test_Insert :: HU.Test+test_Insert = HU.TestLabel "insert"+ $ HU.TestList+ [ testEqual "insertion is commutative for prefix/superfix"+ (Tr.insert aba o $ Tr.insert abaissed i $ Tr.empty)+ (Tr.insert abaissed i $ Tr.insert aba o $ Tr.empty)+ ]+ where+ aba = T.pack "aba"+ abaissed = T.pack "abaissed"++ o = 0::Int+ i = 1::Int+++test_Delete :: HU.Test+test_Delete = HU.TestLabel "delete"+ $ HU.TestList+ [ testEqual "deleting epsilon from empty trie is empty"+ (Tr.delete epsilon Tr.empty) (Tr.empty :: Tr.Trie Int)+ ]+ where+ epsilon = T.pack ""++newtype Letter = Letter { unLetter :: Char }+ deriving (Eq, Ord, Show)++letters :: [Char]+letters =+ concat+ [ ['\t' .. '\n']+ , [' ']+ , ['"' .. '#']+ , ['(' .. ')']+ , ['+' .. ';']+ , ['=', '?']+ , ['A' .. 'Z']+ , ['_']+ , ['a' .. 'z']+ , [ '\170'+ , '\220'+ , '\223'+ , '\233'+ , '\241'+ , '\261'+ , '\338'+ , '\12354'+ , '\12509'+ , '\13312'+ , '\19970'+ , '\34920'+ , '\36877'+ , '\40407'+ , '\65314'+ , '\131072'+ ]+ ]++instance QCA.Arbitrary Letter where+ arbitrary = Letter `fmap` QC.elements letters++ shrink = fmap Letter . QCA.shrink . unLetter+++newtype Str = Str { unStr :: L.Text }+ deriving (Eq, Ord, Show)++instance QCA.Arbitrary Str where+ arbitrary = QC.sized $ \n -> do+ k <- QC.choose (0,n)+ s <- QC.vector k+ c <- QC.arbitrary -- We only want non-empty strings.+ return . Str . L.pack $ map unLetter (c:s)++ shrink = fmap Str . QCA.shrink . unStr++instance QCA.Arbitrary T.Text where+ arbitrary = T.pack <$> QCA.arbitrary++ shrink = fmap T.pack . QCA.shrink . T.unpack+++instance QCA.Arbitrary L.Text where+ arbitrary = L.pack <$> QCA.arbitrary++ shrink = fmap L.pack . QCA.shrink . L.unpack++instance (QCA.Arbitrary a, Generic a) => QCA.Arbitrary (Tr.Trie a) where+ arbitrary = QC.sized $ \n -> do+ k <- QC.choose (0,n)+ labels <- map (L.toStrict . unStr) `fmap` QC.vector k+ elems <- QC.vector k+ return . Tr.fromList $ zip labels elems++ shrink = QCA.genericShrink++----------------------------------------------------------------+-- cf <http://www.cs.york.ac.uk/fp/darcs/smallcheck/README>+-- type Series a = Int -> [a]++instance Monad m => SCS.Serial m Letter where+ series = SCS.generate $ \d -> take (d+1) $ map Letter letters++instance Monad m => SCS.Serial m Str where+ series = Str . L.pack . map unLetter <$> SCS.series++-- -- TODO: This instance really needs some work. The smart constructures ensure only valid values are generated, but there are redundancies and inefficiencies.+instance (Monoid a, SCS.Serial m a) => SCS.Serial m (Tr.Trie a) where+ series = SCS.cons0 Tr.empty+ SCS.\/ SCS.cons3 arcHACK+ SCS.\/ SCS.cons2 mappend+ where+ arcHACK (Str k) Nothing t = Tr.singleton (L.toStrict k) () >> t+ arcHACK (Str k) (Just v) t = Tr.singleton (L.toStrict k) v+ >>= Tr.unionR t . Tr.singleton T.empty+++----------------------------------------------------------------+----------------------------------------------------------------+-- | If you insert a value, you can look it up+prop_insert :: (Eq a) => Str -> a -> Tr.Trie a -> Bool+prop_insert (Str k) v t =+ (Tr.lookup sk . Tr.insert sk v $ t) == Just v+ where+ sk = L.toStrict k+++-- | A singleton, is.+prop_singleton :: (Eq a) => Str -> a -> Bool+prop_singleton (Str k) v =+ Tr.insert sk v Tr.empty == Tr.singleton sk v+ where+ sk = L.toStrict k+++-- | Deal with QC/SC polymorphism issues because of (==>)+-- Fundeps would be nice here, but |b->a is undecidable, and |a->b is wrong+class CheckGuard a b where+ (==>) :: Bool -> a -> b++instance (QC.Testable a) => CheckGuard a QC.Property where+ (==>) = (QC.==>)++instance SC.Testable IO QC.Property where+ test prop = SC.monadic $ do+ (resultStr, result) <- capture $ checkQuick 500 prop+ if QC.isSuccess result+ then return True+ else do+ putStrLn resultStr+ print result+ return False+ where+#ifdef __USE_QUICKCHECK_1__+ checkQuick n =+ QC.checkResult (QC.defaultConfig+ { QC.configMaxTest = n+ , QC.configMaxFail = 1000 `max` 10*n+ })+#else+ checkQuick n =+ QC.quickCheckWithResult (QC.stdArgs+ { QC.maxSize = n+ , QC.maxSuccess = n+ , QC.maxDiscardRatio = 1000 `max` 10*n+ })+#endif+++instance (Monad m, SC.Testable m a) => CheckGuard a (SC.Property m) where+ (==>) = (SC.==>)++prop_size_insert :: (Eq a, Show a, CheckGuard QC.Property b) => Str -> a -> Tr.Trie a -> b+prop_size_insert (Str k) v t = not (sk `Tr.member` t) ==> (+ (Tr.size . Tr.insert sk v) === ((1+) . Tr.size)+ $ t)+ where+ sk = L.toStrict k++prop_size_delete :: (Eq a, Show a, CheckGuard QC.Property b) => Str -> a -> Tr.Trie a -> b+prop_size_delete (Str k) v t = not (sk `Tr.member` t) ==> (+ (Tr.size . Tr.delete sk . Tr.insert sk v) === Tr.size+ $ t)+ where+ sk = L.toStrict k++prop_insert_delete :: (Eq a, Show a, CheckGuard QC.Property b) => Str -> a -> Tr.Trie a -> b+prop_insert_delete (Str k) v t = not (sk `Tr.member` t) ==> (+ (Tr.delete sk . Tr.insert sk v) === id+ $ t)+ where+ sk = L.toStrict k++prop_delete_lookup :: (Eq a, Show a, CheckGuard QC.Property b) => Str -> Tr.Trie a -> b+prop_delete_lookup (Str k) t = not (sk `Tr.member` t) ==> (+ (Tr.lookup sk . Tr.delete sk) === const Nothing+ $ t)+ where+ sk = L.toStrict k+++-- | All keys in a submap are keys in the supermap+prop_submap1 :: Str -> Tr.Trie a -> Bool+prop_submap1 (Str k) t =+ all ((`Tr.member` t) . L.toStrict) . Tr.keys . Tr.submap (L.toStrict k) $ t+++-- | All keys in a submap have the query as a prefix+prop_submap2 :: Str -> Tr.Trie a -> Bool+prop_submap2 (Str k) t =+ all (L.isPrefixOf k) . Tr.keys . Tr.submap (L.toStrict k) $ t+++-- | All values in a submap are the same in the supermap+prop_submap3 :: (Eq a) => Str -> Tr.Trie a -> Bool+prop_submap3 (Str k) t =+ (\q -> Tr.lookup q t' == Tr.lookup q t) `all` fmap L.toStrict (Tr.keys t')+ where t' = Tr.submap (L.toStrict k) t+++infix 4 <==+(<==) :: (Ord a, Show a) => a -> a -> QC.Property+x <== y =+ QC.counterexample (show x ++ interpret res ++ show y) (res == LT || res == EQ)+ where+ res = x `compare` y+ interpret LT = " < "+ interpret EQ = " == "+ interpret GT = " > "++-- | Keys are ordered when converting to a list+prop_toList :: Tr.Trie a -> QC.Property+prop_toList t = ordered (toList16 . L.toStrict <$> Tr.keys t)+ where ordered xs = QC.conjoin (zipWith (<==) xs (drop 1 xs))+++_takes_first :: (Eq c, Show c) => ([(L.Text, c)] -> Tr.Trie c) -> [(Str, c)] -> QC.Property+_takes_first f assocs =+ (Tr.toList . f) === (nubBy (apFst ((==) `on` (toList16 . L.toStrict))) . sortOn (toList16 . L.toStrict . fst))+ $ map (first unStr) assocs+++-- | 'fromList' takes the first value for a given key+prop_fromList_takes_first :: (Eq a, Show a) => [(Str, a)] -> QC.Property+prop_fromList_takes_first = _takes_first (Tr.fromList . fmap (first L.toStrict))+++-- | 'fromListR' takes the first value for a given key+prop_fromListR_takes_first :: (Eq a, Show a) => [(Str, a)] -> QC.Property+prop_fromListR_takes_first = _takes_first (TC.fromListR . fmap (first L.toStrict))+++-- | 'fromListL' takes the first value for a given key+prop_fromListL_takes_first :: (Eq a, Show a) => [(Str, a)] -> QC.Property+prop_fromListL_takes_first = _takes_first (TC.fromListL . fmap (first L.toStrict))+++-- | 'fromListS' takes the first value for a given key+prop_fromListS_takes_first :: (Eq a, Show a) => [(Str, a)] -> QC.Property+prop_fromListS_takes_first = _takes_first (TC.fromListS . fmap (first L.toStrict))+++-- | @('fromListWith' const)@ takes the first value for a given key+prop_fromListWithConst_takes_first :: (Eq a, Show a) => [(Str, a)] -> QC.Property+prop_fromListWithConst_takes_first = _takes_first (TC.fromListWith const . fmap (first L.toStrict))+++-- | @('fromListWithL' const)@ takes the first value for a given key+prop_fromListWithLConst_takes_first :: (Eq a, Show a) => [(Str, a)] -> QC.Property+prop_fromListWithLConst_takes_first = _takes_first (TC.fromListWithL const . fmap (first L.toStrict))++prop_length16_is_length_toList16 :: Str -> QC.Property+prop_length16_is_length_toList16 = (length16 . L.toStrict . unStr) === (length . toList16 . L.toStrict . unStr)++----------------------------------------------------------------+-- | Lift a function to apply to the first of pairs, retaining the second.+first :: (a -> b) -> (a,c) -> (b,c)+first f (x,y) = (f x, y)++-- | Lift a binary function to apply to the first of pairs, discarding seconds.+apFst :: (a -> b -> c) -> ((a,d) -> (b,e) -> c)+apFst f (x,_) (y,_) = f x y++-- | Function equality+(===) :: (Eq b, Show b) => (a -> b) -> (a -> b) -> (a -> QC.Property)+(===) f g x = (QC.===) (f x) (g x)+----------------------------------------------------------------+----------------------------------------------------------- fin.+
+ test/Data/Trie/TextInternal/Test.hs view
@@ -0,0 +1,51 @@+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}++----------------------------------------------------------------+-- ~ 2019.04.03+-- |+-- Module : Data.Trie.TextInternal.Test+-- Copyright : Copyright (c) 2008--2009 wren gayle romano, 2019 michael j. klein+-- License : BSD3+-- Maintainer : lambdamichael@gmail.com+-- Stability : experimental+--+-- Testing helper functions on 'Text'+-- (mostly to ensure they match expectations from `bytestring-trie`).++module Data.Trie.TextInternal.Test where++import qualified Data.Text as T+import Data.Trie.TextInternal++import Data.List (unfoldr)+----------------------------------------------------------------++-- | For debugging. [] is the infinite bit, head is the little end+showBits :: (Integral a) => a -> String+showBits = unfoldr getBit+ where+ getBit 0 = Nothing+ getBit i | odd i = Just ('I', (i-1)`div`2)+ | otherwise = Just ('O', i`div`2)++-- TODO: make this into an HUnit test+test :: IO ()+test = do+ cmp' hello+ cmp' $ T.pack "hi"+ cmp' $ T.pack "heat"+ cmp' $ T.pack "held"+ cmp' $ T.pack "hell"+ cmp' $ T.pack "hello"+ cmp' $ T.pack "jello"++ where+ cmp' y = do putStrLn . show . breakMaximalPrefix hello $ y+ putStrLn . show . (\(a,b,c) -> (a,c,b)) . breakMaximalPrefix y $ hello+ putStrLn "\n"++ hello = T.pack "hello"++----------------------------------------------------------------+----------------------------------------------------------- fin.+
+ test/FromListBench.hs view
@@ -0,0 +1,60 @@+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}++----------------------------------------------------------------+-- ~ 2009.01.04+-- |+-- Module : FromListBench+-- Copyright : Copyright (c) 2008--2009 wren gayle romano+-- License : BSD3+-- Maintainer : wren@community.haskell.org+-- Stability : provisional+-- Portability : portable+--+-- Benchmarking for left- vs right-fold for @fromList@.+----------------------------------------------------------------++module FromListBench (test) where++import qualified Data.Trie as Tr+import Data.Trie.Convenience (insertIfAbsent)+import Data.List (foldl', sort)+import qualified Data.ByteString as S++import Data.ByteString.Internal (c2w)++import Microbench+import Control.Exception (evaluate)+----------------------------------------------------------------++fromListR, fromListL :: [(S.ByteString, a)] -> Tr.Trie a+fromListR = foldr (uncurry Tr.insert) Tr.empty+fromListL = foldl' (flip $ uncurry $ insertIfAbsent) Tr.empty++getList, getList' :: S.ByteString -> Int -> [(S.ByteString, Int)]+getList xs n = map (\k -> (k,0)) . S.inits . S.take n $ xs+getList' xs n = map (\k -> (k,0)) . S.tails . S.take n $ xs++test :: IO ()+test = do+ -- 100000 is large enough to trigger Microbench's stop condition,+ -- and small enough to not lock up the system in trying to create it.+ xs <- evaluate $ S.replicate 100000 (c2w 'a')++ microbench "fromListR obverse" (Tr.null . fromListR . getList xs)+ microbench "fromListL obverse" (Tr.null . fromListL . getList xs)++ putStrLn ""+ microbench "fromListR reverse" (Tr.null . fromListR . getList' xs)+ microbench "fromListL reverse" (Tr.null . fromListL . getList' xs)++ -- Sorting forces it into the obverse order at O(n log n) cost+ putStrLn ""+ putStrLn ""+ microbench "fromListR obverse sorted" (Tr.null . fromListR . sort . getList xs)+ microbench "fromListL obverse sorted" (Tr.null . fromListL . sort . getList xs)+ putStrLn ""+ microbench "fromListR reverse sorted" (Tr.null . fromListR . sort . getList' xs)+ microbench "fromListL reverse sorted" (Tr.null . fromListL . sort . getList' xs)++----------------------------------------------------------------+----------------------------------------------------------- fin.
+ test/FromListBench/Text.hs view
@@ -0,0 +1,58 @@+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}++----------------------------------------------------------------+-- ~ 2019.04.03+-- |+-- Module : FromListBench.Text+-- Copyright : Copyright (c) 2008--2009 wren gayle romano, 2019 michael j. klein+-- License : BSD3+-- Maintainer : lambdamichael@gmail.com+-- Stability : experimental+--+-- Benchmarking for left- vs right-fold for @fromList@.+----------------------------------------------------------------++module FromListBench.Text (test) where++import qualified Data.Trie.Text as Tr+import Data.Trie.Text.Convenience (insertIfAbsent)+import Data.List (foldl', sort)+import qualified Data.Text as T++import Microbench+import Control.Exception (evaluate)+----------------------------------------------------------------++fromListR, fromListL :: [(T.Text, a)] -> Tr.Trie a+fromListR = foldr (uncurry Tr.insert) Tr.empty+fromListL = foldl' (flip $ uncurry $ insertIfAbsent) Tr.empty++getList, getList' :: T.Text -> Int -> [(T.Text, Int)]+getList xs n = map (\k -> (k,0)) . T.inits . T.take n $ xs+getList' xs n = map (\k -> (k,0)) . T.tails . T.take n $ xs++test :: IO ()+test = do+ -- 100000 is large enough to trigger Microbench's stop condition,+ -- and small enough to not lock up the system in trying to create it.+ xs <- evaluate $ T.replicate 100000 (T.singleton 'a')++ microbench "fromListR obverse" (Tr.null . fromListR . getList xs)+ microbench "fromListL obverse" (Tr.null . fromListL . getList xs)++ putStrLn ""+ microbench "fromListR reverse" (Tr.null . fromListR . getList' xs)+ microbench "fromListL reverse" (Tr.null . fromListL . getList' xs)++ -- Sorting forces it into the obverse order at O(n log n) cost+ putStrLn ""+ putStrLn ""+ microbench "fromListR obverse sorted" (Tr.null . fromListR . sort . getList xs)+ microbench "fromListL obverse sorted" (Tr.null . fromListL . sort . getList xs)+ putStrLn ""+ microbench "fromListR reverse sorted" (Tr.null . fromListR . sort . getList' xs)+ microbench "fromListL reverse sorted" (Tr.null . fromListL . sort . getList' xs)++----------------------------------------------------------------+----------------------------------------------------------- fin.+
+ test/FromListBench/Text/Encode.hs view
@@ -0,0 +1,60 @@+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}++----------------------------------------------------------------+-- ~ 2019.04.09+-- |+-- Module : FromListBench.Text+-- Copyright : Copyright (c) 2008--2009 wren gayle romano, 2019 michael j. klein+-- License : BSD3+-- Maintainer : lambdamichael@gmail.com+-- Stability : experimental+--+-- Benchmarking for left- vs right-fold for @fromList@ with+-- encoding from `Text` to UTF16 (Little Endian) `ByteString`+-- for use with `Trie`+----------------------------------------------------------------++module FromListBench.Text.Encode (test) where++import qualified Data.Trie as Tr+import Data.Trie.Convenience (insertIfAbsent)+import Data.List (foldl', sort)+import qualified Data.Text as T+import qualified Data.Text.Encoding as E++import Microbench+import Control.Exception (evaluate)+----------------------------------------------------------------++fromListR, fromListL :: [(T.Text, a)] -> Tr.Trie a+fromListR = foldr (uncurry (Tr.insert . E.encodeUtf16LE)) Tr.empty+fromListL = foldl' (flip $ uncurry $ insertIfAbsent . E.encodeUtf16LE) Tr.empty++getList, getList' :: T.Text -> Int -> [(T.Text, Int)]+getList xs n = map (\k -> (k,0)) . T.inits . T.take n $ xs+getList' xs n = map (\k -> (k,0)) . T.tails . T.take n $ xs++test :: IO ()+test = do+ -- 100000 is large enough to trigger Microbench's stop condition,+ -- and small enough to not lock up the system in trying to create it.+ xs <- evaluate $ T.replicate 100000 (T.singleton 'a')++ microbench "fromListR obverse" (Tr.null . fromListR . getList xs)+ microbench "fromListL obverse" (Tr.null . fromListL . getList xs)++ putStrLn ""+ microbench "fromListR reverse" (Tr.null . fromListR . getList' xs)+ microbench "fromListL reverse" (Tr.null . fromListL . getList' xs)++ -- Sorting forces it into the obverse order at O(n log n) cost+ putStrLn ""+ putStrLn ""+ microbench "fromListR obverse sorted" (Tr.null . fromListR . sort . getList xs)+ microbench "fromListL obverse sorted" (Tr.null . fromListL . sort . getList xs)+ putStrLn ""+ microbench "fromListR reverse sorted" (Tr.null . fromListR . sort . getList' xs)+ microbench "fromListL reverse sorted" (Tr.null . fromListL . sort . getList' xs)++----------------------------------------------------------------+----------------------------------------------------------- fin.
+ test/TrieFile/Text.hs view
@@ -0,0 +1,89 @@+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}++----------------------------------------------------------------+-- ~ 2019.04.03+-- |+-- Module : TrieFile.Text+-- Copyright : Copyright (c) 2008--2009 wren gayle romano, 2019 michael j. klein+-- License : BSD3+-- Maintainer : lambdamichael@gmail.com+-- Stability : experimental+--+-- Example program to read each line from a file (e.g. @/usr/dict@)+-- into a trie. Used to benchmark the naive algorithm against the+-- optimized C. Also used to verify correctness of C implementation,+-- and Trie implementation in general.+----------------------------------------------------------------++module TrieFile.Text (test, readTrieFromFile) where++import qualified Data.Trie.Text as Tr+import qualified Data.Trie.Text.Internal as Tr+import qualified Data.Text.IO as T++import qualified Data.Foldable as F++{-+import Microbench+import Control.Exception (evaluate)+-- -}++import System.IO (withFile, IOMode(..), hIsEOF)+import System.Environment (getArgs)+----------------------------------------------------------------++-- Broken out for manual use in GHCi+readTrieFromFile :: FilePath -> IO (Tr.Trie Int)+readTrieFromFile file = withFile file ReadMode $ \h ->+ let go i t = do { b <- hIsEOF h+ ; if b+ then return t+ else do { line <- T.hGetLine h+ ; (go $! i+1) $! Tr.insert line i t+ }+ }+ in go 0 Tr.empty++test :: IO ()+test = do+ args <- getArgs+ case args of+ [] -> putStrLn "No Trie file to benchmark"+ file:_ -> do+ t <- readTrieFromFile file -- >>= evaluate++ -- `sort`+ -- S.putStrLn . S.unlines . Tr.keys $ t++ -- `wc -l`+ -- putStrLn . show . Tr.size $ t+++ {- -- Tests for comparing inferred foldl/foldr vs hand-written version+ microbench "List.foldr elems" $ do+ vs <- return $! Tr.elems t+ n <- return $! foldr (\v r -> v `seq` (1+) $! r) (0::Int) vs+ n `seq` (return () :: IO ())++ microbench "Trie.foldr @elems" $ do+ t' <- return $! t+ n <- return $! F.foldr (\v r -> v `seq` (1+) $! r) (0::Int) t'+ n `seq` (return () :: IO ())++ microbench "Trie.foldl @elems" $ do+ t' <- return $! t+ n <- return $! F.foldl (\r v -> v `seq` (1+) $! r) (0::Int) t'+ n `seq` (return () :: IO ())+ -- -}++ -- {- -- verify associativity of folds+ putStrLn . show . take 20 . F.foldr (:) [] $ t+ putStrLn . show . take 20 . Tr.foldrWithKey (const (:)) [] $ t++ putStrLn . show . take 20 . F.foldl (flip (:)) [] $ t+ -- -}+++----------------------------------------------------------------+----------------------------------------------------------- fin.+
+ test/test-text-trie.hs view
@@ -0,0 +1,50 @@+{-# OPTIONS_GHC -Wall -fwarn-tabs #-}++----------------------------------------------------------------+-- ~ 2019.04.03+-- |+-- Copyright : Copyright (c) 2019 michael j. klein+-- License : BSD3+-- Maintainer : lambdamichael@gmail.com+-- Stability : experimental+----------------------------------------------------------------++import qualified Data.Trie.TextInternal.Test+import qualified Data.Trie.Text.Test+import qualified FromListBench+import qualified FromListBench.Text+import qualified FromListBench.Text.Encode+import qualified TrieFile.Text++main :: IO ()+main = do+ putStrLn "Data.Trie.TextInternal.Test"+ Data.Trie.TextInternal.Test.test+ putStrLn "End: Data.Trie.TextInternal.Test"+ putStrLn ""++ putStrLn "Data.Trie.Text.Test"+ Data.Trie.Text.Test.test+ putStrLn "End: Data.Trie.Text.Test"+ putStrLn ""++ putStrLn "FromListBench"+ FromListBench.test+ putStrLn "End: FromListBench"+ putStrLn ""++ putStrLn "FromListBench.Text"+ FromListBench.Text.test+ putStrLn "End: FromListBench.Text"+ putStrLn ""++ putStrLn "FromListBench.Text.Encode"+ FromListBench.Text.Encode.test+ putStrLn "End: FromListBench.Text.Encode"+ putStrLn ""++ putStrLn "TrieFile.Text"+ TrieFile.Text.test+ putStrLn "End: TrieFile.Text"+ putStrLn ""+
+ text-trie.cabal view
@@ -0,0 +1,105 @@+------------------------------------------------------------+-- michael j. klein <lambdamichael@gmail.com> ~ 2019.04.11+------------------------------------------------------------++-- By and large Cabal >=1.2 is fine; but+-- * >=1.6 gives tested-with: and source-repository:+-- * >=1.8 allows executables to build-depends: on the library+-- * >=1.9.2 allows Test-Suite+Cabal-Version: >= 1.9.2+Build-Type: Simple++Name: text-trie+Version: 0.2.5.0+Stability: provisional+Homepage: http://github.com/michaeljklein/text-trie+Author: wren gayle romano, michael j. klein+Maintainer: lambdamichael@gmail.com+Copyright: Copyright (c) 2008--2019 wren gayle romano, 2019 michael j. klein+License: BSD3+License-File: LICENSE++Category: Data, Data Structures+Synopsis: An efficient finite map from Text to values, based on bytestring-trie.+Description: An efficient finite map from Text to values, based on bytestring-trie.+ .+ The implementation is based on big-endian patricia+ trees, like "Data.IntMap". We first trie on the+ elements of "Data.ByteString" and then trie on the+ big-endian bit representation of those elements.+ Patricia trees have efficient algorithms for union+ and other merging operations, but they're also quick+ for lookups and insertions.+ .+ If you are only interested in being able to associate+ strings to values, then you may prefer the @hashmap@+ package which is faster for those only needing a+ map-like structure. This package is intended for+ those who need the extra capabilities that a trie-like+ structure can offer (e.g., structure sharing to+ reduce memory costs for highly redundant keys,+ taking the submap of all keys with a given prefix,+ contextual mapping, extracting the minimum and+ maximum keys, etc.)+++Extra-source-files:+ AUTHORS, CHANGELOG, README.md++-- Tested-With:+-- GHC ==7.4.1, GHC ==7.4.2,+-- GHC ==7.6.1, GHC ==7.6.2, GHC ==7.6.3,+-- 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,+-- 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/michaeljklein/text-trie.git++------------------------------------------------------------+Library+ Hs-Source-Dirs: src+ Exposed-Modules: Data.Trie.Text+ , Data.Trie.Text.Internal+ , Data.Trie.Text.Convenience+ , Data.Trie.TextInternal+ , Data.Text.Internal.Word16+ Other-Modules: Data.Trie.Text.BitTwiddle+ , Data.Trie.Errors+ -- 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+ , text >= 1.2.3 && < 1.2.4+ , binary >= 0.5.1 && < 0.8.7++------------------------------------------------------------+Test-Suite test-text-trie+ type: exitcode-stdio-1.0+ Hs-Source-Dirs: test+ main-is: test-text-trie.hs+ ghc-options: -fno-warn-orphans+ Other-Modules: Data.Trie.TextInternal.Test+ , Data.Trie.Text.Test+ , FromListBench+ , FromListBench.Text+ , FromListBench.Text.Encode+ , TrieFile.Text+ build-depends: text-trie+ , base >= 4.5 && < 4.13+ , bytestring >= 0.9.2 && < 0.11+ , text >= 1.2.3 && < 1.2.4+ , binary >= 0.5.1 && < 0.8.7+ , QuickCheck+ , HUnit+ , smallcheck+ , microbench+ , bytestring-trie >= 0.2.5 && < 0.2.6+ , silently >= 1.2.5 && < 1.2.6++------------------------------------------------------------+------------------------------------------------------- fin.