tries 0.0.4.2 → 0.0.5
raw patch · 12 files changed
+349/−355 lines, 12 filesdep −composition-extradep ~QuickCheckdep ~basedep ~rose-trees
Dependencies removed: composition-extra
Dependency ranges changed: QuickCheck, base, rose-trees
Files
- README.md +33/−0
- bench-lookup/Build.hs +83/−0
- bench-lookup/Main.hs +22/−0
- bench/Bench.hs +0/−55
- bench/BenchLookup.hs +0/−22
- bench/Build.hs +0/−83
- src/Data/Trie/Class.hs +4/−15
- src/Data/Trie/HashMap.hs +46/−43
- src/Data/Trie/Knuth.hs +5/−5
- src/Data/Trie/List.hs +7/−7
- src/Data/Trie/Map.hs +39/−34
- tries.cabal +110/−91
+ README.md view
@@ -0,0 +1,33 @@+tries+====++This is a collection and comparison of some basic, pure trie implementations.++So far, there is:++- a Map trie, using `Data.Map` from [containers](https://hackage.haskell.org/package/containers)+- a List trie, using `Data.Tree` from [containers](https://hackage.haskell.org/package/containers)+- a HashMap trie, using `Data.HashMap` from [unordered-containers](https://hackage.haskell.org/package/unordered-containers)+- a Knuth trie, using `Data.Tree.Knuth` from [rose-trees](https://hackage.haskell.org/package/rose-trees)++## Running the Tests++```bash+stack test+```++and++## Running the Benchmarks++for insert / delete:++```bash+stack bench --benchmark-arguments="--output profile.html"+```++for lookups:++```bash+stack bench --benchmark-arguments="--output profile-lookup.html" --flag tries:Lookup+```
+ bench-lookup/Build.hs view
@@ -0,0 +1,83 @@+module Build where++++import Data.List.NonEmpty (NonEmpty (..))+import Data.Tree (Tree (..))+import Data.Trie.List as L+import Data.Trie.Map as M+import Data.Trie.HashMap as HM+import Data.Tree.Knuth.Forest as K+import Data.Trie.Knuth as K+import qualified Data.Map as Map+import qualified Data.HashMap.Lazy as HMap+import Control.Monad.State+++buildMiddleQuery :: Int -> NonEmpty Int+buildMiddleQuery x = 0 :| go x+ where+ go n =+ let half = floor ((fromIntegral n)/2)+ in if half == 0+ then []+ else half : go (floor $ (fromIntegral n)/2)+++genListTrie :: Int -> ListTrie Int Int+genListTrie n = ListTrie $ Node (0, Just 0) $ genTree n+ where+ genTree :: Int -> [Tree (Int, Maybe Int)]+ genTree n = flip evalState 1 $ replicateM n $ do+ i <- getSucc+ return $ Node (i, Just 0) $ genTree (floor $ (fromIntegral n)/2)+++getSucc :: State Int Int+getSucc = do+ i <- get+ modify (+1)+ pure i+++genMapTrie :: Int -> MapTrie Int Int+genMapTrie n = MapTrie . MapStep . Map.singleton 0 $+ MapChildren (Just 0) $ Just . MapTrie . MapStep $ genMapTree n+ where+ genMapTree :: Int -> Map.Map Int (MapChildren MapTrie Int Int)+ genMapTree n =+ Map.unions . flip evalState 1 $+ replicateM n $ do+ i <- getSucc+ pure $ Map.singleton i $+ MapChildren (Just 0) $+ if n <= 1+ then Nothing+ else Just . MapTrie . MapStep $ genMapTree (floor $ (fromIntegral n)/2)+++genHashMapTrie :: Int -> HashMapTrie Int Int+genHashMapTrie n = HashMapTrie $ HashMapStep $ HMap.singleton 0 $+ HashMapChildren (Just 0) $ Just . HashMapTrie . HashMapStep $ genHashMapTree n+ where+ genHashMapTree :: Int -> HMap.HashMap Int (HashMapChildren HashMapTrie Int Int)+ genHashMapTree n = HMap.unions $ flip evalState 1 $+ replicateM n $ do+ i <- getSucc+ return $ HMap.singleton i $+ HashMapChildren (Just 0) $+ if n <= 1+ then Nothing+ else Just . HashMapTrie . HashMapStep $ genHashMapTree (floor $ fromIntegral n / 2)++++-- | This one is ordered largest first+genKnuthTrie :: Int -> KnuthTrie Int Int+genKnuthTrie n = KnuthTrie $ Fork (0, Just 0) (genKnuthForest n n) Nil+ where+ genKnuthForest :: Int -> Int -> KnuthForest (Int, Maybe Int)+ genKnuthForest 0 _ = Nil+ genKnuthForest n s = let cs = if n == 0 then Nil else genKnuthForest (floor $ (fromIntegral n)/2) (n-1)+ ss = if s == 0 then Nil else genKnuthForest n (s-1)+ in Fork (s, Just 0) cs ss
+ bench-lookup/Main.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE+ FlexibleContexts+ #-}++module Main where++import Build++import Data.Trie.Class as TC+import Criterion.Main+++main = defaultMain+ [ bgroup "lookup"+ [ bgroup "ListTrie" $ benchOne genListTrie <$> [10,20..100]+ , bgroup "MapTrie" $ benchOne genMapTrie <$> [10,20..100]+ , bgroup "HashMapTrie" $ benchOne genHashMapTrie <$> [10,20..100]+ , bgroup "KnuthTrie" $ benchOne genKnuthTrie <$> [10,20..100]+ ]+ ]+ where+ benchOne gen x = bench (show x) $ whnf (TC.lookup $ buildMiddleQuery x) (gen 100)
− bench/Bench.hs
@@ -1,55 +0,0 @@-{-# LANGUAGE- FlexibleContexts- #-}--module Main where--import Build--import Data.List.NonEmpty (NonEmpty (..))-import qualified Data.List.NonEmpty as NE-import Data.Tree (Tree (..))-import Data.Trie.List as L-import Data.Trie.Map as M-import Data.Trie.HashMap as HM-import Data.Tree.Knuth.Forest as K-import Data.Trie.Knuth as K-import Data.Trie.Class as TC-import qualified Data.Map as Map-import qualified Data.HashMap.Lazy as HMap-import Criterion.Main-import Control.Monad.State----deleteMany :: ( Trie NonEmpty Int c- ) => Int -> c Int a -> c Int a-deleteMany top xs =- foldr- (\p -> TC.delete $ buildMiddleQuery top)- xs- [1..top]--insertMany :: ( Trie NonEmpty Int c- ) => Int -> c Int Int -> c Int Int-insertMany top xs =- foldr- (\p -> TC.insert (buildMiddleQuery top) 0)- xs- [1..top]---main = defaultMain- [ bgroup "delete"- [ bench "ListTrie" $ whnf (deleteMany 100) (genListTrie 100)- , bench "MapTrie" $ whnf (deleteMany 100) (genMapTrie 100)- , bench "HashMapTrie" $ whnf (deleteMany 100) (genHashMapTrie 100)- , bench "KnuthTrie" $ whnf (deleteMany 100) (genKnuthTrie 100)- ]- , bgroup "insert"- [ bench "ListTrie" $ whnf (insertMany 100) (genListTrie 100)- , bench "MapTrie1" $ whnf (insertMany 100) (genMapTrie 100)- , bench "HashMapTrie" $ whnf (insertMany 100) (genHashMapTrie 100)- , bench "KnuthTrie" $ whnf (insertMany 100) (genKnuthTrie 100)- ]- ]
− bench/BenchLookup.hs
@@ -1,22 +0,0 @@-{-# LANGUAGE- FlexibleContexts- #-}--module Main where--import Build--import Data.Trie.Class as TC-import Criterion.Main---main = defaultMain- [ bgroup "lookup"- [ bgroup "ListTrie" $ benchOne genListTrie <$> [10,20..100]- , bgroup "MapTrie" $ benchOne genMapTrie <$> [10,20..100]- , bgroup "HashMapTrie" $ benchOne genHashMapTrie <$> [10,20..100]- , bgroup "KnuthTrie" $ benchOne genKnuthTrie <$> [10,20..100]- ]- ]- where- benchOne gen x = bench (show x) $ whnf (TC.lookup $ buildMiddleQuery x) (gen 100)
− bench/Build.hs
@@ -1,83 +0,0 @@-module Build where----import Data.List.NonEmpty (NonEmpty (..))-import Data.Tree (Tree (..))-import Data.Trie.List as L-import Data.Trie.Map as M-import Data.Trie.HashMap as HM-import Data.Tree.Knuth.Forest as K-import Data.Trie.Knuth as K-import qualified Data.Map as Map-import qualified Data.HashMap.Lazy as HMap-import Control.Monad.State---buildMiddleQuery :: Int -> NonEmpty Int-buildMiddleQuery x = 0 :| go x- where- go n =- let half = floor ((fromIntegral n)/2)- in if half == 0- then []- else half : go (floor $ (fromIntegral n)/2)---genListTrie :: Int -> ListTrie Int Int-genListTrie n = ListTrie $ Node (0, Just 0) $ genTree n- where- genTree :: Int -> [Tree (Int, Maybe Int)]- genTree n = flip evalState 1 $ replicateM n $ do- i <- getSucc- return $ Node (i, Just 0) $ genTree (floor $ (fromIntegral n)/2)---getSucc :: State Int Int-getSucc = do- i <- get- modify (+1)- pure i---genMapTrie :: Int -> MapTrie Int Int-genMapTrie n = MapTrie . MapStep . Map.singleton 0 $- MapChildren (Just 0) $ Just . MapTrie . MapStep $ genMapTree n- where- genMapTree :: Int -> Map.Map Int (MapChildren MapTrie Int Int)- genMapTree n =- Map.unions . flip evalState 1 $- replicateM n $ do- i <- getSucc- pure $ Map.singleton i $- MapChildren (Just 0) $- if n <= 1- then Nothing- else Just . MapTrie . MapStep $ genMapTree (floor $ (fromIntegral n)/2)---genHashMapTrie :: Int -> HashMapTrie Int Int-genHashMapTrie n = HashMapTrie $ HashMapStep $ HMap.singleton 0 $- HashMapChildren (Just 0) $ Just . HashMapTrie . HashMapStep $ genHashMapTree n- where- genHashMapTree :: Int -> HMap.HashMap Int (HashMapChildren HashMapTrie Int Int)- genHashMapTree n = HMap.unions $ flip evalState 1 $- replicateM n $ do- i <- getSucc- return $ HMap.singleton i $- HashMapChildren (Just 0) $- if n <= 1- then Nothing- else Just . HashMapTrie . HashMapStep $ genHashMapTree (floor $ fromIntegral n / 2)------ | This one is ordered largest first-genKnuthTrie :: Int -> KnuthTrie Int Int-genKnuthTrie n = KnuthTrie $ Fork (0, Just 0) (genKnuthForest n n) Nil- where- genKnuthForest :: Int -> Int -> KnuthForest (Int, Maybe Int)- genKnuthForest 0 _ = Nil- genKnuthForest n s = let cs = if n == 0 then Nil else genKnuthForest (floor $ (fromIntegral n)/2) (n-1)- ss = if s == 0 then Nil else genKnuthForest n (s-1)- in Fork (s, Just 0) cs ss
src/Data/Trie/Class.hs view
@@ -9,11 +9,9 @@ import qualified Data.Trie as BT import qualified Data.ByteString as BS -import Data.Function.Syntax-import Data.Maybe (isJust, fromMaybe)+import Data.Maybe (isJust) import Data.Foldable as F import Data.Functor.Identity (Identity (..))--- import Data.Map.TernaryMap as TM -- | Class representing tries with single-threaded insertion, deletion, and lookup.@@ -24,16 +22,14 @@ insert :: p s -> a -> t s a -> t s a delete :: p s -> t s a -> t s a -lookupWithDefault :: Trie p s t => a -> p s -> t s a -> a-lookupWithDefault x = fromMaybe x .* lookup member :: Trie p s t => p s -> t s a -> Bool-member = isJust .* lookup+member t = isJust . lookup t notMember :: Trie p s t => p s -> t s a -> Bool-notMember = not .* member+notMember t = not . member t -- * Conversion @@ -41,13 +37,6 @@ fromFoldable = F.foldr (uncurry insert) mempty --- * Ternary Map---- TODO--- instance Ord k => Trie [] k TernaryMap where--- lookup = TM.lookup--- delete = TM.delete- -- * ByteString-Trie -- | Embeds an empty ByteString passed around for type inference.@@ -60,6 +49,6 @@ getBSTrie (BSTrie (_,x)) = x instance Trie Identity BS.ByteString BSTrie where- lookup = (BT.lookup *. snd . unBSTrie) . runIdentity+ lookup (Identity ps) (BSTrie (_,xs)) = BT.lookup ps xs insert (Identity ps) x (BSTrie (q,xs)) = BSTrie (q, BT.insert ps x xs) delete (Identity ps) (BSTrie (q,xs)) = BSTrie (q, BT.delete ps xs)
src/Data/Trie/HashMap.hs view
@@ -15,29 +15,29 @@ module Data.Trie.HashMap where -import Data.Trie.Class-import Data.Monoid-import Data.Hashable+import Data.Trie.Class (Trie (..))+import Data.Monoid (First (..), Last (..), (<>))+import Data.Hashable (Hashable) import Data.Maybe (fromMaybe, fromJust) import qualified Data.Foldable as F import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE import qualified Data.HashMap.Lazy as HM import qualified Data.Key as K-import Control.Monad+import Control.Monad (replicateM) -import Data.Data-import GHC.Generics-import Control.DeepSeq+import Data.Data (Data, Typeable)+import GHC.Generics (Generic)+import Control.DeepSeq (NFData) import Prelude hiding (lookup, null)-import Test.QuickCheck+import Test.QuickCheck (Arbitrary (..), resize, choose, sized, scale) import Test.QuickCheck.Instances () -- * One Step data HashMapChildren c p a = HashMapChildren- { hashMapNode :: Maybe a+ { hashMapNode :: !(Maybe a) , hashMapChildren :: !(Maybe (c p a)) } deriving (Show, Eq, Functor, Foldable, Traversable, Generic, Data, Typeable) @@ -50,13 +50,13 @@ , Arbitrary p , Arbitrary (c p a) ) => Arbitrary (HashMapChildren c p a) where- arbitrary = HashMapChildren <$> arbitrary <*> scale (\n -> floor $ fromIntegral n / 2) arbitrary+ arbitrary = HashMapChildren <$> arbitrary <*> scale (`div` 2) arbitrary instance ( Monoid (c p a) ) => Monoid (HashMapChildren c p a) where mempty = HashMapChildren Nothing Nothing mappend (HashMapChildren mx mxs) (HashMapChildren my mys) =- HashMapChildren (getLast $ Last mx <> Last my)+ HashMapChildren (getLast (Last mx <> Last my)) (mxs <> mys) newtype HashMapStep c p a = HashMapStep@@ -78,8 +78,8 @@ where go n = do i <- choose (0,n)- xs <- replicateM i $ (,) <$> arbitrary <*> resize (floor $ fromIntegral n / 2) arbitrary- return $ HashMapStep $ HM.fromList xs+ xs <- replicateM i $ (,) <$> arbitrary <*> resize (n `div` 2) arbitrary+ pure (HashMapStep (HM.fromList xs)) instance ( Hashable p , Eq p@@ -93,14 +93,13 @@ =<< HM.lookup p xs delete (p:|ps) (HashMapStep xs) | F.null ps = let mxs = hashMapChildren =<< HM.lookup p xs- in HashMapStep $! HM.insert p (HashMapChildren Nothing $! mxs) xs+ in HashMapStep (HM.insert p (HashMapChildren Nothing mxs) xs) | otherwise = let (HashMapChildren mx mxs) = fromMaybe (HashMapChildren Nothing Nothing) (HM.lookup p xs)- in HashMapStep $! HM.insert p- (HashMapChildren mx $!- delete (NE.fromList ps) <$> mxs)- xs+ in HashMapStep (HM.insert p+ (HashMapChildren mx (delete (NE.fromList ps) <$> mxs))+ xs) insert :: ( Hashable p , Eq p@@ -109,15 +108,15 @@ ) => NonEmpty p -> a -> HashMapStep c p a -> HashMapStep c p a insert (p:|ps) x (HashMapStep xs) | F.null ps = let mxs = hashMapChildren =<< HM.lookup p xs- in HashMapStep $! HM.insert p- (HashMapChildren (Just x) $! mxs)- xs+ in HashMapStep (HM.insert p+ (HashMapChildren (Just x) $! mxs)+ xs) | otherwise = let mx = hashMapNode =<< HM.lookup p xs- xs' = fromMaybe mempty $! hashMapChildren =<< HM.lookup p xs- in HashMapStep $! HM.insert p- (HashMapChildren mx $- Just $! Data.Trie.Class.insert (NE.fromList ps) x xs')- xs+ xs' = fromMaybe mempty (hashMapChildren =<< HM.lookup p xs)+ in HashMapStep (HM.insert p+ (HashMapChildren mx+ (Just (Data.Trie.Class.insert (NE.fromList ps) x xs')))+ xs) {-# INLINEABLE insert #-} @@ -127,13 +126,13 @@ ) => Monoid (HashMapStep c p a) where mempty = empty mappend (HashMapStep xs) (HashMapStep ys) =- HashMapStep $ HM.unionWith (<>) xs ys+ HashMapStep (HM.unionWith (<>) xs ys) empty :: HashMapStep c p a empty = HashMapStep HM.empty singleton :: Hashable p => p -> a -> HashMapStep c p a-singleton p x = HashMapStep $! HM.singleton p $ HashMapChildren (Just x) Nothing+singleton p x = HashMapStep (HM.singleton p (HashMapChildren (Just x) Nothing)) {-# INLINEABLE singleton #-} @@ -149,8 +148,8 @@ , Eq p ) => Trie NonEmpty p HashMapTrie where lookup ts (HashMapTrie xs) = lookup ts xs- delete ts (HashMapTrie xs) = HashMapTrie $ delete ts xs- insert ts x (HashMapTrie xs) = HashMapTrie $ Data.Trie.HashMap.insert ts x xs+ delete ts (HashMapTrie xs) = HashMapTrie (delete ts xs)+ insert ts x (HashMapTrie xs) = HashMapTrie (Data.Trie.HashMap.insert ts x xs) type instance K.Key (HashMapTrie p) = NonEmpty p @@ -168,10 +167,10 @@ let ks = HM.keys xs in F.concatMap go ks where- go k = let (HashMapChildren _ mxs) = fromJust $ HM.lookup k xs- in map (k :|) $ fromMaybe [] $ do- xs' <- mxs- return $ NE.toList <$> keys xs'+ go k = let (HashMapChildren _ mxs) = fromJust (HM.lookup k xs)+ in case mxs of+ Nothing -> []+ Just xs' -> NE.cons k <$> keys xs' {-# INLINEABLE keys #-} @@ -196,11 +195,11 @@ ) => NonEmpty p -> HashMapTrie p a -> Maybe (NonEmpty p, a, [p]) match (p:|ps) (HashMapTrie (HashMapStep xs)) = do (HashMapChildren mx mxs) <- HM.lookup p xs- let mFoundHere = (p:|[],, ps) <$> mx+ let mFoundHere = (p:|[],,ps) <$> mx if F.null ps then mFoundHere else getFirst $ First (do (pre,y,suff) <- match (NE.fromList ps) =<< mxs- pure (p:|NE.toList pre, y, suff))+ pure (NE.cons p pre, y, suff)) <> First mFoundHere {-# INLINEABLE match #-}@@ -211,13 +210,17 @@ , Eq p ) => NonEmpty p -> HashMapTrie p a -> [(NonEmpty p, a, [p])] matches (p:|ps) (HashMapTrie (HashMapStep xs)) =- let (HashMapChildren mx mxs) = fromMaybe mempty $ HM.lookup p xs- foundHere = fromMaybe [] $ (\x -> [(p:|[],x,ps)]) <$> mx- in if F.null ps- then foundHere- else let rs = fromMaybe [] $ matches (NE.fromList ps) <$> mxs- in foundHere ++ (prependAncestry <$> rs)- where prependAncestry (pre,x,suff) = (p:| NE.toList pre,x,suff)+ let (HashMapChildren mx mxs) = fromMaybe mempty (HM.lookup p xs)+ foundHere = case mx of+ Nothing -> []+ Just x -> [(p:|[],x,ps)]+ in if F.null ps+ then foundHere+ else let rs = case mxs of+ Nothing -> []+ Just xs' -> matches (NE.fromList ps) xs'+ in foundHere ++ (prependAncestry <$> rs)+ where prependAncestry (pre,x,suff) = (NE.cons p pre,x,suff) {-# INLINEABLE matches #-}
src/Data/Trie/Knuth.hs view
@@ -16,12 +16,12 @@ import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE -import Data.Trie.Class+import Data.Trie.Class (Trie (..)) -import Data.Data-import GHC.Generics-import Control.DeepSeq-import Test.QuickCheck+import Data.Data (Data, Typeable)+import GHC.Generics (Generic)+import Control.DeepSeq (NFData)+import Test.QuickCheck (Arbitrary) newtype KnuthTrie s x = KnuthTrie
src/Data/Trie/List.hs view
@@ -12,7 +12,7 @@ module Data.Trie.List where -import Data.Trie.Class+import Data.Trie.Class (Trie (..)) import Prelude hiding (lookup) import Data.Tree (Tree (..))@@ -21,13 +21,13 @@ import Data.Maybe (fromMaybe) import Data.Key hiding (lookup)-import Data.Monoid-import Control.Monad+import Data.Monoid (First (..))+import Control.Monad (guard) -import Data.Data-import GHC.Generics-import Control.DeepSeq-import Test.QuickCheck+import Data.Data (Data, Typeable)+import GHC.Generics (Generic)+import Control.DeepSeq (NFData)+import Test.QuickCheck (Arbitrary (..)) import Test.QuickCheck.Instances ()
src/Data/Trie/Map.hs view
@@ -10,11 +10,13 @@ , FlexibleInstances , FlexibleContexts , MultiParamTypeClasses+ , RankNTypes+ , ScopedTypeVariables #-} module Data.Trie.Map where -import Data.Trie.Class+import Data.Trie.Class (Trie (..)) import Prelude hiding (lookup, null) import qualified Data.Map as Map@@ -23,14 +25,14 @@ import qualified Data.Key as K import qualified Data.Foldable as F-import Data.Maybe-import Data.Monoid-import Control.Monad+import Data.Maybe (fromMaybe, fromJust)+import Data.Monoid (First (..), Last (..), (<>))+import Control.Monad (replicateM) -import Data.Data-import GHC.Generics-import Control.DeepSeq-import Test.QuickCheck+import Data.Data (Data, Typeable)+import GHC.Generics (Generic)+import Control.DeepSeq (NFData)+import Test.QuickCheck (Arbitrary (..), resize, choose, sized, scale) import Test.QuickCheck.Instances () @@ -38,7 +40,7 @@ -- * One Step data MapChildren c p a = MapChildren- { mapNode :: Maybe a+ { mapNode :: !(Maybe a) , mapChildren :: !(Maybe (c p a)) } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic, Data, Typeable) @@ -51,7 +53,7 @@ , Arbitrary p , Arbitrary (c p a) ) => Arbitrary (MapChildren c p a) where- arbitrary = MapChildren <$> arbitrary <*> scale (\n -> floor $ fromIntegral n / 2) arbitrary+ arbitrary = MapChildren <$> arbitrary <*> scale (`div` 2) arbitrary instance ( Monoid (c p a) ) => Monoid (MapChildren c p a) where@@ -79,7 +81,7 @@ where go n = do i <- choose (0,n)- xs <- replicateM i $ (,) <$> arbitrary <*> resize (floor $ fromIntegral n / 2) arbitrary+ xs <- replicateM i $ (,) <$> arbitrary <*> resize (n `div` 2) arbitrary return $ MapStep $ Map.fromList xs @@ -93,9 +95,9 @@ | otherwise = lookup (NE.fromList ps) =<< mapChildren =<< Map.lookup p xs delete (p:|ps) (MapStep xs) | F.null ps = let mxs = mapChildren =<< Map.lookup p xs- in MapStep $! Map.insert p (MapChildren Nothing mxs) xs- | otherwise = let (MapChildren mx mxs) = fromMaybe (MapChildren Nothing Nothing) $! Map.lookup p xs- in MapStep $! Map.insert p (MapChildren mx $! delete (NE.fromList ps) <$> mxs) xs+ in MapStep (Map.insert p (MapChildren Nothing mxs) xs)+ | otherwise = let (MapChildren mx mxs) = fromMaybe (MapChildren Nothing Nothing) (Map.lookup p xs)+ in MapStep (Map.insert p (MapChildren mx (delete (NE.fromList ps) <$> mxs)) xs) insert :: ( Ord p@@ -104,10 +106,10 @@ ) => NonEmpty p -> a -> MapStep c p a -> MapStep c p a insert (p:|ps) x (MapStep xs) | F.null ps = let mxs = mapChildren =<< Map.lookup p xs- in MapStep $! Map.insert p (MapChildren (Just x) mxs) xs+ in MapStep (Map.insert p (MapChildren (Just x) mxs) xs) | otherwise = let mx = mapNode =<< Map.lookup p xs xs' = fromMaybe mempty (mapChildren =<< Map.lookup p xs)- in MapStep $! Map.insert p (MapChildren mx $ Just $! Data.Trie.Class.insert (NE.fromList ps) x xs') xs+ in MapStep (Map.insert p (MapChildren mx (Just (Data.Trie.Class.insert (NE.fromList ps) x xs'))) xs) {-# INLINEABLE insert #-} @@ -123,7 +125,7 @@ empty = MapStep Map.empty singleton :: s -> a -> MapStep c s a-singleton p x = MapStep $ Map.singleton p $ MapChildren (Just x) Nothing+singleton p x = MapStep (Map.singleton p (MapChildren (Just x) Nothing)) -- * Fixpoint of Steps@@ -134,8 +136,8 @@ instance Ord s => Trie NonEmpty s MapTrie where lookup ts (MapTrie xs) = lookup ts xs- delete ts (MapTrie xs) = MapTrie $ delete ts xs- insert ts x (MapTrie xs) = MapTrie $ Data.Trie.Map.insert ts x xs+ delete ts (MapTrie xs) = MapTrie (delete ts xs)+ insert ts x (MapTrie xs) = MapTrie (Data.Trie.Map.insert ts x xs) type instance K.Key (MapTrie s) = NonEmpty s @@ -147,15 +149,15 @@ -- * Conversion -keys :: Ord s => MapTrie s a -> [NonEmpty s]+keys :: forall s a. Ord s => MapTrie s a -> [NonEmpty s] keys (MapTrie (MapStep xs)) =- let ks = Map.keys xs- in F.concatMap go ks+ F.concatMap go (Map.keys xs) where- go k = let (MapChildren _ mxs) = fromJust $ Map.lookup k xs- in fmap (k :|) $ fromMaybe [] $ do- xs' <- mxs- return $ NE.toList <$> keys xs'+ go :: s -> [NonEmpty s]+ go k = let (MapChildren _ mxs) = fromJust (Map.lookup k xs)+ in case mxs of+ Nothing -> []+ Just xs' -> NE.cons k <$> keys xs' elems :: MapTrie s a -> [a] elems = F.toList@@ -172,11 +174,13 @@ match (p:|ps) (MapTrie (MapStep xs)) = do (MapChildren mx mxs) <- Map.lookup p xs let mFoundHere = do x <- mx- return (p:|[], x, ps)- if F.null ps then mFoundHere- else getFirst $ First (do (pre,y,suff) <- match (NE.fromList ps) =<< mxs- return (p:|NE.toList pre, y, suff))- <> First mFoundHere+ pure (p:|[], x, ps)+ if F.null ps+ then mFoundHere+ else getFirst $+ First (do (pre,y,suff) <- match (NE.fromList ps) =<< mxs+ pure (p:|NE.toList pre, y, suff))+ <> First mFoundHere -- | Returns a list of all the nodes along the path to the furthest point in the -- query, in order of the path walked from the root to the furthest point.@@ -187,9 +191,10 @@ Map.lookup p xs foundHere = fromMaybe [] $ do x <- mx return [(p:|[],x,ps)]- in if F.null ps then foundHere- else let rs = fromMaybe [] $ matches (NE.fromList ps) <$> mxs- in foundHere ++ (prependAncestry <$> rs)+ in if F.null ps+ then foundHere+ else let rs = fromMaybe [] $ matches (NE.fromList ps) <$> mxs+ in foundHere ++ (prependAncestry <$> rs) where prependAncestry (pre,x,suff) = (p:| NE.toList pre,x,suff)
tries.cabal view
@@ -1,97 +1,116 @@-Name: tries-Version: 0.0.4.2-Author: Athan Clark <athan.clark@gmail.com>-Maintainer: Athan Clark <athan.clark@gmail.com>-License: BSD3-License-File: LICENSE-Synopsis: Various trie implementations in Haskell--- Description:-Cabal-Version: >= 1.10-Build-Type: Simple-Category: Data, Tree--flag Lookup- Description: Benchmark the lookup functions- Default: False+-- This file has been generated from package.yaml by hpack version 0.21.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: 022bdce10844410f3e9663fa23513d9739331172dc3fbd52e1a4c1e7af9485f3 -Library- Default-Language: Haskell2010- HS-Source-Dirs: src- GHC-Options: -Wall- Exposed-Modules: Data.Trie.Class- Data.Trie.HashMap- Data.Trie.Knuth- Data.Trie.List- Data.Trie.Map- Data.Trie.Pseudo- Build-Depends: base >= 4.8 && < 5- , bytestring- , bytestring-trie- , composition- , composition-extra >= 2.0.0- , containers- , deepseq- , hashable- , keys--- , TernaryTrees- , rose-trees >= 0.0.2.1- , semigroups- , sets >= 0.0.5.2- , unordered-containers- , QuickCheck >= 2.9.2- , quickcheck-instances+name: tries+version: 0.0.5+synopsis: Various trie implementations in Haskell+description: Please see the README on Github at <https://git.localcooking.com/tooling/tries#readme>+category: Data, Tree+homepage: https://github.com/athanclark/tries#readme+bug-reports: https://github.com/athanclark/tries/issues+author: Athan Clark+maintainer: athan.clark@localcooking.com+copyright: 2018 Athan Clark+license: BSD3+license-file: LICENSE+build-type: Simple+cabal-version: >= 1.10 -Test-Suite test- Type: exitcode-stdio-1.0- Default-Language: Haskell2010- Hs-Source-Dirs: test- Ghc-Options: -Wall -threaded- Main-Is: Spec.hs- Other-Modules: Data.TrieSpec- Build-Depends: base- , tries- , containers- , mtl- , tasty- , tasty-quickcheck- , QuickCheck- , quickcheck-instances+extra-source-files:+ README.md +source-repository head+ type: git+ location: https://github.com/athanclark/tries -Benchmark bench- Type: exitcode-stdio-1.0- Default-Language: Haskell2010- Hs-Source-Dirs: bench- Ghc-Options: -Wall -threaded- Main-Is: Bench.hs- Other-Modules: Build- Build-Depends: base- , tries- , criterion- , rose-trees- , mtl- , unordered-containers- , containers+library+ exposed-modules:+ Data.Trie.Class+ Data.Trie.HashMap+ Data.Trie.Knuth+ Data.Trie.List+ Data.Trie.Map+ Data.Trie.Pseudo+ other-modules:+ Paths_tries+ hs-source-dirs:+ src+ ghc-options: -Wall+ build-depends:+ QuickCheck >=2.9.2+ , base >=4.8 && <5.0+ , bytestring+ , bytestring-trie+ , composition+ , containers+ , deepseq+ , hashable+ , keys+ , quickcheck-instances+ , rose-trees >=0.0.2.1+ , semigroups+ , sets >=0.0.5.2+ , unordered-containers+ default-language: Haskell2010 -Benchmark bench-lookup- if flag(Lookup)- Buildable: True- else- Buildable: False- Type: exitcode-stdio-1.0- Default-Language: Haskell2010- Hs-Source-Dirs: bench- Ghc-Options: -Wall -threaded- Main-Is: BenchLookup.hs- Other-Modules: Build- Build-Depends: base- , tries- , criterion- , rose-trees- , mtl- , unordered-containers- , containers+test-suite tries-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Data.TrieSpec+ Paths_tries+ hs-source-dirs:+ test+ ghc-options: -Wall -threaded -rtsopts -Wall -with-rtsopts=-N+ build-depends:+ QuickCheck+ , base >=4.8 && <5.0+ , bytestring+ , bytestring-trie+ , composition+ , containers+ , deepseq+ , hashable+ , keys+ , mtl+ , quickcheck-instances+ , rose-trees >=0.0.2.1+ , semigroups+ , sets >=0.0.5.2+ , tasty+ , tasty-quickcheck+ , tries+ , unordered-containers+ default-language: Haskell2010 -Source-Repository head- Type: git- Location: https://github.com/athanclark/tries.git+benchmark tries-bench-lookup+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules:+ Build+ Paths_tries+ hs-source-dirs:+ bench-lookup+ ghc-options: -Wall -threaded -rtsopts -Wall -with-rtsopts=-N+ build-depends:+ QuickCheck >=2.9.2+ , base >=4.8 && <5.0+ , bytestring+ , bytestring-trie+ , composition+ , containers+ , criterion+ , deepseq+ , hashable+ , keys+ , mtl+ , quickcheck-instances+ , rose-trees+ , semigroups+ , sets >=0.0.5.2+ , tries+ , unordered-containers+ default-language: Haskell2010