Remove Trie, I couldn't use it after all
This commit is contained in:
parent
1b0b4c2ab8
commit
faa8eb0a94
@ -29,7 +29,6 @@ library
|
|||||||
Network.Reddit
|
Network.Reddit
|
||||||
Data.SubReddit
|
Data.SubReddit
|
||||||
Publish
|
Publish
|
||||||
Data.Trie
|
|
||||||
Membership
|
Membership
|
||||||
|
|
||||||
-- Modules included in this library but not exported.
|
-- Modules included in this library but not exported.
|
||||||
@ -71,7 +70,7 @@ executable reddit-pub
|
|||||||
test-suite reddit-tests
|
test-suite reddit-tests
|
||||||
main-is: Spec.hs
|
main-is: Spec.hs
|
||||||
type: exitcode-stdio-1.0
|
type: exitcode-stdio-1.0
|
||||||
other-modules: Test.Data.Trie
|
other-modules:
|
||||||
|
|
||||||
-- Modules included in this executable, other than Main.
|
-- Modules included in this executable, other than Main.
|
||||||
-- other-modules:
|
-- other-modules:
|
||||||
|
@ -1,78 +0,0 @@
|
|||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE DeriveFunctor #-}
|
|
||||||
{-# LANGUAGE LambdaCase #-}
|
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
|
||||||
{-# LANGUAGE TypeSynonymInstances #-}
|
|
||||||
-- I know theres the bytestring-trie package, but it's been kind of
|
|
||||||
-- unmaintained lately, I don't have the time to start pinning and stuff.
|
|
||||||
module Data.Trie where
|
|
||||||
|
|
||||||
import Data.ByteString (ByteString)
|
|
||||||
import Data.Map.Strict (Map)
|
|
||||||
import qualified Data.Foldable as F
|
|
||||||
import qualified Data.Map.Strict as M
|
|
||||||
import qualified Data.ByteString as B
|
|
||||||
import Data.Word (Word8)
|
|
||||||
import Data.Maybe (isJust)
|
|
||||||
|
|
||||||
data Pair a b = Pair !a !b
|
|
||||||
|
|
||||||
instance (Semigroup a, Semigroup b) => Semigroup (Pair a b) where
|
|
||||||
(Pair a b) <> (Pair a' b') = Pair (a <> a') (b <> b')
|
|
||||||
|
|
||||||
-- XXX: This is as lazy as it gets, strictify where it's needed
|
|
||||||
data TrieF a f
|
|
||||||
= Empty
|
|
||||||
| ElementNode (Maybe (Pair ByteString a)) (Map Word8 f)
|
|
||||||
deriving Functor
|
|
||||||
|
|
||||||
newtype Fix f = Fix { getFix :: f (Fix f) }
|
|
||||||
|
|
||||||
type Trie a = Fix (TrieF a)
|
|
||||||
|
|
||||||
type TrieSet = Trie ()
|
|
||||||
|
|
||||||
cata :: Functor f => (f a -> a) -> Fix f -> a
|
|
||||||
cata f = c where c = f . fmap c . getFix
|
|
||||||
|
|
||||||
ana :: Functor f => (a -> f a) -> a -> Fix f
|
|
||||||
ana f = c where c = Fix . fmap c . f
|
|
||||||
|
|
||||||
fromList :: Semigroup a => [(ByteString, a)] -> Trie a
|
|
||||||
fromList = F.foldl' (\acc (k,v) -> insert k v acc) empty
|
|
||||||
|
|
||||||
toList :: Trie a -> [(ByteString, a)]
|
|
||||||
toList = cata $ \case
|
|
||||||
Empty -> []
|
|
||||||
ElementNode (Just (Pair a b)) children -> (a,b) : concat (M.elems children)
|
|
||||||
ElementNode Nothing children -> concat (M.elems children)
|
|
||||||
|
|
||||||
insert :: Semigroup a => ByteString -> a -> Trie a -> Trie a
|
|
||||||
insert k v = union (singleton k v)
|
|
||||||
|
|
||||||
singleton :: ByteString -> a -> Trie a
|
|
||||||
singleton bs a = ana go (B.uncons bs)
|
|
||||||
where
|
|
||||||
go Nothing = let x = Pair bs a in x `seq` ElementNode (Just x) M.empty
|
|
||||||
go (Just (w8,children)) = ElementNode Nothing (M.singleton w8 (B.uncons children))
|
|
||||||
|
|
||||||
union :: Semigroup a => Trie a -> Trie a -> Trie a
|
|
||||||
union a (Fix Empty) = a
|
|
||||||
union (Fix Empty) b = b
|
|
||||||
union (Fix (ElementNode ma' x1)) (Fix (ElementNode ma x0)) =
|
|
||||||
let x = ma' <> ma
|
|
||||||
in x `seq` Fix (ElementNode x (M.unionWith union x1 x0))
|
|
||||||
|
|
||||||
empty :: Trie a
|
|
||||||
empty = Fix Empty
|
|
||||||
|
|
||||||
lookup :: forall a. ByteString -> Trie a -> Maybe a
|
|
||||||
lookup bs t = cata go t $ B.uncons bs
|
|
||||||
where
|
|
||||||
go :: TrieF a (Maybe (Word8, ByteString) -> Maybe a) -> Maybe (Word8, ByteString) -> Maybe a
|
|
||||||
go Empty _ = Nothing
|
|
||||||
go (ElementNode ma' _) Nothing = fmap (\(Pair _ b) -> b) ma'
|
|
||||||
go (ElementNode _ m) (Just (w8,xs)) = M.lookup w8 m >>= \next -> next (B.uncons xs)
|
|
||||||
|
|
||||||
member :: ByteString -> Trie a -> Bool
|
|
||||||
member bs = isJust . Data.Trie.lookup bs
|
|
@ -2,8 +2,5 @@ module Main where
|
|||||||
|
|
||||||
import Test.Hspec (hspec)
|
import Test.Hspec (hspec)
|
||||||
|
|
||||||
import qualified Test.Data.Trie as Data.Trie
|
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = hspec $
|
main = hspec $ pure ()
|
||||||
Data.Trie.spec
|
|
||||||
|
@ -1,32 +0,0 @@
|
|||||||
{-# LANGUAGE NamedFieldPuns #-}
|
|
||||||
module Test.Data.Trie where
|
|
||||||
|
|
||||||
import Test.Hspec
|
|
||||||
import Test.Hspec.Hedgehog
|
|
||||||
import Data.ByteString (ByteString)
|
|
||||||
import qualified Hedgehog.Gen as Gen
|
|
||||||
import qualified Hedgehog.Range as Range
|
|
||||||
|
|
||||||
import qualified Data.Map.Strict as M
|
|
||||||
import Control.Monad.State (evalStateT, foldM, execStateT, StateT (runStateT))
|
|
||||||
import qualified Data.Foldable as F
|
|
||||||
import qualified Data.Trie as Trie
|
|
||||||
import Data.Monoid
|
|
||||||
|
|
||||||
genByteString :: Gen ByteString
|
|
||||||
genByteString = Gen.bytes (Range.linear 0 50)
|
|
||||||
|
|
||||||
genModel :: Gen (M.Map ByteString (Sum Int))
|
|
||||||
genModel = Gen.map (Range.linear 0 30) genT
|
|
||||||
where
|
|
||||||
genT = (,) <$> genByteString <*> (Sum <$> Gen.integral (Range.linear 0 1000))
|
|
||||||
|
|
||||||
propInsert :: PropertyT IO ()
|
|
||||||
propInsert = do
|
|
||||||
model <- forAll genModel
|
|
||||||
let got = F.foldl' (\acc (k,v) -> Trie.insert k v acc) Trie.empty $ M.toList model
|
|
||||||
model === M.fromList (Trie.toList got)
|
|
||||||
|
|
||||||
spec :: Spec
|
|
||||||
spec = describe "Data.Trie" $
|
|
||||||
it "inserts as with Map" $ hedgehog propInsert
|
|
Loading…
Reference in New Issue
Block a user