diff --git a/AUTHORS b/AUTHORS new file mode 100644 --- /dev/null +++ b/AUTHORS @@ -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 diff --git a/CHANGELOG b/CHANGELOG new file mode 100644 --- /dev/null +++ b/CHANGELOG @@ -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` diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. + diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,70 @@ +text-trie +=============== +[![Hackage version](https://img.shields.io/hackage/v/bytestring-trie.svg?style=flat)](https://hackage.haskell.org/package/text-trie) +[![TravisCI Build Status](https://img.shields.io/travis/michaeljklein/bytestring-trie.svg?style=flat)](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) + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,7 @@ +#!/usr/bin/env runhaskell + +module Main (main) where +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/src/Data/Text/Internal/Word16.hs b/src/Data/Text/Internal/Word16.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Internal/Word16.hs @@ -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 + diff --git a/src/Data/Trie/Errors.hs b/src/Data/Trie/Errors.hs new file mode 100644 --- /dev/null +++ b/src/Data/Trie/Errors.hs @@ -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. diff --git a/src/Data/Trie/Text.hs b/src/Data/Trie/Text.hs new file mode 100644 --- /dev/null +++ b/src/Data/Trie/Text.hs @@ -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` +-- +-- +-- * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\", +-- Workshop on ML, September 1998, pages 77-86, +-- +-- +-- * 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. + diff --git a/src/Data/Trie/Text/BitTwiddle.hs b/src/Data/Trie/Text/BitTwiddle.hs new file mode 100644 --- /dev/null +++ b/src/Data/Trie/Text/BitTwiddle.hs @@ -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. + diff --git a/src/Data/Trie/Text/Convenience.hs b/src/Data/Trie/Text/Convenience.hs new file mode 100644 --- /dev/null +++ b/src/Data/Trie/Text/Convenience.hs @@ -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. + diff --git a/src/Data/Trie/Text/Internal.hs b/src/Data/Trie/Text/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Trie/Text/Internal.hs @@ -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: +-- 1. 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 +-- +-- +-- | 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. + diff --git a/src/Data/Trie/TextInternal.hs b/src/Data/Trie/TextInternal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Trie/TextInternal.hs @@ -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. diff --git a/test/Data/Trie/Text/Test.hs b/test/Data/Trie/Text/Test.hs new file mode 100644 --- /dev/null +++ b/test/Data/Trie/Text/Test.hs @@ -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 +-- 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. + diff --git a/test/Data/Trie/TextInternal/Test.hs b/test/Data/Trie/TextInternal/Test.hs new file mode 100644 --- /dev/null +++ b/test/Data/Trie/TextInternal/Test.hs @@ -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. + diff --git a/test/FromListBench.hs b/test/FromListBench.hs new file mode 100644 --- /dev/null +++ b/test/FromListBench.hs @@ -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. diff --git a/test/FromListBench/Text.hs b/test/FromListBench/Text.hs new file mode 100644 --- /dev/null +++ b/test/FromListBench/Text.hs @@ -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. + diff --git a/test/FromListBench/Text/Encode.hs b/test/FromListBench/Text/Encode.hs new file mode 100644 --- /dev/null +++ b/test/FromListBench/Text/Encode.hs @@ -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. diff --git a/test/TrieFile/Text.hs b/test/TrieFile/Text.hs new file mode 100644 --- /dev/null +++ b/test/TrieFile/Text.hs @@ -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. + diff --git a/test/test-text-trie.hs b/test/test-text-trie.hs new file mode 100644 --- /dev/null +++ b/test/test-text-trie.hs @@ -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 "" + diff --git a/text-trie.cabal b/text-trie.cabal new file mode 100644 --- /dev/null +++ b/text-trie.cabal @@ -0,0 +1,105 @@ +------------------------------------------------------------ +-- michael j. klein ~ 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.