trie-simple 0.4.1.1 → 0.4.2
raw patch · 10 files changed
+545/−340 lines, 10 filesdep +gaugedep +hashabledep +indexed-traversabledep −criteriondep ~basedep ~containersdep ~deepseqPVP ok
version bump matches the API change (PVP)
Dependencies added: gauge, hashable, indexed-traversable, matchable, semialign, these, witherable
Dependencies removed: criterion
Dependency ranges changed: base, containers, deepseq
API changes (from Hackage documentation)
+ Data.Trie.Map: fromAscListWith :: Ord c => (a -> a -> a) -> [([c], a)] -> TMap c a
+ Data.Trie.Map: fromListWith :: Ord c => (a -> a -> a) -> [([c], a)] -> TMap c a
Files
- CHANGELOG.md +21/−0
- README.md +5/−3
- bench/Common.hs +38/−14
- bench/trie-benchmark.hs +119/−192
- src/Data/Trie/Map.hs +2/−2
- src/Data/Trie/Map/Hidden.hs +261/−85
- src/Data/Trie/Set.hs +1/−1
- src/Data/Trie/Set/Hidden.hs +45/−10
- test/Data/Trie/MapSpec.hs +30/−19
- trie-simple.cabal +23/−14
CHANGELOG.md view
@@ -1,3 +1,24 @@+# 0.4.2++- Compatibility changes++ - Drops GHC older than 8.10 ("base-4.14")++- API changes++ - Addition of `Data.Trie.Map.fromListWith` and `Data.Trie.Map.fromAscListWith`+ - The behavior of `Data.Trie.Map.appendWith` is fully specified now.++- Additional instances++ - `Eq1, Eq2, Ord1, Ord2, Show1, Show2` from "base"+ - `IsList` from "base" (for `OverloadedLists` GHC extension)+ - `Hashable, Hashable1, Hashable2` from "hashable"+ - `FunctorWithIndex, FoldableWithIndex, TraversableWithIndex` from "indexed-traversable"+ - `Filterable(WithIndex), Witherable(WithIndex)` from "witherable"+ - `Semialign, Align, Zip` from "semialign"+ - `Matchable` from "matchable"+ # 0.4.1.1 - Initial release.
README.md view
@@ -18,11 +18,13 @@ ## Benchmarks -Benchmarks compared against plain `Map` and `Set`.+Benchmarks compared against plain `Map` and `Set`. -+ -+++Each of these benchmarks has two sets of point and errorbars, representing two datasets they are run against. ## About License
bench/Common.hs view
@@ -1,7 +1,7 @@+{-# LANGUAGE NamedFieldPuns #-} module Common(- dictAmEn, dictBrEn,- dictAmEnShuffled, randomStrs,- dictURI1, dictURI2+ Dataset(..),+ englishDataset, wikiDataset ) where import qualified Data.Vector as V@@ -9,20 +9,48 @@ import qualified System.Random.MWC as R import qualified System.Random.MWC.CondensedTable as R-import qualified System.Random.MWC.Distributions as R+import Control.DeepSeq+import Data.List (sort) +data Dataset = Dataset {+ dictA :: [String],+ dictB :: [String],+ dictAUnsorted :: [String],+ gibberish :: [String]+ }+ deriving (Show)++instance NFData Dataset where+ rnf Dataset{ dictA, dictB, dictAUnsorted, gibberish } = rnf dictA `seq` rnf dictB `seq` rnf dictAUnsorted `seq` rnf gibberish++englishDataset :: IO Dataset+englishDataset = do+ dictAmEn <- lines <$> readFile "/usr/share/dict/american-english"+ dictBrEn <- lines <$> readFile "/usr/share/dict/british-english"+ dictAmEnShuffled <- lines <$> readFile "benchdata/american-english-shuf"+ rand <- randomStrs 10003+ pure $ Dataset{ dictA = dictAmEn, dictB = dictBrEn, dictAUnsorted = dictAmEnShuffled, gibberish = rand }++wikiDataset :: IO Dataset+wikiDataset = do+ wiki1 <- lines <$> readFile "benchdata/externallinks.txt.1"+ wiki2 <- lines <$> readFile "benchdata/externallinks.txt.2"+ let wiki1Sorted = sort wiki1+ wiki2Sorted = sort wiki2+ rand <- randomStrs 10007+ pure $ Dataset{ dictA = wiki1Sorted, dictB = wiki2Sorted, dictAUnsorted = wiki1, gibberish = rand }++---+ 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)+randomStrs :: Word32 -> IO [String]+randomStrs s =+ do g <- R.initialize (seed s) revReplicateM numRandomStr $ do n <- R.genFromTable distN g revReplicateM (n+1) (uniformAlphabet g)@@ -31,10 +59,6 @@ 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 []
bench/trie-benchmark.hs view
@@ -1,13 +1,14 @@+{-# LANGUAGE RecordWildCards #-} module Main(main) where -import Criterion.Main+import Gauge.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.List (inits, tails, foldl') import Data.Set (Set) import qualified Data.Set as Set import Data.Map.Lazy (Map)@@ -17,157 +18,87 @@ main :: IO () main = defaultMain- [ benchTSet- , benchTSet_URI- , benchSet- , benchSet_URI- , benchTMap- , benchMap+ [ benchAll englishDataset "English"+ , benchAll wikiDataset "Wiki" ] -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) ]- ]+benchAll :: IO Dataset -> String -> Benchmark+benchAll setupEnv groupName =+ env setupEnv $ \dataset ->+ bgroup groupName [+ benchSet dataset,+ benchTSet dataset,+ benchMap dataset,+ benchTMap dataset+ ] -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" +benchTSet :: Dataset -> Benchmark+benchTSet ~Dataset{..} = bgroup "TSet" [ 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 ->+ [ bench "fromList" $ whnf TSet.fromList dictAUnsorted+ , bench "fromAscList" $ whnf TSet.fromAscList dictA ]+ , env (pure $ TSet.fromList dictA) $ \mapA -> 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 ->+ [ bench "isEmpty" (nf TSet.null mapA)+ , bench "stringCount" (nf TSet.count mapA)+ , bench "enumerate10" (nf (take 10 . TSet.enumerate) mapA)+ , bench "enumerateAll" (nf TSet.enumerate mapA)+ , bench "match" (nf (\dict' -> map (`TSet.member` dict') gibberish) mapA) ]+ , env (pure (TSet.fromList dictA)) $ \mapA -> 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)+ [ bench "insert1" (whnf (TSet.insert "######fake_key######") mapA)+ , bench "insert2" (whnf (TSet.insert realKey) mapA)+ , bench "delete1" (whnf (TSet.delete "######fake_key######") mapA)+ , bench "delete2" (whnf (TSet.delete realKey) mapA) ]- , env (Set.fromList <$> dictAmEn) $ \dictA ->- env (Set.fromList <$> dictBrEn) $ \dictB ->- env (Set.fromList <$> randomStrs) $ \dictSmall ->+ , env (pure $ TSet.fromList dictA) $ \mapA ->+ env (pure $ TSet.fromList dictB) $ \mapB -> 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) ]+ [ bench "union" (whnf (uncurry TSet.union) (mapA, mapB))+ , bench "intersection" (whnf (uncurry TSet.intersection) (mapA, mapB))+ , bench "difference" (whnf (uncurry TSet.difference) (mapA, mapB))+ , env (pure $ TSet.fromList gibberish) $ \mapSmall ->+ bench "append" (whnf (uncurry TSet.append) (mapSmall, mapSmall))+ , bench "prefixes" (whnf TSet.prefixes mapA)+ , bench "suffixes" (whnf TSet.suffixes mapB) ] ]+ where realKey = head dictA -benchSet_URI :: Benchmark-benchSet_URI = bgroup "Set_URI" +benchSet :: Dataset -> Benchmark+benchSet ~Dataset{..} = 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 dictURI1 $ \dict ->- bench "fromList" $ whnf Set.fromList dict- , env (sort <$> dictURI1) $ \sortedDict ->- bench "fromAscList" $ whnf Set.fromAscList sortedDict ]- , env (Set.fromList <$> dictURI1) $ \dictSet ->+ [ bench "fromList" $ whnf Set.fromList dictAUnsorted+ , bench "fromAscList" $ whnf Set.fromAscList dictA ]+ , env (pure $ Set.fromList dictA) $ \mapA -> 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 ->+ [ bench "isEmpty" (nf Set.null mapA)+ , bench "stringCount" (nf Set.size mapA)+ , bench "enumerate10" (nf (take 10 . Set.toList) mapA)+ , bench "enumerateAll" (nf Set.toList mapA)+ , bench "match" (nf (\dict' -> map (`Set.member` dict') gibberish) mapA) ]+ , env (pure (Set.fromList dictA)) $ \mapA -> 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)+ [ bench "insert1" (whnf (Set.insert "######fake_key######") mapA)+ , bench "insert2" (whnf (Set.insert realKey) mapA)+ , bench "delete1" (whnf (Set.delete "######fake_key######") mapA)+ , bench "delete2" (whnf (Set.delete realKey) mapA) ]- , env (Set.fromList <$> dictURI1) $ \dictA ->- env (Set.fromList <$> dictURI2) $ \dictB ->- env (Set.fromList <$> randomStrs) $ \dictSmall ->+ , env (pure $ Set.fromList dictA) $ \mapA ->+ env (pure $ Set.fromList dictB) $ \mapB -> 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) ]+ [ bench "union" (whnf (uncurry Set.union) (mapA, mapB))+ , bench "intersection" (whnf (uncurry Set.intersection) (mapA, mapB))+ , bench "difference" (whnf (uncurry Set.difference) (mapA, mapB))+ , env (pure $ Set.fromList gibberish) $ \mapSmall ->+ bench "append" (whnf (uncurry setAppend) (mapSmall, mapSmall))+ , bench "prefixes" (whnf setPrefixes mapA)+ , bench "suffixes" (whnf setSuffixes mapB) ] ]+ where realKey = head dictA setAppend :: (Ord c) => Set [c] -> Set [c] -> Set [c] setAppend ass bss = Set.unions@@ -183,43 +114,41 @@ [ bs | as <- Set.toAscList ass, bs <- tails as ] -benchTMap :: Benchmark-benchTMap = bgroup "TMap" +benchTMap :: Dataset -> Benchmark+benchTMap ~Dataset{..} = 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]+ [ bench "fromList" $ whnf TMap.fromList [(w, length w) | w <- dictAUnsorted ]+ , bench "fromAscList" $ whnf TMap.fromAscList [(w, length w) | w <- dictA ] ]- , env (lenTMap <$> dictAmEn) $ \dict ->+ , env (pure $ lenTMap dictA) $ \mapA -> 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 ->+ [ bench "isEmpty" (nf TMap.null mapA)+ , bench "stringCount" (nf TMap.count mapA)+ , bench "enumerate10" (nf (take 10 . TMap.toList) mapA)+ , bench "match" (nf (\dict' -> map (`TMap.member` dict') gibberish) mapA) ]+ , env (pure (lenTMap dictA)) $ \mapA -> 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)+ [ bench "insert1" (whnf (TMap.insert "######fake_key######" 1) mapA)+ , bench "insert2" (whnf (TMap.insert realKey 1) mapA)+ , bench "delete1" (whnf (TMap.delete "######fake_key######") mapA)+ , bench "delete2" (whnf (TMap.delete realKey) mapA)+ , bench "alter1" (whnf (TMap.alter alterFn "######fake_key######") mapA)+ , bench "alter2" (whnf (TMap.alter alterFn realKey) mapA) ]- , env (lenTMap <$> dictAmEn) $ \dict ->+ , env (pure (lenTMap dictA)) $ \mapA -> 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 ->+ [ bench "fmap" (nf (fmap (+3)) mapA)+ , bench "foldMap" (nf (foldMap Sum) mapA) ]+ , env (pure $ lenTMap dictA) $ \mapA ->+ env (pure $ lenTMap dictB) $ \mapB -> 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)) ]+ [ bench "union" (whnf (uncurry TMap.union) (mapA, mapB))+ , bench "intersection" (whnf (uncurry TMap.intersection) (mapA, mapB))+ , bench "difference" (whnf (uncurry TMap.difference) (mapA, mapB))+ , env (pure $ lenTMap gibberish) $ \mapSmall ->+ bench "append" (whnf (uncurry tmapProd) (mapSmall, mapSmall)) ] ]+ where realKey = head dictA alterFn :: Maybe Int -> Maybe Int alterFn Nothing = Just 1000@@ -229,45 +158,43 @@ 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)+tmapProd = TMap.appendWith (\x y -> Sum (x * y)) -benchMap :: Benchmark-benchMap = bgroup "Map" +benchMap :: Dataset -> Benchmark+benchMap ~Dataset{..} = 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]+ [ bench "fromList" $ whnf Map.fromList [(w, length w) | w <- dictAUnsorted ]+ , bench "fromAscList" $ whnf Map.fromAscList [(w, length w) | w <- dictA ] ]- , env (lenMap <$> dictAmEn) $ \dict ->+ , env (pure $ lenMap dictA) $ \mapA -> 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 ->+ [ bench "isEmpty" (nf Map.null mapA)+ , bench "stringCount" (nf Map.size mapA)+ , bench "enumerate10" (nf (take 10 . Map.toList) mapA)+ , bench "match" (nf (\dict' -> map (`Map.member` dict') gibberish) mapA) ]+ , env (pure (lenMap dictA)) $ \mapA -> 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)+ [ bench "insert1" (whnf (Map.insert "######fake_key######" 1) mapA)+ , bench "insert2" (whnf (Map.insert realKey 1) mapA)+ , bench "delete1" (whnf (Map.delete "######fake_key######") mapA)+ , bench "delete2" (whnf (Map.delete realKey) mapA)+ , bench "alter1" (whnf (Map.alter alterFn "######fake_key######") mapA)+ , bench "alter2" (whnf (Map.alter alterFn realKey) mapA) ]- , env (lenMap <$> dictAmEn) $ \dict ->+ , env (pure (lenMap dictA)) $ \mapA -> 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 ->+ [ bench "fmap" (nf (fmap (+3)) mapA)+ , bench "foldMap" (nf (foldMap Sum) mapA) ]+ , env (pure $ lenMap dictA) $ \mapA ->+ env (pure $ lenMap dictB) $ \mapB -> 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)) ]+ [ bench "union" (whnf (uncurry Map.union) (mapA, mapB))+ , bench "intersection" (whnf (uncurry Map.intersection) (mapA, mapB))+ , bench "difference" (whnf (uncurry Map.difference) (mapA, mapB))+ , env (pure $ lenMap gibberish) $ \mapSmall ->+ bench "append" (whnf (uncurry mapProd) (mapSmall, mapSmall)) ] ]+ where realKey = head dictA lenMap :: (Ord c) => [[c]] -> Map [c] Int lenMap dict = Map.fromList [(w, length w) | w <- dict]
src/Data/Trie/Map.hs view
@@ -27,8 +27,8 @@ appendWith, -- * Conversion- toList, fromList,- toAscList, fromAscList,+ toList, fromList, fromListWith,+ toAscList, fromAscList, fromAscListWith, toMap, fromMap, keysTSet, fromTSet,
src/Data/Trie/Map/Hidden.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-} module Data.Trie.Map.Hidden( -- * Types TMap(..),@@ -25,8 +27,8 @@ appendWith, -- * Conversion- toList, fromList,- toAscList, fromAscList,+ toList, fromList, fromListWith,+ toAscList, fromAscList, fromAscListWith, toMap, fromMap, keysTSet, fromTSet, @@ -44,18 +46,15 @@ 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 qualified Data.List.NonEmpty as NE import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe, isJust, isNothing)@@ -64,32 +63,170 @@ import qualified Data.Trie.Set.Internal as TSet import Control.DeepSeq+import Data.Functor.Classes+import qualified GHC.Exts+import Text.Show (showListWith) +import Data.Functor.WithIndex+import Data.Foldable.WithIndex+import Data.Traversable.WithIndex++import Data.Hashable.Lifted+import Data.Hashable+import Witherable+import Data.These (These(..))+import Data.Zip (Zip(..))+import Data.Align ( Align(..), Semialign(..) )+import Data.Matchable+ data Node c a r = Node !(Maybe a) !(Map c r) deriving (Show, Eq, Ord, Functor, Foldable, Traversable) +instance (Eq c, Eq a) => Eq1 (Node c a) where+ liftEq = liftEq2 (==)++instance (Ord c, Ord a) => Ord1 (Node c a) where+ liftCompare = liftCompare2 compare++instance Eq c => Eq2 (Node c) where+ liftEq2 eqA eqR (Node a1 e1) (Node a2 e2) = liftEq eqA a1 a2 && liftEq eqR e1 e2++instance Ord c => Ord2 (Node c) where+ liftCompare2 cmpA cmpR (Node a1 e1) (Node a2 e2) = liftCompare cmpA a1 a2 <> liftCompare cmpR e1 e2+ 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@,+-- This type serves the almost same purpose of @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 Show2 TMap where+ liftShowsPrec2 _ showListC showspA _ p t = showParen (p > 10) $+ showString "fromList " . showListWith (showPairWith showListC (showspA 0)) (toList t)++showPairWith :: (a -> ShowS) -> (b -> ShowS) -> (a,b) -> ShowS+showPairWith showsA showsB = liftShowsPrec2 (const showsA) (showListWith showsA) (const showsB) (showListWith showsB) 0++instance Show c => Show1 (TMap c) where+ liftShowsPrec = liftShowsPrec2 showsPrec showList+ instance (Show c, Show a) => Show (TMap c a) where- showsPrec p t = showParen (p > 10) $ showString "fromList " . showsPrec 11 (toList t)+ showsPrec = showsPrec2 instance (NFData c, NFData a) => NFData (TMap c a) where rnf (TMap node) = rnf node +instance (Eq c) => Eq1 (TMap c) where+ liftEq = liftEq2 (==)++instance Eq2 TMap where+ liftEq2 eqC eqA = go+ where+ go (TMap (Node ma1 e1)) (TMap (Node ma2 e2)) =+ liftEq eqA ma1 ma2 &&+ liftEq2 eqC go e1 e2++instance (Ord c) => Ord1 (TMap c) where+ liftCompare cmp (TMap m1) (TMap m2) = liftCompare2 cmp (liftCompare cmp) m1 m2++instance Ord2 TMap where+ liftCompare2 cmpC cmpA = go+ where+ go (TMap (Node ma1 e1)) (TMap (Node ma2 e2)) =+ liftCompare cmpA ma1 ma2 <>+ liftCompare2 cmpC go e1 e2++instance (Ord c) => GHC.Exts.IsList (TMap c a) where+ type Item (TMap c a) = ([c],a)+ fromList = fromList+ toList = toList++instance Hashable2 TMap where+ liftHashWithSalt2 hashC hashA = hashT+ where+ hashMA = liftHashWithSalt hashA+ hashEdges = liftHashWithSalt2 hashC hashT+ hashT s (TMap (Node ma e)) = s `hashMA` ma `hashEdges` e++instance Hashable c => Hashable1 (TMap c) where+ liftHashWithSalt = liftHashWithSalt2 hashWithSalt++instance (Hashable c, Hashable a) => Hashable (TMap c a) where+ hashWithSalt = hashWithSalt2++instance FunctorWithIndex [c] (TMap c) where+ imap = mapWithKey++instance FoldableWithIndex [c] (TMap c) where+ ifoldr = foldrWithKey++instance TraversableWithIndex [c] (TMap c) where+ itraverse = traverseWithKey++instance Ord c => Filterable (TMap c) where+ mapMaybe f = go+ where+ go (TMap (Node ma edges)) =+ TMap (Node (ma >>= f) (mapMaybe (nonEmptyTMap . go) edges))++instance Ord c => Witherable (TMap c) where+ wither f = go+ where+ go (TMap (Node ma edges)) = fmap TMap $+ Node <$> wither f ma <*> wither (fmap nonEmptyTMap . go) edges++instance Ord c => FilterableWithIndex [c] (TMap c) where+ imapMaybe f (TMap (Node ma edges)) = TMap (Node mb edges')+ where+ mb = ma >>= f []+ edges' = imapMaybe (\c t -> nonEmptyTMap $ imapMaybe (f . (c:)) t) edges++instance Ord c => WitherableWithIndex [c] (TMap c) where+ iwither f (TMap (Node ma edges)) = TMap <$> (Node <$> mb <*> edges')+ where+ mb = wither (f []) ma+ edges' = iwither child edges+ child c t = nonEmptyTMap <$> iwither (f . (c :)) t++instance Ord c => Semialign (TMap c) where+ align (TMap (Node ma e1)) (TMap (Node mb e2)) = TMap (Node mc e')+ where+ mc = align ma mb+ e' = alignWith subtree e1 e2+ subtree (This t1) = This <$> t1+ subtree (That t2) = That <$> t2+ subtree (These t1 t2) = align t1 t2++instance (Ord c) => Align (TMap c) where+ nil = empty++instance (Ord c) => Zip (TMap c) where+ zipWith op = intersectionWith (\a b -> Just (op a b))++instance (Eq c) => Matchable (TMap c) where+ zipMatchWith f = go+ where+ go (TMap (Node ma e1)) (TMap (Node mb e2)) = TMap <$> (Node <$> mc <*> e')+ where+ mc = zipMatchWith f ma mb+ e' = zipMatchWith go e1 e2+ -- * Queries --- | Perform matching against a @TMap@.+-- | Perform partial 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 xs tmap@ returns two values. The first value is the result of+-- 'lookup'. The second is another @TMap@ for all keys which contain @xs@ as their prefix.+-- The keys of the returned map do not contain the common prefix @xs@.+--+-- ===== Example+--+-- >>> let x = 'fromList' [("ham", 1), ("bacon", 2), ("hamburger", 3)]+-- >>> match "ham" x+-- (Just 1,fromList [("",1),("burger",3)]) 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)) =@@ -117,7 +254,9 @@ -- Note that this operation takes O(number of nodes), -- unlike O(1) of 'Map.size'. count :: TMap c a -> Int-count = F.length+count = foldTMap count'+ where+ count' (Node ma e) = F.foldl' (+) (length ma) e -- | Returns list of key strings, in ascending order. keys :: TMap c a -> [[c]]@@ -129,7 +268,9 @@ -- | Returns list of values, in ascending order by its key. elems :: TMap c a -> [a]-elems = F.toList+elems = foldTMap elems'+ where+ elems' (Node ma e) = F.toList ma ++ F.foldr (++) [] e -- * Construction @@ -153,22 +294,23 @@ -- | Inserts an entry of key and value pair. ----- Already existing value will be overwritten, i.e.--- > insert = insertWith (const a)+-- Already existing value will be overwritten.+--+-- > 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 = '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+-- | @insertWith op xs a tmap@ inserts an entry of key-value pair @(cs,a)@ -- 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 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 @@ -179,7 +321,7 @@ -- 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 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 @@ -193,7 +335,7 @@ in TMap (Node ma e') {-# INLINE adjust #-} --- | Apply a function @f@ to the entry with given key. If there is no such+-- | Apply a function @f@ to the entry with the 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))@@ -235,8 +377,8 @@ -- @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.+-- operation applied to the given key.+-- If you're not going to use @alter@ on missing keys, consider using @update@ instead. alter :: (Ord c) => (Maybe a -> Maybe a) -> [c] -> TMap c a -> TMap c a alter f = case f Nothing of@@ -314,63 +456,82 @@ 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.+Creates a new @TMap@ from two @TMap@s. The keys of the new map+are concatenations of one key from the first map and another one from the second map. -Corresponding values for these keys are combined with given function+Corresponding values for these keys are calculated with the 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 @<>@.+the same key, the calculated values for these keys are combined with the '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.+The behavior of @appendWith@ is equivalent to the following implementation. +@+appendWith :: (Ord c, Semigroup z) => (x -> y -> z) ->+ TMap c x -> TMap c y -> TMap c z+appendWith f x y = 'fromListWith' (flip (<>))+ [ (kx ++ ky, f valx valy)+ | (kx, valx) <- 'toAscList' x+ , (ky, valy) <- toAscList y ]+@++In other words, a set of colliding key-valur pairs is combined in increasing order of the left key.+For example, suppose @x, y@ are @TMap@ with these key-value pairs,+and @kx1 ++ ky3, kx2 ++ ky2, kx3 ++ ky1@ are all equal to the same key @kz@.++@+x = 'fromAscList' [ (kx1, x1), (kx2, x2), (kx3, x3) ] -- kx1 < kx2 < kx3+y = fromAscList [ (ky1, y1), (ky2, y2), (ky3, y3) ]+@++On these maps, @appendWith@ combines the values for these colliding keys+in the order of @kx*@.++@+'lookup' kz (appendWith f x y) == Just (f x1 y3 <> f x2 y2 <> f x3 y1)+@+ ===== Example -> let x = fromList [("a", 1), ("aa", 2)] :: TMap Char (Sum Int)-> y = fromList [("aa", 10), ("aaa", 20)] :: TMap Char (Sum Int)+> let x = fromList [("a", 1), ("aa", 2)] :: TMap Char Int+> y = fromList [("aa", 10), ("aaa", 20)] :: TMap Char Int >-> appendWith (*) x y =-> fromList [ ("aaa", 1 * 10)-> , ("aaaa", 1 * 20 + 2 * 10)-> , ("aaaaa", 2 * 20) ]+> appendWith (\a b -> show (a,b)) 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''')+appendWith f xs (TMap (Node my ey))+ | Map.null ey = case my of+ Nothing -> empty+ Just y -> fmap (`f` y) xs+ | otherwise = go xs+ where+ go (TMap (Node Nothing ex)) = TMap (Node Nothing (Map.map go ex))+ go (TMap (Node (Just x) ex)) =+ let mz = f x <$> my+ ex' = Map.map go ex+ ey' = Map.map (fmap (f x)) ey+ ez = Map.unionWith (unionWith (<>)) ey' ex'+ in TMap (Node mz ez) -- * Instances instance Functor (TMap c) where fmap f = go where- go (TMap (Node ma e)) = TMap (Node (fmap f ma) (fmap go e))+ go (TMap (Node ma e)) = TMap (Node (fmap f ma) (Map.map 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+ foldr f z = foldr f z . elems+ toList = elems+ null = Data.Trie.Map.Hidden.null+ length = count instance Traversable (TMap c) where- traverse f = go- where- go (TMap (Node a e)) = TMap <$> (Node <$> traverse f a <*> traverse go e)+ traverse f = traverseWithKey (const f) -- | 'unionWith'-based instance (Ord c, Semigroup a) => Semigroup (TMap c a) where@@ -390,6 +551,9 @@ fromList :: Ord c => [([c], a)] -> TMap c a fromList = List.foldl' (flip (uncurry insert)) empty +fromListWith :: Ord c => (a -> a -> a) -> [ ([c],a)] -> TMap c a+fromListWith op = List.foldl' (flip (uncurry (insertWith op))) empty+ toAscList :: TMap c a -> [([c], a)] toAscList = toList @@ -397,17 +561,31 @@ fromAscList [] = empty fromAscList [(cs, a)] = singleton cs a fromAscList pairs =- let (ma, gs) = group_ pairs+ let (as, gs) = group_ pairs+ ma = NE.last <$> NE.nonEmpty as 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, [])+foldl1' :: (a -> a -> a) -> NE.NonEmpty a -> a+foldl1' f (a NE.:| as) = F.foldl' f a as++fromAscListWith :: Ord c => (a -> a -> a) -> [ ([c],a)] -> TMap c a+fromAscListWith _ [] = empty+fromAscListWith op pairs =+ let (as, gs) = group_ pairs+ ma = foldl1' (flip op) <$> NE.nonEmpty as+ e = Map.fromDistinctAscList $ map (fmap (fromAscListWith op)) gs+ in TMap (Node ma e)++group_ :: Eq c => [([c], a)] -> ([a], [ (c, [ ([c], a) ]) ] )+group_ = foldr step ([], []) 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)+ step ([], a) ~(as, gs) = (a : as, gs)+ step (c:cs, a) ~(as, gs) = (as, prepend c cs a gs)+ + prepend c cs a gs = case gs of+ (d,ps'):rest | c == d -> (d, (cs,a):ps'):rest+ _ -> (c, [(cs,a)]):gs toMap :: TMap c a -> Map [c] a toMap = Map.fromDistinctAscList . toAscList@@ -416,10 +594,8 @@ fromMap = fromAscList . Map.toAscList keysTSet :: TMap c a -> TSet c-keysTSet = foldTMap keysTSet'- where- keysTSet' (Node ma e) =- TSet (TSet.Node (isJust ma) e)+keysTSet (TMap (Node ma e)) =+ TSet (TSet.Node (isJust ma) (Map.map keysTSet e)) fromTSet :: ([c] -> a) -> TSet c -> TMap c a fromTSet f = go []@@ -469,31 +645,24 @@ -- > 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')+traverseWithKey f (TMap (Node Nothing e)) = TMap . Node Nothing <$> Map.traverseWithKey (\c t' -> traverseWithKey (f . (c:)) t') e+traverseWithKey f (TMap (Node (Just a) e)) = fmap TMap $ Node <$> (Just <$> f [] a) <*> Map.traverseWithKey (\c t' -> traverseWithKey (f . (c:)) t') e -- | Same semantics to following defintion, but have -- more efficient implementation. ----- > traverseWithKey f = fromAscList .--- > map (\(cs,a) -> (cs, f cs a)) .--- > toAscList+-- > mapWithKey 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))+mapWithKey f (TMap (Node ma e)) = TMap $ Node (f [] <$> ma) (Map.mapWithKey (\c t' -> mapWithKey (f . (c:)) t') e) -- | 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))+foldMapWithKey f = foldrWithKey (\k v r -> f k v <> r) mempty -- | Same semantics to following defintion, but have -- more efficient implementation.@@ -512,4 +681,11 @@ foldTMap :: (Node c a r -> r) -> TMap c a -> r foldTMap f = go- where go (TMap node) = f (fmap go node)+ where+ -- Use lazy @<$>@+ go (TMap (Node a e)) = f (Node a (go <$> e))++nonEmptyTMap :: TMap c a -> Maybe (TMap c a)+nonEmptyTMap t+ | null t = Nothing+ | otherwise = Just t
src/Data/Trie/Set.hs view
@@ -46,5 +46,5 @@ ) where -import Prelude hiding (foldr, foldMap, null)+import Prelude hiding (Foldable(..)) import Data.Trie.Set.Hidden
src/Data/Trie/Set/Hidden.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE TypeFamilies #-} module Data.Trie.Set.Hidden( -- * Types TSet(..),@@ -28,12 +29,13 @@ ) where -import Prelude hiding (foldMap, foldr, null)+import Prelude hiding (Foldable(..)) import Control.Applicative hiding (empty) import qualified Control.Applicative as Ap import Data.Semigroup+import Data.Foldable (Foldable) import qualified Data.Foldable as F import qualified Data.List as List (foldr, foldl') import Data.Maybe (fromMaybe)@@ -44,6 +46,11 @@ import Control.Arrow ((&&&)) import Control.DeepSeq+import Data.Functor.Classes+import Text.Show (showListWith)+import qualified GHC.Exts+import Data.Hashable.Lifted+import Data.Hashable data Node c r = Node !Bool !(Map c r) deriving (Show, Eq, Ord, Functor, Foldable, Traversable)@@ -54,13 +61,39 @@ newtype TSet c = TSet { getNode :: Node c (TSet c) } deriving (Eq, Ord) +instance Show1 TSet where+ liftShowsPrec _ showListC p t = showParen (p > 10) $+ showString "fromList " . showListWith showListC (enumerate t)+ instance Show c => Show (TSet c) where- showsPrec p t = showParen (p > 10) $- showString "fromList " . showsPrec 11 (enumerate t)+ showsPrec = showsPrec1 instance (NFData c) => NFData (TSet c) where rnf (TSet node) = rnf node +instance (Ord c) => GHC.Exts.IsList (TSet c) where+ type Item (TSet c) = [c]+ fromList = fromList+ toList = toList++instance Eq1 TSet where+ liftEq eq = go+ where+ go (TSet (Node a1 e1)) (TSet (Node a2 e2)) = a1 == a2 && liftEq2 eq go e1 e2++instance Ord1 TSet where+ liftCompare cmp = go+ where+ go (TSet (Node a1 e1)) (TSet (Node a2 e2)) = compare a1 a2 <> liftCompare2 cmp go e1 e2++instance Hashable c => Hashable (TSet c) where+ hashWithSalt = liftHashWithSalt hashWithSalt++instance Hashable1 TSet where+ liftHashWithSalt hashC = go+ where+ go s (TSet (Node a e)) = liftHashWithSalt2 hashC go (s `hashWithSalt` a) e+ {- The canonical Monoid instance could be (epsilon, append),@@ -108,7 +141,7 @@ count = foldTSet count' where count' (Node a e) =- (if a then 1 else 0) + sum e+ (if a then 1 else 0) + F.sum e -- | List of all elements. enumerate :: TSet c -> [[c]]@@ -207,11 +240,13 @@ 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))+append x (TSet (Node ay ey))+ | Map.null ey = if ay then x else empty+ | otherwise = go x where- ez = Map.map (`append` y) ex- f = if ax then union y else id+ go (TSet (Node ax ex))+ | ax = TSet $ Node ay (Map.unionWith union ey (Map.map go ex))+ | otherwise = TSet $ Node ax (Map.map go ex) -- * Other operations @@ -297,8 +332,8 @@ foldTSet :: (Node c r -> r) -> TSet c -> r foldTSet f = go- where go (TSet node) = f (fmap go node)+ where go (TSet (Node a e)) = f (Node a (Map.map go e)) paraTSet :: (Node c (TSet c, r) -> r) -> TSet c -> r paraTSet f = go- where go (TSet node) = f (fmap (id &&& go) node)+ where go (TSet (Node a e)) = f (Node a (Map.map (id &&& go) e))
test/Data/Trie/MapSpec.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}+{-# HLINT ignore "Use curry" #-} module Data.Trie.MapSpec( spec ) where@@ -16,6 +18,11 @@ import qualified Data.Trie.Set as TSet import Data.Trie.Set.Gen +import Data.Bits ((.|.))++op :: Int -> Int -> Int+op x y = 1 + 2 * x - 3 * y - (x .|. y)+ spec :: Spec spec = do specify "toList empty = []" $@@ -27,9 +34,15 @@ specify "toAscList . fromList = Map.toAscList . Map.fromList" $ property $ \strs -> toAscList (fromList strs :: TMap C Int) == (Map.toAscList . Map.fromList) strs+ specify "toAscList . fromListWith op = Map.toAscList . Map.fromListWith op" $+ property $ \strs -> toAscList (fromListWith op strs :: TMap C Int) ==+ (Map.toAscList . Map.fromListWith op) strs specify "fromAscList . sortBy (comparing fst) = fromList" $ property $ \strs -> fromAscList (sortBy (comparing fst) strs) == (fromList strs :: TMap C Int)+ specify "fromAscListWith op . sortBy (comparing fst) = fromListWith op" $+ property $ \strs -> fromAscListWith op (sortBy (comparing fst) strs) ==+ (fromListWith op strs :: TMap C Int) specify "fromMap . Map.fromList = fromList" $ property $ \strs -> fromMap (Map.fromList strs) == (fromList strs :: TMap C Int)@@ -65,15 +78,15 @@ 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)+ specify "toMap (insertWith op k v a) = Map.insertWith op k v (toMap a)" $+ property $ \k v (TMap'' a) ->+ toMap (insertWith op k v a) ==+ Map.insertWith op k v (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 (deleteWith sub k v a) = Map.update (sub v) k (toMap a)" $+ property $ \k v (TMap'' a) ->+ toMap (deleteWith sub k v a) ==+ Map.update (sub v) 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)@@ -96,10 +109,10 @@ 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)" $+ specify "appendWith = appendWithSpec" $ property $ \(TMap' a) (TMap' b) ->- toMap (getSum <$> appendWith (\x y -> Sum (x * y)) a b) ==- mapAppend (toMap a) (toMap b)+ appendWith (\x y -> show (x,y)) a b ==+ appendWithSpec (\x y -> show (x,y)) a b specify "validTMap (union a b)" $ property $ \(TMap' a) (TMap' b) ->@@ -114,11 +127,9 @@ 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+appendWithSpec :: (Ord c, Semigroup z) => (x -> y -> z) ->+ TMap c x -> TMap c y -> TMap c z+appendWithSpec f x y = fromListWith (flip (<>))+ [ (kx ++ ky, f valx valy)+ | (kx, valx) <- toAscList x+ , (ky, valy) <- toAscList y ]
trie-simple.cabal view
@@ -1,23 +1,24 @@ name: trie-simple-version: 0.4.1.1+version: 0.4.2 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`.+ A trie data structure @TMap c v@, to hold a mapping from list of characters (@[c]@) to+ something. In other words, a data structure isomorphic to @Map [c] v@.+ It is more efficient to query compared to @Map@. Also, it supports extra+ operations like prefix matching. - 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.+ This package contains @TSet c@ too, which is isomorphic to @Set [c]@. license: BSD3 license-file: LICENSE author: Koji Miyazato maintainer: viercc@gmail.com copyright: Koji Miyazato-category: Data Structure+category: Data Structures build-type: Simple-extra-source-files: README.md, CHANGELOG.md-cabal-version: >=1.10+extra-source-files: README.md+extra-doc-files: CHANGELOG.md+cabal-version: 2.0+tested-with: GHC == 8.10.7, GHC == 9.0.2, GHC == 9.2.7, GHC == 9.4.5, GHC == 9.6.2 source-repository head type: git@@ -32,10 +33,16 @@ 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,+ build-depends: base >= 4.14 && < 4.19,+ containers >= 0.5.7.1 && < 0.7, deepseq >= 1.4.2.0 && < 1.5,- mtl >= 2.2.1 && < 2.3+ mtl >= 2.2.1 && < 2.4,+ indexed-traversable >= 0.1.1 && <0.2,+ witherable ^>= 0.4,+ matchable ^>= 0.1.2,+ hashable >= 1.3 && < 1.5,+ semialign >= 1.3 && < 1.4,+ these >= 1 && < 2 default-language: Haskell2010 ghc-options: -Wall -Wno-dodgy-exports @@ -54,6 +61,7 @@ QuickCheck, hspec, trie-simple+ build-tool-depends: hspec-discover:hspec-discover == 2.* ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 @@ -65,9 +73,10 @@ build-depends: base, deepseq, containers,- criterion,+ gauge, vector, mwc-random, trie-simple ghc-options: -O2 -Wall -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010+