packages feed

trie-simple (empty) → 0.4.1.1

raw patch · 19 files changed

+1845/−0 lines, 19 filesdep +QuickCheckdep +basedep +containerssetup-changed

Dependencies added: QuickCheck, base, containers, criterion, deepseq, hspec, mtl, mwc-random, trie-simple, vector

Files

+ CHANGELOG.md view
@@ -0,0 +1,4 @@+# 0.4.1.1++- Initial release.+
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2018, Koji Miyazato++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 Koji Miyazato nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,34 @@+# trie-simple++Trie data structure `TMap` to hold mapping from list of characters to+something, i.e. isomorphic to `Map [c] v`.+This package also contains `TSet`, which is isomorphic to `Set` of lists of+characters.++This package implements these structures using `Map` from containers+package, and require the character type to be only `Ord`.++Advantages of using this package over `Map` or `Set` are:++  * 2x Faster `lookup` (`member`) operation+  * Retrieving subset of map or set with given prefix+  * `append`, `prefixes`, and `suffixes` support+  * Can be more memory-efficient (but not always; needs+    benchmark anyway).++## Benchmarks++Benchmarks compared against plain `Map` and `Set`.++![benchmark chart for TMap](https://raw.githubusercontent.com/viercc/trie-simple/master/doc/benchTMap.png)++![benchmark chart for TSet](https://raw.githubusercontent.com/viercc/trie-simple/master/doc/benchTSet.png)++## About License++[LICENSE](LICENSE) tells the licence of this project, EXCEPT+one file for benchmark input data. See [ABOUT](ABOUT) for that+file.++If you install `trie-simple` from Hackage, that input data is not+included in the distributed files.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bench/Common.hs view
@@ -0,0 +1,43 @@+module Common(+  dictAmEn, dictBrEn,+  dictAmEnShuffled, randomStrs,+  dictURI1, dictURI2+) where++import qualified Data.Vector as V+import Data.Word++import qualified System.Random.MWC                as R+import qualified System.Random.MWC.CondensedTable as R+import qualified System.Random.MWC.Distributions  as R++numRandomStr :: Int+numRandomStr = 1000++seed :: Word32 -> V.Vector Word32+seed w = V.fromList [1573289798, 32614861, w]++dictAmEn, dictBrEn, dictAmEnShuffled, randomStrs :: IO [String]+dictAmEn = lines <$> readFile "/usr/share/dict/american-english"+dictBrEn = lines <$> readFile "/usr/share/dict/british-english"+dictAmEnShuffled = lines <$> readFile "benchdata/american-english-shuf"+randomStrs =+  do g <- R.initialize (seed 3)+     revReplicateM numRandomStr $ do+       n <- R.genFromTable distN g+       revReplicateM (n+1) (uniformAlphabet g)+  where+    distN = R.tableBinomial 12 0.33+    alphabet = V.fromList ['a' .. 'z']+    numAlphabet = V.length alphabet+    uniformAlphabet g = (alphabet V.!) <$> R.uniformR (0, numAlphabet-1) g++dictURI1, dictURI2 :: IO [String]+dictURI1 = lines <$> readFile "benchdata/externallinks.txt.1"+dictURI2 = lines <$> readFile "benchdata/externallinks.txt.2"++revReplicateM :: (Monad m) => Int -> m a -> m [a]+revReplicateM n ma = loop n []+  where+    loop 0 acc = return acc+    loop i acc = ma >>= \a -> loop (i-1) (a:acc)
+ bench/trie-benchmark.hs view
@@ -0,0 +1,280 @@+module Main(main) where++import Criterion.Main++import qualified Data.Trie.Set as TSet+import Data.Trie.Map (TMap)+import qualified Data.Trie.Map as TMap++import Data.Monoid+import Data.List (sort, inits, tails, foldl')+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Map.Lazy (Map)+import qualified Data.Map.Lazy as Map++import Common++main :: IO ()+main = defaultMain+  [ benchTSet+  , benchTSet_URI+  , benchSet+  , benchSet_URI+  , benchTMap+  , benchMap+  ]++benchTSet :: Benchmark+benchTSet = bgroup "TSet" +  [ bgroup "construction"+      [ env dictAmEnShuffled $ \dict ->+          bench "fromList" $ whnf TSet.fromList dict+      , env dictAmEn $ \sortedDict ->+          bench "fromAscList" $ whnf TSet.fromAscList sortedDict ]+  , env (TSet.fromList <$> dictAmEn) $ \dict ->+      bgroup "query"+        [ bench "isEmpty" (nf TSet.null dict)+        , bench "stringCount" (nf TSet.count dict)+        , bench "enumerate10" (nf (take 10 . TSet.enumerate) dict)+        , bench "enumerateAll" (nf TSet.enumerate dict)+        , env randomStrs $ \qs ->+            bench "match" (nf (\dict' -> map (`TSet.member` dict') qs) dict) ]+  , env (TSet.fromList <$> dictAmEn) $ \dict ->+      bgroup "single-item"+        [ bench "insert1" (whnf (TSet.insert "wwwwwwwwwwwwwwww") dict)+        , bench "insert2" (whnf (TSet.insert "cheese") dict)+        , bench "delete1" (whnf (TSet.delete "wwwwwwwwwwwwwwww") dict)+        , bench "delete2" (whnf (TSet.delete "cheese") dict)+        ]+  , env (TSet.fromList <$> dictAmEn) $ \dictA ->+    env (TSet.fromList <$> dictBrEn) $ \dictB ->+    env (TSet.fromList <$> randomStrs) $ \dictSmall ->+      bgroup "combine"+        [ bench "union" (whnf (uncurry TSet.union) (dictA, dictB))+        , bench "intersection" (whnf (uncurry TSet.intersection) (dictA, dictB))+        , bench "difference" (whnf (uncurry TSet.difference) (dictA, dictB))+        , bench "append" (whnf (uncurry TSet.append) (dictSmall, dictSmall))+        , bench "prefixes" (whnf TSet.prefixes dictA)+        , bench "suffixes" (whnf TSet.suffixes dictB) ]+  ]++benchTSet_URI :: Benchmark+benchTSet_URI = bgroup "TSet_URI" +  [ bgroup "construction"+      [ env dictURI1 $ \dict ->+          bench "fromList" $ whnf TSet.fromList dict+      , env (sort <$> dictURI1) $ \sortedDict ->+          bench "fromAscList" $ whnf TSet.fromAscList sortedDict ]+  , env (TSet.fromList <$> dictURI1) $ \dict ->+      bgroup "query"+        [ bench "isEmpty" (nf TSet.null dict)+        , bench "stringCount" (nf TSet.count dict)+        , bench "enumerate10" (nf (take 10 . TSet.enumerate) dict)+        , bench "enumerateAll" (nf TSet.enumerate dict)+        , env randomStrs $ \qs ->+            bench "match" (nf (\dict' -> map (`TSet.member` dict') qs) dict) ]+  , env (TSet.fromList <$> dictURI1) $ \dict ->+      bgroup "single-item"+        [ bench "insert1" (whnf (TSet.insert "wwwwwwwwwwwwwwww") dict)+        , bench "insert2" (whnf (TSet.insert "cheese") dict)+        , bench "delete1" (whnf (TSet.delete "wwwwwwwwwwwwwwww") dict)+        , bench "delete2" (whnf (TSet.delete "cheese") dict)+        ]+  , env (TSet.fromList <$> dictURI1) $ \dictA ->+    env (TSet.fromList <$> dictURI2) $ \dictB ->+    env (TSet.fromList <$> randomStrs) $ \dictSmall ->+      bgroup "combine"+        [ bench "union" (whnf (uncurry TSet.union) (dictA, dictB))+        , bench "intersection" (whnf (uncurry TSet.intersection) (dictA, dictB))+        , bench "difference" (whnf (uncurry TSet.difference) (dictA, dictB))+        , bench "append" (whnf (uncurry TSet.append) (dictSmall, dictSmall))+        , bench "prefixes" (whnf TSet.prefixes dictA)+        , bench "suffixes" (whnf TSet.suffixes dictB) ]+  ]+  +benchSet :: Benchmark+benchSet = bgroup "Set" +  [ bgroup "construction"+      -- Set.fromList detects whether the input list is sorted+      -- and switch the algorithm based on it.+      -- Using shuffled dictionary avoids this optimization fires+      -- in this benchmark.+      [ env dictAmEnShuffled $ \dict ->+          bench "fromList" $ whnf Set.fromList dict+      , env dictAmEn $ \sortedDict ->+          bench "fromAscList" $ whnf Set.fromAscList sortedDict ]+  , env (Set.fromList <$> dictAmEn) $ \dictSet ->+      bgroup "query"+        [ bench "isEmpty" (nf Set.null dictSet)+        , bench "stringCount" (nf Set.size dictSet)+        , bench "enumerate10" (nf (take 10 . Set.toList) dictSet)+        , bench "enumerateAll" (nf Set.toList dictSet)+        , env randomStrs $ \qs ->+            bench "match" (nf (\dictSet' -> map (`Set.member` dictSet') qs) dictSet) ]+  , env (Set.fromList <$> dictAmEn) $ \dict ->+      bgroup "single-item"+        [ bench "insert1" (whnf (Set.insert "wwwwwwwwwwwwwwww") dict)+        , bench "insert2" (whnf (Set.insert "cheese") dict)+        , bench "delete1" (whnf (Set.delete "wwwwwwwwwwwwwwww") dict)+        , bench "delete2" (whnf (Set.delete "cheese") dict)+        ]+  , env (Set.fromList <$> dictAmEn) $ \dictA ->+    env (Set.fromList <$> dictBrEn) $ \dictB ->+    env (Set.fromList <$> randomStrs) $ \dictSmall ->+      bgroup "combine"+        [ bench "union" (whnf (uncurry Set.union) (dictA, dictB))+        , bench "intersection" (whnf (uncurry Set.intersection) (dictA, dictB))+        , bench "difference" (whnf (uncurry Set.difference) (dictA, dictB))+        , bench "append" (whnf (uncurry setAppend) (dictSmall, dictSmall))+        , bench "prefixes" (whnf setPrefixes dictA)+        , bench "suffixes" (whnf setSuffixes dictB) ]+  ]++benchSet_URI :: Benchmark+benchSet_URI = bgroup "Set_URI" +  [ bgroup "construction"+      -- Set.fromList detects whether the input list is sorted+      -- and switch the algorithm based on it.+      -- Using shuffled dictionary avoids this optimization fires+      -- in this benchmark.+      [ env dictURI1 $ \dict ->+          bench "fromList" $ whnf Set.fromList dict+      , env (sort <$> dictURI1) $ \sortedDict ->+          bench "fromAscList" $ whnf Set.fromAscList sortedDict ]+  , env (Set.fromList <$> dictURI1) $ \dictSet ->+      bgroup "query"+        [ bench "isEmpty" (nf Set.null dictSet)+        , bench "stringCount" (nf Set.size dictSet)+        , bench "enumerate10" (nf (take 10 . Set.toList) dictSet)+        , bench "enumerateAll" (nf Set.toList dictSet)+        , env randomStrs $ \qs ->+            bench "match" (nf (\dictSet' -> map (`Set.member` dictSet') qs) dictSet) ]+  , env (Set.fromList <$> dictURI1) $ \dict ->+      bgroup "single-item"+        [ bench "insert1" (whnf (Set.insert "wwwwwwwwwwwwwwww") dict)+        , bench "insert2" (whnf (Set.insert "cheese") dict)+        , bench "delete1" (whnf (Set.delete "wwwwwwwwwwwwwwww") dict)+        , bench "delete2" (whnf (Set.delete "cheese") dict)+        ]+  , env (Set.fromList <$> dictURI1) $ \dictA ->+    env (Set.fromList <$> dictURI2) $ \dictB ->+    env (Set.fromList <$> randomStrs) $ \dictSmall ->+      bgroup "combine"+        [ bench "union" (whnf (uncurry Set.union) (dictA, dictB))+        , bench "intersection" (whnf (uncurry Set.intersection) (dictA, dictB))+        , bench "difference" (whnf (uncurry Set.difference) (dictA, dictB))+        , bench "append" (whnf (uncurry setAppend) (dictSmall, dictSmall))+        , bench "prefixes" (whnf setPrefixes dictA)+        , bench "suffixes" (whnf setSuffixes dictB) ]+  ]++setAppend :: (Ord c) => Set [c] -> Set [c] -> Set [c]+setAppend ass bss = Set.unions+  [ Set.mapMonotonic (as ++) bss+      | as <- Set.toAscList ass ]++setPrefixes :: (Ord c) => Set [c] -> Set [c]+setPrefixes ass = Set.unions+  [ Set.fromDistinctAscList (inits as) | as <- Set.toAscList ass ]++setSuffixes :: (Ord c) => Set [c] -> Set [c]+setSuffixes ass = Set.fromList+  [ bs | as <- Set.toAscList ass, bs <- tails as ]+++benchTMap :: Benchmark+benchTMap = bgroup "TMap" +  [ bgroup "construction"+      [ env dictAmEnShuffled $ \dict ->+          bench "fromList" $ whnf TMap.fromList [(w, length w) | w <- dict]+      , env (sort <$> dictAmEn) $ \sortedDict ->+          bench "fromAscList" $ whnf TMap.fromAscList [(w, length w) | w <- sortedDict]+      ]+  , env (lenTMap <$> dictAmEn) $ \dict ->+      bgroup "query"+        [ bench "isEmpty" (nf TMap.null dict)+        , bench "stringCount" (nf TMap.count dict)+        , bench "enumerate10" (nf (take 10 . TMap.toList) dict)+        , env randomStrs $ \qs ->+            bench "match" (nf (\dict' -> map (`TMap.member` dict') qs) dict) ]+  , env (lenTMap <$> dictAmEn) $ \dict ->+      bgroup "single-item"+        [ bench "insert1" (whnf (TMap.insert "wwwwwwwwwwwwwwww" 1) dict)+        , bench "insert2" (whnf (TMap.insert "cheese" 1) dict)+        , bench "delete1" (whnf (TMap.delete "wwwwwwwwwwwwwwww") dict)+        , bench "delete2" (whnf (TMap.delete "cheese") dict)+        , bench "alter1" (whnf (TMap.alter alterFn "wwwwwwwwwwwwwwww") dict)+        , bench "alter2" (whnf (TMap.alter alterFn "cheese") dict)+        ]+  , env (lenTMap <$> dictAmEn) $ \dict ->+      bgroup "traversal"+        [ bench "fmap" (nf (fmap (+3)) dict)+        , bench "foldMap" (nf (foldMap Sum) dict) ]+  , env (lenTMap <$> dictAmEn) $ \dictA ->+    env (lenTMap <$> dictBrEn) $ \dictB ->+    env (lenTMap <$> randomStrs) $ \dictSmall ->+      bgroup "combine"+        [ bench "union" (whnf (uncurry TMap.union) (dictA, dictB))+        , bench "intersection" (whnf (uncurry TMap.intersection) (dictA, dictB))+        , bench "difference" (whnf (uncurry TMap.difference) (dictA, dictB))+        , bench "append" (whnf (uncurry tmapProd) (dictSmall, dictSmall)) ]+  ]++alterFn :: Maybe Int -> Maybe Int+alterFn Nothing = Just 1000+alterFn (Just a) = if even a then Just a else Nothing++lenTMap :: (Ord c) => [[c]] -> TMap c Int+lenTMap dict = TMap.fromList [(w, length w) | w <- dict]++tmapProd :: (Ord c) => TMap c Int -> TMap c Int -> TMap c (Sum Int)+tmapProd t1 t2 = TMap.appendWith (*) (Sum <$> t1) (Sum <$> t2)++benchMap :: Benchmark+benchMap = bgroup "Map" +  [ bgroup "construction"+      [ env dictAmEnShuffled $ \dict ->+          bench "fromList" $ whnf Map.fromList [(w, length w) | w <- dict]+      , env (sort <$> dictAmEn) $ \sortedDict ->+          bench "fromAscList" $ whnf Map.fromAscList [(w, length w) | w <- sortedDict]+      ]+  , env (lenMap <$> dictAmEn) $ \dict ->+      bgroup "query"+        [ bench "isEmpty" (nf Map.null dict)+        , bench "stringCount" (nf Map.size dict)+        , bench "enumerate10" (nf (take 10 . Map.toList) dict)+        , env randomStrs $ \qs ->+            bench "match" (nf (\dict' -> map (`Map.member` dict') qs) dict) ]+  , env (lenMap <$> dictAmEn) $ \dict ->+      bgroup "single-item"+        [ bench "insert1" (whnf (Map.insert "wwwwwwwwwwwwwwww" 1) dict)+        , bench "insert2" (whnf (Map.insert "cheese" 1) dict)+        , bench "delete1" (whnf (Map.delete "wwwwwwwwwwwwwwww") dict)+        , bench "delete2" (whnf (Map.delete "cheese") dict)+        , bench "alter1" (whnf (Map.alter alterFn "wwwwwwwwwwwwwwww") dict)+        , bench "alter2" (whnf (Map.alter alterFn "cheese") dict)+        ]+  , env (lenMap <$> dictAmEn) $ \dict ->+      bgroup "traversal"+        [ bench "fmap" (nf (fmap (+3)) dict)+        , bench "foldMap" (nf (foldMap Sum) dict) ]+  , env (lenMap <$> dictAmEn) $ \dictA ->+    env (lenMap <$> dictBrEn) $ \dictB ->+    env (lenMap <$> randomStrs) $ \dictSmall ->+      bgroup "combine"+        [ bench "union" (whnf (uncurry Map.union) (dictA, dictB))+        , bench "intersection" (whnf (uncurry Map.intersection) (dictA, dictB))+        , bench "difference" (whnf (uncurry Map.difference) (dictA, dictB))+        , bench "append" (whnf (uncurry mapProd) (dictSmall, dictSmall)) ]+  ]++lenMap :: (Ord c) => [[c]] -> Map [c] Int+lenMap dict = Map.fromList [(w, length w) | w <- dict]++mapProd :: (Ord c) => Map [c] Int -> Map [c] Int -> Map [c] Int+mapProd m1 m2 =+  foldl' (Map.unionWith (+)) Map.empty+    [ prod1 s x m2 | (s,x) <- Map.toList m1 ]+  where+    prod1 s x m = Map.mapKeysMonotonic (s++) $ Map.map (x*) m
+ src/Data/Trie/Map.hs view
@@ -0,0 +1,45 @@+module Data.Trie.Map(+  -- * Type+  TMap(),+  -- * Queries+  match,+  lookup,+  member, notMember,+  null, count,+  keys, elems,+  -- * Construction+  empty, just,+  singleton,++  -- * Single item modification+  insertWith, insert,+  deleteWith, delete,++  adjust, revise, update, alter,++  -- * Combine+  --+  -- These functions behave in the same way as corresponding+  -- functions from "Data.Map".+  union, unionWith,+  intersection, intersectionWith,+  difference, differenceWith,+  appendWith,++  -- * Conversion+  toList, fromList,+  toAscList, fromAscList,+  toMap, fromMap,+  keysTSet, fromTSet,++  -- * Parsing+  toParser, toParser_, toParser__,++  -- * Traversing with keys+  traverseWithKey, mapWithKey, foldMapWithKey, foldrWithKey,+)+where++import           Prelude              hiding (lookup, null)++import           Data.Trie.Map.Hidden
+ src/Data/Trie/Map/Hidden.hs view
@@ -0,0 +1,515 @@+{-# LANGUAGE DeriveTraversable #-}+module Data.Trie.Map.Hidden(+  -- * Types+  TMap(..),+  -- * Queries+  match,+  lookup,+  member, notMember,+  null, count,+  keys, elems,+  -- * Construction+  empty, just,+  singleton,++  -- * Single item modification+  insertWith, insert,+  deleteWith, delete,++  adjust, revise, update, alter,++  -- * Combine+  union, unionWith,+  intersection, intersectionWith,+  difference, differenceWith,+  appendWith,++  -- * Conversion+  toList, fromList,+  toAscList, fromAscList,+  toMap, fromMap,+  keysTSet, fromTSet,++  -- * Parsing+  toParser, toParser_, toParser__,++  -- * Traversing with keys+  traverseWithKey, mapWithKey, foldMapWithKey, foldrWithKey,++  -- * Internals+  Node(..),+  foldTMap,+)+where++import           Prelude                hiding (lookup, null)++import           Data.Functor.Const+import           Data.Functor.Identity++import           Data.Semigroup++import           Control.Applicative    hiding (empty)+import qualified Control.Applicative    as Ap (empty)++import           Control.Monad++import qualified Data.Foldable          as F+import qualified Data.List              as List (foldl')+import           Data.Map.Strict        (Map)+import qualified Data.Map.Strict        as Map+import           Data.Maybe             (fromMaybe, isJust, isNothing)++import           Data.Trie.Set.Internal (TSet (..))+import qualified Data.Trie.Set.Internal as TSet++import           Control.DeepSeq++data Node c a r = Node !(Maybe a) !(Map c r)+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable)++instance (NFData c, NFData a, NFData r) => NFData (Node c a r) where+  rnf (Node a e) = rnf a `seq` rnf e++-- | Mapping from @[c]@ to @a@ implemented as a trie.+--   This type serves almost same purpose with @Map [c] a@,+--   but can be looked up more efficiently.+newtype TMap c a = TMap { getNode :: Node c a (TMap c a) }+  deriving (Eq, Ord)++instance (Show c, Show a) => Show (TMap c a) where+  showsPrec p t = showParen (p > 10) $ showString "fromList " . showsPrec 11 (toList t)++instance (NFData c, NFData a) => NFData (TMap c a) where+  rnf (TMap node) = rnf node++-- * Queries++-- | Perform matching against a @TMap@.+--+--   @match xs tmap@ returns two values. First value is the result of+--   'lookup'. Second value is another @TMap@, which holds mapping between+--   all pair of @ys@ and @b@, such that @tmap@ maps @(xs ++ ys)@ to @b@.+match :: (Ord c) => [c] -> TMap c a -> (Maybe a, TMap c a)+match []     t@(TMap (Node ma _)) = (ma, t)+match (c:cs)   (TMap (Node _  e)) =+  case Map.lookup c e of+    Nothing -> (Nothing, empty)+    Just t' -> match cs t'++-- | @lookup xs tmap@ returns @Just a@ if @tmap@ contains mapping+--   from @xs@ to @a@, and returns @Nothing@ if not.+lookup :: (Ord c) => [c] -> TMap c a -> Maybe a+lookup cs = fst . match cs++member, notMember :: (Ord c) => [c] -> TMap c a -> Bool+member cs = isJust . lookup cs+notMember cs = isNothing . lookup cs++-- | Tests if given map is empty.+null :: TMap c a -> Bool+null (TMap (Node ma e)) = isNothing ma && Map.null e+{- Ensure all @TMap@ values exposed to users have no+   redundant node. -}++-- | Returns number of entries.+--+--   Note that this operation takes O(number of nodes),+--   unlike O(1) of 'Map.size'.+count :: TMap c a -> Int+count = F.length++-- | Returns list of key strings, in ascending order.+keys :: TMap c a -> [[c]]+keys = foldTMap keys'+  where+    keys' (Node ma e) =+      [ [] | isJust ma ] +++      [ c:cs' | (c,css') <- Map.toList e, cs' <- css' ]++-- | Returns list of values, in ascending order by its key.+elems :: TMap c a -> [a]+elems = F.toList++-- * Construction++-- | Empty @TMap@.+empty :: TMap c a+empty = TMap (Node Nothing Map.empty)++-- | @TMap@ which contains only one entry from the empty string to @a@.+just :: a -> TMap c a+just a = TMap (Node (Just a) Map.empty)++-- | @singleton xs a@ is a @TMap@ which contains only one entry+--   from @xs@ to @a@.+singleton :: [c] -> a -> TMap c a+singleton cs a0 = foldr cons (just a0) cs++cons :: c -> TMap c a -> TMap c a+cons c t = TMap (Node Nothing (Map.singleton c t))++-- * Single-item modification++-- | Inserts an entry of key and value pair.+--+--   Already existing value will be overwritten, i.e.+--   > insert = insertWith (const a)+insert :: (Ord c) => [c] -> a -> TMap c a -> TMap c a+insert cs a = revise (const a) cs++-- | Deletes an entry with given key.+--+--   > delete = update (const Nothing)+delete :: (Ord c) => [c] -> TMap c a -> TMap c a+delete = update (const Nothing)++-- | @insertWith op xs a tmap@ inserts an key (@xs@) and value (@a@) pair+--   to the @tmap@. If @tmap@ already has an entry with key equals to+--   @xs@, its value @b@ is replaced with @op a b@.+--+--   > insertWith op cs a = revise (maybe a (op a)) cs+insertWith :: (Ord c) => (a -> a -> a) -> [c] -> a -> TMap c a -> TMap c a+insertWith f cs a = revise (maybe a (f a)) cs++-- | Deletes an entry with given key, conditionally.+--+--   @deleteWith f xs b@ looks up an entry with key @xs@, and if such entry+--   is found, evaluate @f b a@ with its value @a@. If it returned @Nothing@,+--   the entry is deleted. Otherwise, if it returned @Just a'@, the value of+--   the entry is replaced with @a'@.+--+--   > deleteWith f cs b = update (f b) cs+deleteWith :: (Ord c) => (b -> a -> Maybe a) -> [c] -> b -> TMap c a -> TMap c a+deleteWith f cs b = update (f b) cs++-- | Apply a function to the entry with given key.+adjust :: (Ord c) => (a -> a) -> [c] -> TMap c a -> TMap c a+adjust f = F.foldr step base+  where+    base (TMap (Node ma e)) = TMap (Node (f <$> ma) e)+    step x xs (TMap (Node ma e)) =+      let e' = Map.adjust xs x e+      in TMap (Node ma e')+{-# INLINE adjust #-}++-- | Apply a function @f@ to the entry with given key. If there is no such+--   entry, insert an entry with value @f Nothing@.+revise :: (Ord c) => (Maybe a -> a) -> [c] -> TMap c a -> TMap c a+revise f = fst . F.foldr step (base, just (f Nothing))+  where+    base (TMap (Node ma e)) = TMap (Node (Just (f ma)) e)+    step x (inserter', xs') =+      let inserter (TMap (Node ma e)) =+            let e' = Map.insertWith (const inserter') x xs' e+            in TMap (Node ma e')+      in (inserter, cons x xs')+{-# INLINE revise #-}++-- | Apply a function @f@ to the entry with given key. If @f@ returns+--   @Nothing@, that entry is deleted.+update :: (Ord c) => (a -> Maybe a) -> [c] -> TMap c a -> TMap c a+update f cs = fromMaybe empty . update_ f cs+{-# INLINE update #-}++update_ :: (Ord c) => (a -> Maybe a) -> [c] -> TMap c a -> Maybe (TMap c a)+update_ f = F.foldr step base+  where+    base (TMap (Node ma e)) =+      let ma' = ma >>= f+      in if isNothing ma' && Map.null e+           then Nothing+           else Just $ TMap (Node ma' e)+    step x xs (TMap (Node ma e)) =+      let e' = Map.update xs x e+      in if isNothing ma && Map.null e'+           then Nothing+           else Just $ TMap (Node ma e')+{-# INLINE update_ #-}++-- | Apply a function @f@ to the entry with given key. This function @alter@+--   is the most generic version of 'adjust', 'revise', 'update'.+-- +--   * You can insert new entry by returning @Just a@ from @f Nothing@.+--   * You can delete existing entry by returning @Nothing@ from+--     @f (Just a)@.+--+--   This function always evaluates @f Nothing@ in addition to determine+--   operation applied to given key.+--   If you never use `alter` on a missing key, consider using 'update' instead.+alter :: (Ord c) => (Maybe a -> Maybe a) -> [c] -> TMap c a -> TMap c a+alter f =+  case f Nothing of+    Nothing -> update (f . Just)+    Just f0 -> \cs -> fromMaybe empty . alter_ f f0 cs+{-# INLINE alter #-}++alter_ :: (Ord c) => (Maybe a -> Maybe a) -> a -> [c] -> TMap c a -> Maybe (TMap c a)+alter_ f f0 = fst . F.foldr step (base, just f0)+  where+    base (TMap (Node ma e)) =+      let ma' = f ma+      in if isNothing ma' && Map.null e+           then Nothing+           else Just $ TMap (Node ma' e)+    step x (alterer', xs') =+      let alterer (TMap (Node ma e)) =+            let e' = Map.alter (maybe (Just xs') alterer') x e+            in if isNothing ma && Map.null e'+                 then Nothing+                 else Just $ TMap (Node ma e')+      in (alterer, cons x xs')+{-# INLINE alter_ #-}++-- * Combine+union :: (Ord c) => TMap c a -> TMap c a -> TMap c a+union = unionWith const++unionWith :: (Ord c) => (a -> a -> a) -> TMap c a -> TMap c a -> TMap c a+unionWith f = go+  where+    go (TMap (Node mat et)) (TMap (Node mau eu)) =+      let maz = case (mat, mau) of+            (Nothing, Nothing) -> Nothing+            (Just at, Nothing) -> Just at+            (Nothing, Just au) -> Just au+            (Just at, Just au) -> Just (f at au)+          ez = Map.unionWith go et eu+      in TMap (Node maz ez)++intersection :: (Ord c) => TMap c a -> TMap c b -> TMap c a+intersection = intersectionWith (\a _ -> Just a)++intersectionWith :: (Ord c) =>+  (a -> b -> Maybe r) -> TMap c a -> TMap c b -> TMap c r+intersectionWith f x y = fromMaybe empty $ go x y+  where+    go (TMap (Node ma ex)) (TMap (Node mb ey)) =+      if isNothing mr && Map.null ez+        then Nothing+        else Just $ TMap (Node mr ez)+      where+        mr = do a <- ma+                b <- mb+                f a b+        emz = Map.intersectionWith go ex ey+        ez = Map.mapMaybe id emz++difference :: (Ord c) => TMap c a -> TMap c b -> TMap c a+difference = differenceWith (\_ _ -> Nothing)++differenceWith :: (Ord c) =>+  (a -> b -> Maybe a) -> TMap c a -> TMap c b -> TMap c a+differenceWith f x y = fromMaybe empty $ go x y+  where+    go (TMap (Node ma ex)) (TMap (Node mb ey)) =+      if isNothing mr && Map.null ez+        then Nothing+        else Just $ TMap (Node mr ez)+      where+        mr = case (ma, mb) of+          (Nothing, _)       -> Nothing+          (Just a,  Nothing) -> Just a+          (Just a,  Just b)  -> f a b+        ez = Map.differenceWith go ex ey++{- |+Make new @TMap@ from two @TMap@s. Constructed @TMap@+has keys which are concatenation of any combination from+two input maps.++Corresponding values for these keys are combined with given function+of type @(x -> y -> z)@. If two different concatenations yield+a same key, corresponding values for these keys are combined with+a 'Semigroup' operation @<>@.++There is no guarantees on which order duplicate values are combined with @<>@.+So it must be commutative semigroup to get a stable result.++===== Example++> let x = fromList [("a", 1), ("aa", 2)]     :: TMap Char (Sum Int)+>     y = fromList [("aa", 10), ("aaa", 20)] :: TMap Char (Sum Int)+>+> appendWith (*) x y =+>   fromList [ ("aaa", 1 * 10)+>            , ("aaaa", 1 * 20 + 2 * 10)+>            , ("aaaaa", 2 * 20) ]++-}+appendWith :: (Ord c, Semigroup z) => (x -> y -> z) ->+  TMap c x -> TMap c y -> TMap c z+appendWith f x y =+  if null y+    then empty+    else go x+  where+    go (TMap (Node Nothing e)) =+      let e' = Map.map go e+      in TMap (Node Nothing e')+    go (TMap (Node (Just ax) e)) =+      let TMap (Node maz e') = fmap (f ax) y+          e'' = Map.map go e+          e''' = Map.unionWith (unionWith (<>)) e' e''+      in TMap (Node maz e''')++-- * Instances++instance Functor (TMap c) where+  fmap f = go+    where+      go (TMap (Node ma e)) = TMap (Node (fmap f ma) (fmap go e))++instance Foldable (TMap c) where+  foldMap f = go+    where+      go (TMap (Node ma e)) = case ma of+        Nothing -> foldMap go e+        Just a  -> f a `mappend` foldMap go e++instance Traversable (TMap c) where+  traverse f = go+    where+      go (TMap (Node a e)) = TMap <$> (Node <$> traverse f a <*> traverse go e)++-- | 'unionWith'-based+instance (Ord c, Semigroup a) => Semigroup (TMap c a) where+  (<>) = unionWith (<>)+  stimes n = fmap (stimes n)++-- | 'unionWith'-based+instance (Ord c, Semigroup a) => Monoid (TMap c a) where+  mempty = empty+  mappend = (<>)++-- * Conversion++toList :: TMap c a -> [([c], a)]+toList = foldrWithKey (\k a r -> (k,a) : r) []++fromList :: Ord c => [([c], a)] -> TMap c a+fromList = List.foldl' (flip (uncurry insert)) empty++toAscList :: TMap c a -> [([c], a)]+toAscList = toList++fromAscList :: Eq c => [([c], a)] -> TMap c a+fromAscList [] = empty+fromAscList [(cs, a)] = singleton cs a+fromAscList pairs =+  let (ma, gs) = group_ pairs+      e = Map.fromDistinctAscList $ map (fmap fromAscList) gs+  in TMap (Node ma e)++group_ :: Eq c => [([c], a)] -> (Maybe a, [ (c, [ ([c], a) ]) ] )+group_ = foldr step (Nothing, [])+  where+    step ([], a) (ma, gs) = (ma <|> Just a, gs)+    step (c:cs, a) (ma, gs) = case gs of+      (d,ps'):rest | c == d  -> (ma, (d, (cs,a):ps'):rest)+      _            -> (ma, (c, [(cs,a)]):gs)++toMap :: TMap c a -> Map [c] a+toMap = Map.fromDistinctAscList . toAscList++fromMap :: (Eq c) => Map [c] a -> TMap c a+fromMap = fromAscList . Map.toAscList++keysTSet :: TMap c a -> TSet c+keysTSet = foldTMap keysTSet'+  where+    keysTSet' (Node ma e) =+      TSet (TSet.Node (isJust ma) e)++fromTSet :: ([c] -> a) -> TSet c -> TMap c a+fromTSet f = go []+  where+    go q (TSet (TSet.Node a e)) =+      let e' = Map.mapWithKey (\c -> go (c:q)) e+          a' = if a then Just (f (reverse q)) else Nothing+      in TMap (Node a' e')++-- * Parsing++toParser :: Alternative f =>+     (c -> f c') -- ^ char+  -> f eot       -- ^ eot+  -> TMap c a -> f ([c'], a)+toParser f eot = foldTMap toParser'+  where+    toParser' (Node ma e) =+      maybe Ap.empty (\a -> ([], a) <$ eot) ma <|>+      F.asum [ consFst <$> f c <*> p' | (c, p') <- Map.toAscList e ]++    consFst c (cs, a) = (c:cs, a)++toParser_ :: Alternative f =>+     (c -> f c') -- ^ char+  -> f eot       -- ^ eot+  -> TMap c a -> f a+toParser_ f eot = foldTMap toParser'+  where+    toParser' (Node ma e) =+      maybe Ap.empty (<$ eot) ma <|>+      F.asum [ f c *> p' | (c, p') <- Map.toAscList e ]++toParser__ :: Alternative f =>+     (c -> f c') -- ^ char+  -> f eot       -- ^ eot+  -> TMap c a -> f ()+toParser__ f eot = void . toParser_ f eot++-- * Traversing with keys++-- | Same semantics to following defintion, but have+--   more efficient implementation.+--+-- > traverseWithKey f = fmap fromAscList .+-- >                     traverse (\(cs,a) -> (,) cs <$> f cs a) .+-- >                     toAscList+traverseWithKey :: (Applicative f) =>+  ([c] -> a -> f b) -> TMap c a -> f (TMap c b)+traverseWithKey f = go []+  where+    go q (TMap (Node ma e)) =+      let step c = go (c : q)+          e' = Map.traverseWithKey step e+          mb = maybe (pure Nothing)+                     (\a -> Just <$> f (reverse q) a)+                     ma+      in TMap <$> (Node <$> mb <*> e')++-- | Same semantics to following defintion, but have+--   more efficient implementation.+--+-- > traverseWithKey f = fromAscList .+-- >                     map (\(cs,a) -> (cs,  f cs a)) .+-- >                     toAscList+mapWithKey :: ([c] -> a -> b) -> TMap c a -> TMap c b+mapWithKey f = runIdentity . traverseWithKey (\k a -> Identity (f k a))++-- | Same semantics to following defintion, but have+--   more efficient implementation.+--+-- > foldMapWithKey f = foldMap (uncurry f) . toAscList+foldMapWithKey :: (Monoid r) => ([c] -> a -> r) -> TMap c a -> r+foldMapWithKey f = getConst . traverseWithKey (\k a -> Const (f k a))++-- | Same semantics to following defintion, but have+--   more efficient implementation.+--+-- > foldrWithKey f z = foldr (uncurry f) z . toAscList+foldrWithKey :: ([c] -> a -> r -> r) -> r -> TMap c a -> r+foldrWithKey f z (TMap (Node ma e)) =+  case ma of+    Nothing -> r+    Just a  -> f [] a r+  where+    r = Map.foldrWithKey (\c subTrie s ->+          foldrWithKey (f . (c:)) s subTrie) z e++-- * Other operations++foldTMap :: (Node c a r -> r) -> TMap c a -> r+foldTMap f = go+  where go (TMap node) = f (fmap go node)
+ src/Data/Trie/Map/Internal.hs view
@@ -0,0 +1,39 @@+{- |+This module exposes internal representation of @TMap@.+TMap has one invariant condition:++* Subtrees of an @TMap@ should not be empty.++For example, consider following tree structure which is valid:++  > > fromList [("a",1), ("aa", 2), ("bc", 3)]+  > Root+  >   'a' -> 1+  >     'a' -> 2+  >   'b' ->+  >     'c' -> 3++Adding redundant node which represents empty map does not change+what an @TMap@ represents.++  > Root+  >   'a' -> 1+  >     'a' -> 2+  >   'b' ->+  >     'c' -> 3+  >   'd' ->+  >     'e' ->+  >       'f' ->++But such @TMap@ should not exist because it confuses @Eq@ and @Ord@+instances and @null@ function.+-}+module Data.Trie.Map.Internal(+  -- * Types+  TMap(..),+  Node(..),+  foldTMap,+)+where++import Data.Trie.Map.Hidden
+ src/Data/Trie/Set.hs view
@@ -0,0 +1,50 @@+{-|+This module provides a type @TSet c@, which is a set of list of some+characters. It serves almost same purpose to @Set [c]@, and functions of+this module mirrors functions with same name from "Data.Set" module.++The advantages to use this module over "Data.Set" are:++* Faster 'member'.+* Partial match provided by 'beginWith' function.+* Efficient 'append', 'prefixes', and 'suffixes' functions.++But notice for some disadvantages:++* Some operations are slower than @Set [c]@. Especially, 'count' is much+  much slower than 'Set.size' (because @Set.size@ is already recorded in the+  data structure). Consider @TSet.count@ be like @length@ of list.+* Constructed @TSet c@ from a list of lists @[[c]]@ do not share each member+  lists with original list unlike @Set [c]@ does. This means holding both+  @TSet c@ and @[[c]]@ in memory consumes much more memory than @Set [c]@ and+  @[[c]]@.++-}+module Data.Trie.Set(+  -- * Types+  TSet(),+  -- * Queries+  member, notMember,+  beginWith,+  null, count, enumerate,+  foldMap, foldr, foldl', +  -- * Construction+  empty, epsilon,+  singleton,+  insert, delete,+  -- * Combine+  union, intersection, difference,+  append,+  -- * Other operations+  prefixes, suffixes, infixes,+  -- * Conversion+  fromList, toList,+  fromAscList, toAscList,+  fromSet, toSet,+  -- * Parsing+  toParser, toParser_+)+where++import Prelude hiding (foldr, foldMap, null)+import Data.Trie.Set.Hidden
+ src/Data/Trie/Set/Hidden.hs view
@@ -0,0 +1,304 @@+{-# LANGUAGE DeriveTraversable #-}+module Data.Trie.Set.Hidden(+  -- * Types+  TSet(..),+  -- * Queries+  member, notMember,+  beginWith,+  null, count, enumerate,+  foldr, foldMap, foldl',+  -- * Construction+  empty, epsilon,+  singleton,+  insert, delete,+  -- * Combine+  union, intersection, difference,+  append,+  -- * Other operations+  prefixes, suffixes, infixes,+  -- * Conversion+  fromList, toList,+  fromAscList, toAscList,+  fromSet, toSet,+  -- * Parsing+  toParser, toParser_,+  -- * Low-level operation+  Node(..),+  foldTSet, paraTSet+)+where++import Prelude hiding (foldMap, foldr, null)++import           Control.Applicative hiding (empty)+import qualified Control.Applicative as Ap++import           Data.Semigroup+import qualified Data.Foldable   as F+import qualified Data.List       as List (foldr, foldl')+import           Data.Maybe      (fromMaybe)+import           Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import           Data.Set        (Set)+import qualified Data.Set        as Set+import           Control.Arrow ((&&&))++import Control.DeepSeq++data Node c r = Node !Bool !(Map c r)+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable)++instance (NFData c, NFData r) => NFData (Node c r) where+  rnf (Node a e) = rnf a `seq` rnf e++newtype TSet c = TSet { getNode :: Node c (TSet c) }+  deriving (Eq, Ord)++instance Show c => Show (TSet c) where+  showsPrec p t = showParen (p > 10) $+    showString "fromList " . showsPrec 11 (enumerate t)++instance (NFData c) => NFData (TSet c) where+  rnf (TSet node) = rnf node++{-++The canonical Monoid instance could be (epsilon, append),+but here I choose (empty, union) to align to Set instance.+Semigroup instance must follow how Monoid is defined.++-}++-- | Semigroup(union)+instance (Ord c) => Semigroup (TSet c) where+  (<>) = union+  stimes = stimesIdempotent++-- | Monoid(empty, union)+instance (Ord c) => Monoid (TSet c) where+  mempty = empty+  mappend = (<>)++-- * Queries+member :: (Ord c) => [c] -> TSet c -> Bool+member [] (TSet (Node a _)) = a+member (c:cs) (TSet (Node _ e)) =+  case Map.lookup c e of+    Nothing -> False+    Just t' -> member cs t'++notMember :: (Ord c) => [c] -> TSet c -> Bool+notMember cs = not . member cs++-- | @beginWith t xs@ returns new TSet @t'@ which contains+--   all string @ys@ such that @t@ contains @xs ++ ys@.+beginWith :: (Ord c) => TSet c -> [c] -> TSet c+beginWith t       []               = t+beginWith (TSet (Node _ e)) (c:cs) = +  case Map.lookup c e of+    Nothing -> empty+    Just t' -> beginWith t' cs++null :: TSet c -> Bool+null (TSet (Node a e)) = not a && Map.null e++-- | Returns number of elements. @count@ takes O(number of nodes)+--   unlike 'Set.size' which is O(1).+count :: TSet c -> Int+count = foldTSet count'+  where+    count' (Node a e) =+      (if a then 1 else 0) + sum e++-- | List of all elements.+enumerate :: TSet c -> [[c]]+enumerate = foldr (:) []++{-+from this post by u/foBrowsing:+  https://www.reddit.com/r/haskell/comments/8krv31/how_to_traverse_a_trie/dzaktkn/+-}+foldr :: ([c] -> r -> r) -> r -> TSet c -> r+foldr f z (TSet (Node a e))+  | a         = f [] r+  | otherwise = r+  where+    r = Map.foldrWithKey (\x tr xs -> foldr (f . (:) x) xs tr) z e++foldMap :: (Monoid r) => ([c] -> r) -> TSet c -> r+foldMap f (TSet (Node a e))+  | a         = f [] `mappend` r+  | otherwise = r+  where+    r = Map.foldMapWithKey (\c subTrie ->+          foldMap (f . (c :)) subTrie) e++foldl' :: (r -> [c] -> r) -> r -> TSet c -> r+foldl' f z = List.foldl' f z . enumerate++-- * Construction+empty :: TSet c+empty = TSet (Node False Map.empty)++-- | @epsilon = singleton []@+epsilon :: TSet c+epsilon = TSet (Node True Map.empty)++singleton :: [c] -> TSet c+singleton = List.foldr cons epsilon++cons :: c -> TSet c -> TSet c+cons c t = TSet (Node False (Map.singleton c t))++insert :: (Ord c, Foldable f) => f c -> TSet c -> TSet c+insert = fst . F.foldr f (b, epsilon)+  where+    b (TSet (Node _ e)) = TSet (Node True e)+    f x (inserter', xs') =+      let inserter (TSet (Node a e)) =+            let e' = Map.insertWith (const inserter') x xs' e+            in TSet (Node a e')+          xs = cons x xs'+      in (inserter, xs)++delete :: (Ord c, Foldable f) => f c -> TSet c -> TSet c+delete cs t = fromMaybe empty $ delete_ cs t++delete_ :: (Ord c, Foldable f) => f c -> TSet c -> Maybe (TSet c)+delete_ = F.foldr f b+  where+    b (TSet (Node _ e)) =+      if Map.null e then Nothing else Just (TSet (Node False e))+    f x xs (TSet (Node a e)) =+      let e' = Map.update xs x e+          t' = TSet (Node a e')+      in if null t' then Nothing else Just t'++-- * Combine+union :: (Ord c) => TSet c -> TSet c -> TSet c+union (TSet (Node ax ex)) (TSet (Node ay ey)) = TSet (Node az ez)+  where+    az = ax || ay+    ez = Map.unionWith union ex ey++intersection :: (Ord c) => TSet c -> TSet c -> TSet c+intersection x y = fromMaybe empty $ intersection_ x y++intersection_ :: (Ord c) => TSet c -> TSet c -> Maybe (TSet c)+intersection_ (TSet (Node ax ex)) (TSet (Node ay ey)) =+    if not az && Map.null ez+      then Nothing+      else Just $ TSet (Node az ez)+  where+    az = ax && ay+    emz = Map.intersectionWith intersection_ ex ey+    ez = Map.mapMaybe id emz++difference :: (Ord c) => TSet c -> TSet c -> TSet c+difference x y = fromMaybe empty $ difference_ x y++difference_ :: (Ord c) => TSet c -> TSet c -> Maybe (TSet c)+difference_ (TSet (Node ax ex)) (TSet (Node ay ey)) =+    if not az && Map.null ez+      then Nothing+      else Just $ TSet (Node az ez)+  where+    az = ax > ay+    ez = Map.differenceWith difference_ ex ey++append :: (Ord c) => TSet c -> TSet c -> TSet c+append _ y | null y = empty+append (TSet (Node ax ex)) y = f (TSet (Node False ez))+  where+    ez = Map.map (`append` y) ex+    f = if ax then union y else id++-- * Other operations++prefixes :: TSet c -> TSet c+prefixes t | null t    = empty+           | otherwise = foldTSet prefixes' t+  where+    prefixes' (Node _ e) = TSet (Node True e)++suffixes :: (Ord c) => TSet c -> TSet c+suffixes = paraTSet suffixes'+  where+    suffixes' nx = union (TSet (fst <$> nx)) (F.foldMap snd nx)++infixes :: (Ord c) => TSet c -> TSet c+infixes = suffixes . prefixes++-- * Conversion+toList, toAscList :: TSet c -> [[c]]+toList = enumerate+toAscList = enumerate++fromList :: (Ord c) => [[c]] -> TSet c+fromList = List.foldl' (flip insert) empty++fromAscList :: (Eq c) => [[c]] -> TSet c+fromAscList [] = empty+fromAscList [cs] = singleton cs+fromAscList xs =+  let (a,es) = groupStrs xs+      e' = Map.fromDistinctAscList $ map (fmap fromAscList) es+  in TSet (Node a e')++groupStrs :: (Eq c) => [[c]] -> (Bool, [(c,[[c]])])+groupStrs = List.foldr pushStr (False, [])+  where+    pushStr [] (_, gs) = (True, gs)+    pushStr (c:cs) (hasNull, gs) =+      case gs of+        (d, dss):rest | c == d -> (hasNull, (d, cs:dss):rest)+        _                      -> (hasNull, (c, [cs]):gs)++toSet :: TSet c -> Set [c]+toSet = Set.fromDistinctAscList . enumerate++fromSet :: (Eq c) => Set [c] -> TSet c+fromSet = fromAscList . Set.toAscList++-- * Parsing++-- | Construct a \"parser\" which recognizes member strings+--   of a TSet.+--+--   * @char@ constructs a parser which recognizes a character.+--   * @eot@ recognizes the end of a token.+toParser :: (Alternative f) =>+  (c -> f a) -- ^ char+  -> f b     -- ^ eot+  -> TSet c -> f [a]+toParser char eot = foldTSet enumerateA'+  where+    enumerateA' (Node a e) =+      (if a then [] <$ eot else Ap.empty) <|>+      F.asum [ (:) <$> char c <*> as | (c, as) <- Map.toAscList e ]++-- | Construct a \"parser\" which recognizes member strings+--   of a TSet.+--   It discards the information which string it is recognizing.+--+--   * @char@ constructs a parser which recognizes a character.+--   * @eot@ recognizes the end of a token.+toParser_ :: (Alternative f) =>+  (c -> f a) -- ^ char+  -> f b     -- ^ eot+  -> TSet c -> f ()+toParser_ char eot = foldTSet enumerateA'+  where+    enumerateA' (Node a e) =+      (if a then () <$ eot else Ap.empty) <|>+      F.asum [ char c *> as | (c, as) <- Map.toAscList e ]++----------------------++foldTSet :: (Node c r -> r) -> TSet c -> r+foldTSet f = go+  where go (TSet node) = f (fmap go node)++paraTSet :: (Node c (TSet c, r) -> r) -> TSet c -> r+paraTSet f = go+  where go (TSet node) = f (fmap (id &&& go) node)
+ src/Data/Trie/Set/Internal.hs view
@@ -0,0 +1,37 @@+{- |+This module exposes internal representation of @TSet@.+TSet has one invariant condition:++* Subtrees of an @TSet@ should not be empty.++For example, consider following tree structure which is valid:++  > > fromList ["a", "aa", "bc"]+  > Root -> False+  >   'a' -> True+  >     'a' -> True+  >   'b' -> False+  >     'c' -> True++Adding redundant node which represents empty set does not change+what an @TSet@ represents.++  > Root -> False+  >   'a' -> True+  >     'a' -> True+  >   'b' -> False+  >     'c' -> True+  >   'd' -> False+  >     'e' -> False+  >       'f' -> False++But such @TSet@ should not exist because it confuses @Eq@ and @Ord@ instances and @null@ function.+-}+module Data.Trie.Set.Internal(+  TSet(..),+  Node(..),+  foldTSet, paraTSet+)+where++import Data.Trie.Set.Hidden
+ test/Common.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE DeriveFunctor #-}+module Common where++import           Test.QuickCheck++import           Control.Applicative+import           Data.List          (tails)+import           Data.Map           (Map)+import qualified Data.Map.Strict as Map++-- Alphabet-only Char+newtype C = C { unC :: Char }+  deriving (Eq, Ord)++instance Show C where+  showsPrec p (C c) = showsPrec p c+  showList cs = showList (map unC cs)++instance Arbitrary C where+  arbitrary = sized $ \n ->+      let m = sqrti (max 1 n)+      in C <$> elements (take m "ABCDEFGHIJKLMNOPQRSTUVWXYZ")++-- Char which is either '0' or '1', always+newtype B = B { unB :: Char }+  deriving (Eq, Ord)++instance Show B where+    showsPrec p (B b) = showsPrec p b+    showList bs = showList (map unB bs)++instance Arbitrary B where+  -- Distribution is biased+  -- (To increase probability of randomly generated two [B]+  --  coincide.)+  arbitrary = B <$> elements "00001"++sqrti :: Int -> Int+sqrti = floor . (sqrt :: Double -> Double) . fromIntegral++randomPair :: [a] -> Gen (a,a)+randomPair as =+  let mkP [] = []+      mkP [_] = []+      mkP (x:xs) = (,) x <$> xs+      ps = tails as >>= mkP+  in elements ps++data Once a = Once { getDefault :: a, getVariants :: [a] }+  deriving (Functor)++instance Applicative Once where+    pure a = Once a []+    Once f fs <*> Once a as = Once (f a) (fs <*> pure a <|> f <$> as)++shrinkTraversableBy :: (Traversable t) => (a -> [a]) -> t a -> [t a]+shrinkTraversableBy f = getVariants . traverse (\a -> Once a (f a))++shrinkMapBy :: (Ord k) => (a -> [a]) -> Map k a -> [Map k a]+shrinkMapBy f = map Map.fromList . shrinkList f' . Map.toList+  where f' (k, a) = (,) k <$> f a
+ test/Data/Trie/Map/Gen.hs view
@@ -0,0 +1,51 @@+module Data.Trie.Map.Gen(+  C(..),+  TMap'(..),+  TMap''(..),+  genTMap,+  validTMap+) where++import           Test.QuickCheck hiding (shrinkMapBy)++import           Data.Maybe+import qualified Data.Map as Map++import           Data.Trie.Map+import           Data.Trie.Map.Internal+import           Common++newtype TMap' = TMap' (TMap C Int)++instance Show TMap' where+  show (TMap' t) = show t++instance Arbitrary TMap' where+  arbitrary = TMap' <$> genTMap +  shrink (TMap' t) = TMap' <$> shrinkTMap t++newtype TMap'' = TMap'' (TMap B Int)++instance Show TMap'' where+  show (TMap'' t) = show t++instance Arbitrary TMap'' where+  arbitrary = TMap'' <$> genTMap +  shrink (TMap'' t) = TMap'' <$> shrinkTMap t++genTMap :: (Ord c, Arbitrary c, Arbitrary a) => Gen (TMap c a)+genTMap = fromList <$> arbitrary++shrinkTMap :: (Ord c, Arbitrary c, Arbitrary a) => TMap c a -> [TMap c a]+shrinkTMap (TMap (Node ma e)) = filter validTMap $ +  [ TMap (Node Nothing e) | Just _ <- [ma] ] +++  [ TMap (Node (Just a') e) | Just a <- [ma], a' <- shrink a ] +++  [ TMap (Node ma e') | e' <- shrinkMapBy shrinkTMap e ]++validTMap :: TMap c a -> Bool+validTMap = snd . foldTMap step+  where+    step (Node ma e) =+      let isEmpty = isNothing ma && all fst e+          isValid = (not isEmpty || Map.null e) && all snd e+      in (isEmpty, isValid)
+ test/Data/Trie/MapSpec.hs view
@@ -0,0 +1,124 @@+module Data.Trie.MapSpec(+  spec+) where++import           Test.Hspec+import           Test.QuickCheck++import           Data.List (sortBy, foldl')+import           Data.Ord+import           Data.Map            (Map)+import qualified Data.Map            as Map+import           Data.Semigroup++import           Data.Trie.Map     as T+import           Data.Trie.Map.Gen+import qualified Data.Trie.Set     as TSet+import           Data.Trie.Set.Gen++spec :: Spec+spec = do+  specify "toList empty = []" $+    toList (empty :: TMap C Int) `shouldSatisfy` Prelude.null+  specify "toList (just a) = [([], a)]" $+    property $ \a -> toList (just a :: TMap C Int) === [([], a)]+  specify "toList (singleton k a) = [(k,a)]" $+    property $ \k a -> toList (singleton k a :: TMap C Int) === [(k,a)]+  specify "toAscList . fromList = Map.toAscList . Map.fromList" $+    property $ \strs -> toAscList (fromList strs :: TMap C Int) ==+                        (Map.toAscList . Map.fromList) strs+  specify "fromAscList . sortBy (comparing fst) = fromList" $+    property $ \strs -> fromAscList (sortBy (comparing fst) strs) ==+                        (fromList strs :: TMap C Int)+  specify "fromMap . Map.fromList = fromList" $+    property $ \strs -> fromMap (Map.fromList strs) ==+                        (fromList strs :: TMap C Int)+  specify "null . toList = null" $+    property $ \(TMap' t) -> Prelude.null (toList t) === T.null t+  specify "length . toList = count" $+    property $ \(TMap' t) -> length (toList t) === count t+  specify "keys = map fst . toList" $+    property $ \(TMap' t) -> keys t == map fst (toList t)+  specify "elems = map snd . toList" $+    property $ \(TMap' t) -> elems t == map snd (toList t)+  specify "keysTSet = TSet.fromAscList . keys" $+    property $ \(TMap' t) -> keysTSet t == TSet.fromAscList (keys t)+  specify "fromTSet id = fromAscList . map (\\k -> (k,k)) . TSet.toAscList" $+    property $ \(TSet' t) ->+      fromTSet id t == fromAscList (map (\k -> (k,k)) (TSet.toAscList t))+  +  specify "member k t = (k `Map.member` toMap t)" $+    property $ \(TMap'' t) ->+      let strMap = toMap t+      in property $ \str -> member str t == Map.member str strMap+  specify "lookup k t = (k `Map.lookup` toMap t)" $+    property $ \(TMap'' t) ->+      let strMap = toMap t+      in property $ \str -> T.lookup str t == Map.lookup str strMap+  specify "lookup (k ++ l) t == lookup l (snd (match k t))" $+    property $ \k l (TMap'' t) ->+      T.lookup (k ++ l) t == T.lookup l (snd (T.match k t))++  specify "toMap (insert k 1 a) = Map.insert k 1 (toMap a)" $+    property $ \k (TMap'' a) ->+      toMap (insert k 1 a) == Map.insert k 1 (toMap a)+  specify "toMap (delete k a) = Map.delete k (toMap a)" $+    property $ \k (TMap'' a) ->+      toMap (delete k a) == Map.delete k (toMap a)+  specify "toMap (insertWith (+) k 1 a) = Map.insertWith (+) k 1 (toMap a)" $+    property $ \k (TMap'' a) ->+      toMap (insertWith (+) k 1 a) ==+      Map.insertWith (+) k 1 (toMap a)+  let sub b a = if a < b then Nothing else Just (a - b)+  specify "toMap (deleteWith sub k 1 a) = Map.update (sub 1) k (toMap a)" $+    property $ \k (TMap'' a) ->+      toMap (deleteWith sub k 1 a) ==+      Map.update (sub 1) k (toMap a)+  specify "toMap (adjust (*2) k a) = Map.adjust (*2) k (toMap a)" $+    property $ \k (TMap'' a) ->+      toMap (adjust (*2) k a) == Map.adjust (*2) k (toMap a)+  let alterer Nothing = Just 100+      alterer (Just a) | odd a = Nothing+                       | otherwise = Just (a `div` 2)+  specify "toMap (alter alterer k a) = Map.alter alterer k (toMap a)" $+    property $ \k (TMap'' a) ->+      toMap (alter alterer k a) == Map.alter alterer k (toMap a)++  specify "toMap (union a b) = Map.union (toMap a) (toMap b)" $+    property $ \(TMap' a) (TMap' b) ->+      toMap (union a b) == Map.union (toMap a) (toMap b)+  specify "toMap (unionWith f a b) = Map.unionWith f (toMap a) (toMap b)" $+    property $ \(Fn2 f) (TMap' a) (TMap' b) ->+      toMap (unionWith f a b) == Map.unionWith f (toMap a) (toMap b)+  specify "toMap (intersection a b) = Map.intersection (toMap a) (toMap b)" $+    property $ \(TMap' a) (TMap' b) ->+      toMap (intersection a b) == Map.intersection (toMap a) (toMap b)+  specify "toMap (difference a b) = Map.difference (toMap a) (toMap b)" $+    property $ \(TMap' a) (TMap' b) ->+      toMap (difference a b) == Map.difference (toMap a) (toMap b)+  specify "toMap (append a b) = mapAppend (toMap a) (toMap b)" $+    property $ \(TMap' a) (TMap' b) ->+      toMap (getSum <$> appendWith (\x y -> Sum (x * y)) a b) ==+      mapAppend (toMap a) (toMap b)+      +  specify "validTMap (union a b)" $+    property $ \(TMap' a) (TMap' b) ->+      validTMap (union a b)+  specify "validTMap (intersection a b)" $+    property $ \(TMap' a) (TMap' b) ->+      validTMap (intersection a b)+  specify "validTMap (difference a b)" $+    property $ \(TMap' a) (TMap' b) ->+      validTMap (difference a b)+  specify "validTMap (append a b)" $+    property $ \(TMap' a) (TMap' b) ->+      validTMap (getSum <$> appendWith (\x y -> Sum (x * y)) a b)+++mapAppend :: (Ord c) => Map [c] Int -> Map [c] Int -> Map [c] Int+mapAppend ass bss =+  sumUnions+    [ Map.mapKeysMonotonic (as ++) $ Map.map (v *) bss+      | (as, v) <- Map.toAscList ass ]+  where+    sumUnions = foldl' (Map.unionWith (+)) Map.empty
+ test/Data/Trie/Set/Gen.hs view
@@ -0,0 +1,58 @@+module Data.Trie.Set.Gen(+  C(..),+  TSet'(..),+  TSet''(..),+  genTSet,+  acceptStrs,+  validTSet+) where++import           Test.QuickCheck hiding (shrinkMapBy)++import qualified Data.Map as Map+import           Data.Trie.Set+import           Data.Trie.Set.Internal+import           Common++newtype TSet' = TSet' (TSet C)+newtype TSet'' = TSet'' (TSet B)++instance Show TSet' where+  show (TSet' t) = show t++instance Arbitrary TSet' where+  arbitrary = TSet' <$> genTSet +  shrink (TSet' t) = TSet' <$> shrinkTSet t++instance Show TSet'' where+  show (TSet'' t) = show t++instance Arbitrary TSet'' where+  arbitrary = TSet'' <$> genTSet +  shrink (TSet'' t) = TSet'' <$> shrinkTSet t++genTSet :: (Ord c, Arbitrary c) => Gen (TSet c)+genTSet = fromList <$> arbitrary++shrinkTSet :: (Ord c, Arbitrary c) => TSet c -> [TSet c]+shrinkTSet (TSet (Node a e)) = filter validTSet $+  [ TSet (Node False e) | a ] +++  [ TSet (Node a e') | e' <- shrinkMapBy shrinkTSet e ]++acceptStrs :: TSet c -> Gen [[c]]+acceptStrs t = sized $ \n ->+  let m = count t+      loop _ [] = return []+      loop k (a:as)+        | k <= 0    = return []+        | otherwise =+            frequency [(n, (a:) <$> loop (k-1) as), (m, loop k as)]+  in loop n (enumerate t)++validTSet :: TSet c -> Bool+validTSet = snd . foldTSet step+  where+    step (Node a e) =+      let isEmpty = not a && all fst e+          isValid = (not isEmpty || Map.null e) && all snd e+      in (isEmpty, isValid)
+ test/Data/Trie/SetSpec.hs view
@@ -0,0 +1,94 @@+module Data.Trie.SetSpec(+  spec+) where++import           Test.Hspec+import           Test.QuickCheck++import           Data.List         (sort, inits, tails)+import           Data.Set          (Set)+import qualified Data.Set          as Set++import           Data.Trie.Set     as T+import           Data.Trie.Set.Gen++spec :: Spec+spec = do+  specify "enumerate empty = []" $+    enumerate (empty :: TSet C) `shouldSatisfy` Prelude.null+  specify "enumerate epsilon = [[]]" $+    enumerate (epsilon :: TSet C) `shouldBe` [[]]+  specify "enumerate . singleton = (:[])" $+    property $ \str -> enumerate (singleton (str :: [C])) === [str]+  specify "enumerate . fromList = Set.toAscList . Set.fromList" $+    property $ \strs -> (enumerate . fromList) (strs :: [[C]]) == (Set.toAscList . Set.fromList) strs+  specify "null . enumerate = null" $+    property $ \(TSet' t) -> Prelude.null (enumerate t) === T.null t+  specify "length . enumerate = count" $+    property $ \(TSet' t) -> length (enumerate t) === count t++  specify "toSet (insert xs a) = Set.insert xs (toSet a)" $+    property $ \xs (TSet' t) -> toSet (T.insert xs t) == Set.insert xs (toSet t)+  specify "toSet (delete xs a) = Set.delete xs (toSet a)" $+    property $ \xs (TSet' t) -> toSet (T.delete xs t) == Set.delete xs (toSet t)+  +  specify "member t = (`Set.member` toSet t)" $+    property $ \(TSet'' t) ->+      let strSet = toSet t+      in property $ \str -> member str t == Set.member str strSet+  specify "forAll (str `in` enumerate t). member str t" $+    property $ \(TSet'' t) -> all (`member` t) <$> acceptStrs t+  specify "member (xs ++ ys) t = member ys (beginWith t xs)" $+    property $ \xs ys (TSet'' t) ->+      member (xs ++ ys) t == member ys (beginWith t xs)++  specify "toSet (union a b) = Set.union (toSet a) (toSet b)" $+    property $ \(TSet' a) (TSet' b) ->+      toSet (union a b) == Set.union (toSet a) (toSet b)+  specify "toSet (intersection a b) = Set.intersection (toSet a) (toSet b)" $+    property $ \(TSet' a) (TSet' b) ->+      toSet (intersection a b) == Set.intersection (toSet a) (toSet b)+  specify "toSet (difference a b) = Set.difference (toSet a) (toSet b)" $+    property $ \(TSet' a) (TSet' b) ->+      toSet (difference a b) == Set.difference (toSet a) (toSet b)+  specify "toSet (append a b) = setAppend (toSet a) (toSet b)" $+    property $ \(TSet' a) (TSet' b) ->+      toSet (append a b) == setAppend (toSet a) (toSet b)++  specify "validTSet (union a b)" $+    property $ \(TSet' a) (TSet' b) ->+      validTSet (union a b)+  specify "validTSet (intersection a b)" $+    property $ \(TSet' a) (TSet' b) ->+      validTSet (intersection a b)+  specify "validTSet (difference a b)" $+    property $ \(TSet' a) (TSet' b) ->+      validTSet (difference a b)+  specify "validTSet (append a b)" $+    property $ \(TSet' a) (TSet' b) ->+      validTSet (append a b)+  +  specify "toSet (prefixes a) = setPrefixes (toSet a)" $+    property $ \(TSet' a) ->+      toSet (prefixes a) === setPrefixes (toSet a)+  specify "toSet (suffixes a) = setSuffixes (toSet a)" $+    property $ \(TSet' a) ->+      toSet (suffixes a) === setSuffixes (toSet a)++  specify "fromAscList . sort = fromList" $+    property $ \strs -> fromAscList (sort strs) == fromList (strs :: [[C]])+  specify "fromSet . Set.fromList = fromList" $+    property $ \strs -> fromSet (Set.fromList strs) == fromList (strs :: [[C]])++setAppend :: (Ord c) => Set [c] -> Set [c] -> Set [c]+setAppend ass bss = Set.unions+  [ Set.mapMonotonic (as ++) bss+      | as <- Set.toAscList ass ]++setPrefixes :: (Ord c) => Set [c] -> Set [c]+setPrefixes ass = Set.unions+  [ Set.fromDistinctAscList (inits as) | as <- Set.toAscList ass ]++setSuffixes :: (Ord c) => Set [c] -> Set [c]+setSuffixes ass = Set.fromList+  [ bs | as <- Set.toAscList ass, bs <- tails as ]
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ trie-simple.cabal view
@@ -0,0 +1,73 @@+name:                trie-simple+version:             0.4.1.1+synopsis:            Simple Map-based Trie+description:+  Trie data structure `TMap` to hold mapping from list of characters to+  something, i.e. isomorphic to `Map [c] v`.+  +  It is more efficient to query compared to `Map`. Also, it supports extra+  operation like prefix matching.+  This package also contains `TSet`, which is isomorphic to `Set` of lists of+  characters.+license:             BSD3+license-file:        LICENSE+author:              Koji Miyazato+maintainer:          viercc@gmail.com+copyright:           Koji Miyazato+category:            Data Structure+build-type:          Simple+extra-source-files:  README.md, CHANGELOG.md+cabal-version:       >=1.10++source-repository head+  type:     git+  location: https://github.com/viercc/trie-simple+  branch:   master++library+  hs-source-dirs:      src+  exposed-modules:     Data.Trie.Set,+                       Data.Trie.Set.Internal,+                       Data.Trie.Map,+                       Data.Trie.Map.Internal+  other-modules:       Data.Trie.Set.Hidden,+                       Data.Trie.Map.Hidden+  build-depends:       base         >= 4.9     && < 4.13,+                       containers   >= 0.5.7.1 && < 0.6,+                       deepseq      >= 1.4.2.0 && < 1.5,+                       mtl          >= 2.2.1   && < 2.3+  default-language:    Haskell2010+  ghc-options:         -Wall -Wno-dodgy-exports++test-suite trie-simple-test+  type:           exitcode-stdio-1.0+  hs-source-dirs: test+  main-is:        Spec.hs+  other-modules:  Data.Trie.SetSpec,+                  Data.Trie.Set.Gen,+                  Data.Trie.MapSpec,+                  Data.Trie.Map.Gen,+                  Common+  build-depends: base,+                 containers,+                 vector,+                 QuickCheck,+                 hspec,+                 trie-simple+  ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+  default-language: Haskell2010++benchmark trie-benchmark+  type:                exitcode-stdio-1.0+  hs-source-dirs:      bench+  main-is:             trie-benchmark.hs+  other-modules:       Common+  build-depends:       base,+                       deepseq,+                       containers,+                       criterion,+                       vector,+                       mwc-random,+                       trie-simple+  ghc-options:         -O2 -Wall -threaded -rtsopts -with-rtsopts=-N+  default-language:    Haskell2010