Remove Trie, I couldn't use it after all
This commit is contained in:
		@@ -29,7 +29,6 @@ library
 | 
			
		||||
                      Network.Reddit
 | 
			
		||||
                      Data.SubReddit
 | 
			
		||||
                      Publish
 | 
			
		||||
                      Data.Trie
 | 
			
		||||
                      Membership
 | 
			
		||||
 | 
			
		||||
    -- Modules included in this library but not exported.
 | 
			
		||||
@@ -71,7 +70,7 @@ executable reddit-pub
 | 
			
		||||
test-suite reddit-tests
 | 
			
		||||
    main-is:          Spec.hs
 | 
			
		||||
    type:             exitcode-stdio-1.0
 | 
			
		||||
    other-modules:    Test.Data.Trie
 | 
			
		||||
    other-modules:    
 | 
			
		||||
 | 
			
		||||
    -- Modules included in this executable, other than Main.
 | 
			
		||||
    -- 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 qualified Test.Data.Trie as Data.Trie
 | 
			
		||||
 | 
			
		||||
main :: IO ()
 | 
			
		||||
main = hspec $
 | 
			
		||||
  Data.Trie.spec
 | 
			
		||||
main = hspec $ pure ()
 | 
			
		||||
 
 | 
			
		||||
@@ -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
 | 
			
		||||
		Reference in New Issue
	
	Block a user