diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/bench/Parsing.hs b/bench/Parsing.hs --- a/bench/Parsing.hs +++ b/bench/Parsing.hs @@ -8,6 +8,7 @@ import Data.Text (Text) import qualified Data.Text as T import qualified Data.Vector as V +import GHC.Compact import Text.QuasiText parseNaiive :: [Text] -> A.Parser Text @@ -19,9 +20,15 @@ ~(src, radix, radix2, tests) -> bgroup "attoparsec" [ bench "radix" $ - V.foldl' (\() t -> rnf $ A.parseOnly (R.parse radix) t) () `nf` tests + V.foldl' (\() t -> rnf $ A.parseOnly (R.parse const radix) t) () `nf` tests + , bench "radix compressed" $ - V.foldl' (\() t -> rnf $ A.parseOnly (R.parse radix2) t) () `nf` tests + V.foldl' (\() t -> rnf $ A.parseOnly (R.parse const radix2) t) () `nf` tests + + , env (getCompact <$> compact radix2) $ \compactR -> + bench "radix compressed compact" $ + V.foldl' (\() t -> rnf $ A.parseOnly (R.parse const radix2) t) () `nf` tests + , bench "naiive" $ V.foldl' (\() t -> rnf $ A.parseOnly (parseNaiive src) t) () `nf` tests ] @@ -37,14 +44,14 @@ \long thing that doesn't parse\n\ \z" -sourceRadixCompressed :: R.CompressedRadixTree +sourceRadixCompressed :: R.CompressedRadixTree () sourceRadixCompressed = case R.compressBy (T.concat source) sourceRadix of Just ct -> ct Nothing -> error "could not compress source" -sourceRadix :: R.RadixTree -sourceRadix = R.fromFoldable source +sourceRadix :: R.RadixTree () +sourceRadix = R.fromFoldable_ source source :: [Text] source = T.lines [embed| @@ -929,4 +936,3 @@ year years yellow|] - diff --git a/bench/Search.hs b/bench/Search.hs --- a/bench/Search.hs +++ b/bench/Search.hs @@ -40,14 +40,14 @@ \long thing that doesn't parse\n\ \z" -sourceRadixCompressed :: R.CompressedRadixTree +sourceRadixCompressed :: R.CompressedRadixTree () sourceRadixCompressed = case R.compressBy (T.concat source) sourceRadix of Just ct -> ct Nothing -> error "could not compress source" -sourceRadix :: R.RadixTree -sourceRadix = R.fromFoldable source +sourceRadix :: R.RadixTree () +sourceRadix = R.fromFoldable_ source source :: [Text] source = T.lines [embed| @@ -932,4 +932,3 @@ year years yellow|] - diff --git a/radixtree.cabal b/radixtree.cabal --- a/radixtree.cabal +++ b/radixtree.cabal @@ -1,75 +1,91 @@ -name: radixtree -version: 0.4.0.0 -description: A prefix-tree parsing library -homepage: https://gitlab.com/transportengineering/radixtree -license: BSD3 -license-file: LICENSE -author: Mike Ledger -maintainer: mike@quasimal.com -copyright: 2018 Mike Ledger -category: Web -build-type: Simple -cabal-version: >=1.10 - -library - hs-source-dirs: src - exposed-modules: Data.RadixTree - build-depends: base >= 4.7 && < 5 - , containers >= 0.5 - , vector - , text - , deepseq - , microlens - , parsers >= 0.12 - , store >= 0.4 - , mtl >= 2.0 - default-language: Haskell2010 +-- This file has been generated from package.yaml by hpack version 0.28.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 8255bc497cd8d2d14fe11ccffde96ff9cab05b3bd0f6d264cf26f1789a662c1b -benchmark radixtree-parsing - type: exitcode-stdio-1.0 - hs-source-dirs: bench - main-is: Parsing.hs - ghc-options: -O2 - build-depends: base - , radixtree - , text - , QuasiText - , criterion - , attoparsec - , deepseq - , vector - default-language: Haskell2010 +name: radixtree +version: 0.6.0.0 +description: A prefix-tree parsing library +category: Web +homepage: https://gitlab.com/transportengineering/rnd/radixtree +author: Mike Ledger +maintainer: mike@quasimal.com +copyright: 2017-2019 Mike Ledger +license: BSD3 +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 +source-repository head + type: git + location: https://gitlab.com/tranpsortengineering/rnd/radixtree -benchmark radixtree-search - type: exitcode-stdio-1.0 - hs-source-dirs: bench - main-is: Search.hs - ghc-options: -O2 - build-depends: base - , radixtree - , text - , QuasiText - , criterion - , attoparsec - , deepseq - , vector - default-language: Haskell2010 +library + exposed-modules: + Data.RadixTree + other-modules: + Paths_radixtree + hs-source-dirs: + src + build-depends: + base >=4.7 && <5 + , containers >=0.5 + , deepseq + , microlens + , mtl >=2.0 + , parsers >=0.12 + , text + , vector + default-language: Haskell2010 test-suite radixtree-test - type: exitcode-stdio-1.0 - hs-source-dirs: test - main-is: Spec.hs - build-depends: base - , radixtree - , attoparsec - , smallcheck - , tasty - , tasty-smallcheck - , text - ghc-options: -threaded -rtsopts -with-rtsopts=-N - default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_radixtree + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + attoparsec + , base + , radixtree + , smallcheck + , tasty + , tasty-smallcheck + , text + default-language: Haskell2010 -source-repository head - type: git - location: https://gitlab.com/tranpsortengineering/radixtree +benchmark radixtree-parsing + type: exitcode-stdio-1.0 + main-is: Parsing.hs + hs-source-dirs: bench + ghc-options: -O2 + build-depends: + attoparsec + , base + , criterion + , deepseq + , radixtree + , text + , vector + , QuasiText + , ghc-compact + default-language: Haskell2010 + +benchmark radixtree-search + type: exitcode-stdio-1.0 + main-is: Search.hs + hs-source-dirs: bench + ghc-options: -O2 + build-depends: + attoparsec + , base + , criterion + , deepseq + , radixtree + , text + , vector + , QuasiText + default-language: Haskell2010 diff --git a/src/Data/RadixTree.hs b/src/Data/RadixTree.hs --- a/src/Data/RadixTree.hs +++ b/src/Data/RadixTree.hs @@ -14,10 +14,13 @@ , RadixNode (..) , CompressedRadixTree -- * Construction + , fromFoldable_ , fromFoldable , compressBy -- * Parsing with radix trees , RadixParsing (..) + , parse_ + , lookup_ , search ) where import Control.Applicative @@ -26,11 +29,8 @@ import Data.Foldable (asum, foldr', toList) import Data.Map.Strict (Map) import qualified Data.Map.Strict as M -import Data.Monoid import Data.Sequence (Seq) import qualified Data.Sequence as Seq -import Data.Store () -import Data.Store.TH (makeStore) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Array as TI (Array) @@ -53,50 +53,50 @@ -- - generate RadixTree directly, instead of going through 'Trie'/'CompressedTrie' -- - use compact regions? -data PrefixNode a = Accept !Text !a | Skip !a +data PrefixNode a tree = Accept !Text a !tree | Skip !tree deriving (Show, Eq) -newtype Trie = Trie (PrefixNode (Map Char Trie)) +newtype Trie a = Trie (PrefixNode a (Map Char (Trie a))) deriving (Show, Eq) -newtype CompressedTrie = CompressedTrie (PrefixNode (Map (Seq Char) CompressedTrie)) +newtype CompressedTrie a = CompressedTrie (PrefixNode a (Map (Seq Char) (CompressedTrie a))) deriving (Show, Eq) {-# INLINE node #-} -node :: Lens (PrefixNode a) (PrefixNode b) a b +node :: Lens (PrefixNode p a) (PrefixNode p b) a b node = lens - (\x -> case x of { Accept _ t -> t; Skip t -> t }) - (\x a -> case x of { Accept l _ -> Accept l a; Skip _ -> Skip a }) + (\x -> case x of { Accept _ _ t -> t; Skip t -> t }) + (\x a -> case x of { Accept l p _ -> Accept l p a; Skip _ -> Skip a }) -leaf :: Text -> Text -> Trie -leaf ft t = go (T.unpack t) +leaf :: Text -> Text -> a -> Trie a +leaf ft t v = go (T.unpack t) where go (x:xs) = Trie (Skip (M.singleton x (go xs))) - go [] = Trie (Accept ft M.empty) + go [] = Trie (Accept ft v M.empty) -insert :: Text -> Text -> Trie -> Trie -insert ft text' (Trie n) = case T.uncons text' of +insert :: Text -> Text -> a -> Trie a -> Trie a +insert ft text' a (Trie n) = case T.uncons text' of Just (c, cs) -> Trie ((node %~ M.insertWith - (\_ orig -> Data.RadixTree.insert ft cs orig) + (\_ orig -> Data.RadixTree.insert ft cs a orig) c - (leaf ft cs)) n) + (leaf ft cs a)) n) Nothing -> - Trie (n^.node.to (Accept ft)) + Trie (n^.node.to (Accept ft a)) -makeCompressable :: Trie -> CompressedTrie +makeCompressable :: Trie a -> CompressedTrie a makeCompressable (Trie n) = CompressedTrie ( over node (M.map makeCompressable . M.mapKeysMonotonic Seq.singleton) n) -compress :: Trie -> CompressedTrie +compress :: Trie a -> CompressedTrie a compress = go . makeCompressable where - go :: CompressedTrie -> CompressedTrie + go :: CompressedTrie a -> CompressedTrie a go (CompressedTrie n) = case n of - Accept l m -> CompressedTrie (Accept l (M.map go m)) - Skip m -> CompressedTrie (Skip (M.foldMapWithKey compress1 m)) + Accept l p m -> CompressedTrie (Accept l p (M.map go m)) + Skip m -> CompressedTrie (Skip (M.foldMapWithKey compress1 m)) - compress1 :: Seq Char -> CompressedTrie -> Map (Seq Char) CompressedTrie + compress1 :: Seq Char -> CompressedTrie a -> Map (Seq Char) (CompressedTrie a) compress1 k c@(CompressedTrie n) = case M.size sm of 0 -> M.singleton k c @@ -109,36 +109,37 @@ -- | A node in a radixtree. To advance from here a parser must parse the 'Text' -- (i.e., the prefix) value at this node. -data RadixNode = RadixNode {-# UNPACK #-} !Text !RadixTree +data RadixNode a = RadixNode {-# UNPACK #-} !Text !(RadixTree a) deriving (Eq, Show, Typeable, Data) --- | A radixtree. Construct with 'fromFoldable', and use with 'parse'. -data RadixTree +-- | A radixtree. Construct with 'fromFoldable_, and use with 'parse'. +data RadixTree a = -- | Can terminate a parser successfully, returning the 'Text' value given. RadixAccept - {-# UNPACK #-} !Text -- the final value to return - {-# UNPACK #-} !(Vector RadixNode) -- possible subtrees beyond this point + {-# UNPACK #-} !Text -- ^ text to return at this point + {-# UNPACK #-} !(Vector (RadixNode a)) -- ^ possible subtrees beyond this point + a -- ^ value to return at this point | RadixSkip - {-# UNPACK #-} !(Vector RadixNode) -- possible subtrees beyond this point + {-# UNPACK #-} !(Vector (RadixNode a)) -- ^ possible subtrees beyond this point deriving (Eq, Show, Typeable, Data) -instance NFData RadixNode where +instance NFData a => NFData (RadixNode a) where {-# INLINE rnf #-} rnf (RadixNode l t) = rnf l `seq` rnf t -instance NFData RadixTree where +instance NFData a => NFData (RadixTree a) where {-# INLINE rnf #-} - rnf (RadixAccept t v) = t `seq` rnf v - rnf (RadixSkip v) = rnf v + rnf (RadixAccept t v p) = t `seq` rnf p `seq` rnf v + rnf (RadixSkip v) = rnf v -- | Compress a totally-unoptimised 'Trie' into a nice and easily-parsable -- 'RadixTree' -fromTrie :: Trie -> RadixTree +fromTrie :: Trie a -> RadixTree a fromTrie = go . compress where !z = V.empty - radixNode :: Seq Char -> CompressedTrie -> RadixNode + radixNode :: Seq Char -> CompressedTrie a -> RadixNode a radixNode l t = RadixNode (T.pack (toList l)) (go t) mapToVector :: Map k a -> Vector (k, a) @@ -146,10 +147,10 @@ 0 -> z sz -> V.fromListN sz (M.toList m) - go :: CompressedTrie -> RadixTree + go :: CompressedTrie a -> RadixTree a go (CompressedTrie n) = case n of - Accept l m -> RadixAccept l . V.map (uncurry radixNode) . mapToVector $! m - Skip m -> RadixSkip . V.map (uncurry radixNode) . mapToVector $! m + Accept l p m -> RadixAccept l (V.map (uncurry radixNode) (mapToVector m)) p + Skip m -> RadixSkip . V.map (uncurry radixNode) . mapToVector $! m data TextSlice = TextSlice { tsOffset16 :: {-# UNPACK #-} !Int -- ^ offset (in units of Word16) @@ -174,108 +175,185 @@ -- parsing benchmarks in this package, the 'CompressedRadixTree' version is -- 254032 bytes, whereas the ordinary 'RadixTree' is a rotund 709904 bytes) at -- no runtime cost. -data CompressedRadixTree - = CompressedRadixTree {-# UNPACK #-} !TI.Array !CompressedRadixTree1 +data CompressedRadixTree a + = CompressedRadixTree {-# UNPACK #-} !TI.Array !(CompressedRadixTree1 a) -data CompressedRadixTree1 +data CompressedRadixTree1 a = CompressedRadixAccept {-# UNPACK #-} !TextSlice - {-# UNPACK #-} !(Vector CompressedRadixNode) - | CompressedRadixSkip {-# UNPACK #-} !(Vector CompressedRadixNode) + {-# UNPACK #-} !(Vector (CompressedRadixNode a)) + a + | CompressedRadixSkip {-# UNPACK #-} !(Vector (CompressedRadixNode a)) -data CompressedRadixNode - = CompressedRadixNode {-# UNPACK #-} !TextSlice !CompressedRadixTree1 +data CompressedRadixNode a + = CompressedRadixNode {-# UNPACK #-} !TextSlice !(CompressedRadixTree1 a) -instance NFData CompressedRadixNode where +instance NFData a => NFData (CompressedRadixNode a) where {-# INLINE rnf #-} rnf (CompressedRadixNode ts t) = ts `seq` rnf t -instance NFData CompressedRadixTree where +instance NFData a => NFData (CompressedRadixTree a) where {-# INLINE rnf #-} rnf (CompressedRadixTree arr v) = arr `seq` rnf v -instance NFData CompressedRadixTree1 where +instance NFData a => NFData (CompressedRadixTree1 a) where {-# INLINE rnf #-} - rnf (CompressedRadixAccept ts v) = ts `seq` rnf v - rnf (CompressedRadixSkip v) = rnf v + rnf (CompressedRadixAccept ts v a) = ts `seq` rnf a `seq` rnf v + rnf (CompressedRadixSkip v) = rnf v --- | Compress a 'RadixTree' given a corpus. All values in the tree be findable --- within the corpus, though the corpus does not have to necessarily be the --- direct source of the tree -compressBy :: Text -> RadixTree -> Maybe CompressedRadixTree +-- | Compress a 'RadixTree' given a corpus. All values in the tree must be +-- findable within the corpus, though the corpus does not have to necessarily be +-- the direct source of the tree +compressBy :: Text -> RadixTree a -> Maybe (CompressedRadixTree a) compressBy full@(TI.Text arr _ _) rt = CompressedRadixTree arr <$> recompressT rt where magic = magicallySaveSpaceSometimes full - recompressN :: RadixNode -> Maybe CompressedRadixNode + recompressN :: RadixNode a -> Maybe (CompressedRadixNode a) recompressN (RadixNode t tree) = CompressedRadixNode <$> magic t <*> recompressT tree - recompressT :: RadixTree -> Maybe CompressedRadixTree1 - recompressT (RadixSkip v) = CompressedRadixSkip <$> V.mapM recompressN v - recompressT (RadixAccept t v) = CompressedRadixAccept <$> magic t <*> V.mapM recompressN v + recompressT :: RadixTree a -> Maybe (CompressedRadixTree1 a) + recompressT (RadixSkip v) = CompressedRadixSkip <$> V.mapM recompressN v + recompressT (RadixAccept t v a) = CompressedRadixAccept <$> magic t <*> V.mapM recompressN v <*> pure a +-- | *Slow*. Same as 'fromFoldable', but you do not need to supply pairs of text +-- and values; they will default to '()'. +fromFoldable_ :: Foldable f => f Text -> RadixTree () +fromFoldable_ = + fromTrie . foldr' (\t -> insert t t ()) (Trie (Skip M.empty)) + -- | *Slow* -fromFoldable :: Foldable f => f Text -> RadixTree +fromFoldable :: Foldable f => f (Text, a) -> RadixTree a fromFoldable = - fromTrie . foldr' (\t -> insert t t) (Trie (Skip M.empty)) - -makeStore ''RadixNode -makeStore ''RadixTree + fromTrie . foldr' (\(t, a) -> insert t t a) (Trie (Skip M.empty)) -------------------------------------------------------------------------------- -- Parsers from 'RadixTree's class RadixParsing radixtree where - parse :: CharParsing m => radixtree -> m Text + keys :: radixtree a -> [(Text, a)] + parse :: CharParsing m => (Text -> a -> r) -> radixtree a -> m r + lookup :: radixtree a -> Text -> Maybe (Text, a) {-# INLINE search #-} -- | Find all occurences of the terms in a 'RadixTree' from this point on. This -- will consume the entire remaining input. Can lazily produce results (but this -- depends on your parser). -search :: (Monad m, CharParsing m, RadixParsing radixtree) - => radixtree -> m [Text] +search + :: (Monad m, CharParsing m, RadixParsing radixtree) + => radixtree a + -> m [Text] search r = go where go = - (parse r >>= \x -> (x:) <$> go) <|> + (parse const r >>= \x -> (x:) <$> go) <|> (anyChar >> go) <|> return [] +{-# INLINE parse_ #-} +parse_ :: (RadixParsing r, CharParsing m) => r a -> m Text +parse_ = Data.RadixTree.parse const + +{-# INLINE lookup_ #-} +lookup_ :: RadixParsing r => r a -> Text -> Maybe Text +lookup_ r t = fst <$> Data.RadixTree.lookup r t + instance RadixParsing RadixTree where + keys = go [] + where + go nil (RadixAccept l xs a) = (l,a) : V.foldr (\(RadixNode _ x) xs' -> go xs' x) nil xs + go nil (RadixSkip xs) = V.foldr (\(RadixNode _ x) xs' -> go xs' x) nil xs + {-# INLINE parse #-} -- | Parse from a 'RadixTree' - parse :: CharParsing m => RadixTree -> m Text - parse = go + parse :: CharParsing m => (Text -> a -> r) -> RadixTree a -> m r + parse constr = go where go r = case r of - RadixAccept l nodes + RadixAccept l nodes a | T.null l -> empty - | otherwise -> asum (V.map parseRadixNode nodes) <|> pure l - RadixSkip nodes -> asum (V.map parseRadixNode nodes) + | otherwise -> asum (V.map parseRadixNode nodes) <|> pure (constr l a) + RadixSkip nodes -> + asum (V.map parseRadixNode nodes) {-# INLINE parseRadixNode #-} parseRadixNode (RadixNode prefix tree) | T.null prefix = go tree | otherwise = try (text prefix *> go tree) + lookup :: RadixTree a -> Text -> Maybe (Text, a) + lookup rt0 t0 + | T.null t0 = case rt0 of + RadixAccept v _ a -> Just (v, a) + RadixSkip _ -> Nothing + | otherwise = case rt0 of + RadixAccept _ ns _ -> lookupRadixNodes t0 ns + RadixSkip ns -> lookupRadixNodes t0 ns + where + lookupRadixNodes t v = go 0 + where + !vlen = V.length v + go !i + | i < vlen = case V.unsafeIndex v i of + RadixNode pfix rt -> case T.commonPrefixes pfix t of + Just (_, remPfx, remSfx) + | T.null remPfx -> Data.RadixTree.lookup rt remSfx + | otherwise -> Nothing + Nothing -> go (i + 1) + | otherwise = Nothing + instance RadixParsing CompressedRadixTree where + + keys (CompressedRadixTree arr crt) = go [] crt + where + fromSlice (TextSlice offs len) = TI.text arr offs len + + go nil (CompressedRadixAccept l xs a) = + (fromSlice l, a) : V.foldr (\(CompressedRadixNode _ x) xs' -> go xs' x) nil xs + go nil (CompressedRadixSkip xs) = + V.foldr (\(CompressedRadixNode _ x) xs' -> go xs' x) nil xs + {-# INLINE parse #-} -- | Parse from a 'RadixTree' - parse :: CharParsing m => CompressedRadixTree -> m Text - parse (CompressedRadixTree arr crt) = go crt + parse :: CharParsing m => (Text -> a -> r) -> CompressedRadixTree a -> m r + parse constr (CompressedRadixTree arr crt) = go crt where fromSlice (TextSlice offs len) = TI.text arr offs len - go r = case r of - CompressedRadixAccept ts nodes -> case fromSlice ts of + CompressedRadixAccept ts nodes a -> case fromSlice ts of l | T.null l -> empty - | otherwise -> asum (V.map parseRadixNode nodes) <|> pure l + | otherwise -> asum (V.map parseRadixNode nodes) <|> pure (constr l a) CompressedRadixSkip nodes -> asum (V.map parseRadixNode nodes) - {-# INLINE parseRadixNode #-} parseRadixNode (CompressedRadixNode ts tree) = case fromSlice ts of prefix | T.null prefix -> go tree | otherwise -> try (text prefix *> go tree) + + lookup :: CompressedRadixTree a -> Text -> Maybe (Text, a) + lookup (CompressedRadixTree arr0 rt0) = lookup1 rt0 + where + fromSlice (TextSlice offs16 len16) = TI.text arr0 offs16 len16 + + lookup1 rt !t + | T.null t = case rt of + CompressedRadixAccept v _ a -> Just (fromSlice v, a) + CompressedRadixSkip _ -> Nothing + | otherwise = case rt of + CompressedRadixAccept _ ns _ -> lookupCompressedRadixNodes t ns + CompressedRadixSkip ns -> lookupCompressedRadixNodes t ns + + lookupCompressedRadixNodes !t v = go 0 + where + !vlen = V.length v + go !i + | i < vlen = case V.unsafeIndex v i of + CompressedRadixNode pfix rt -> case T.commonPrefixes (fromSlice pfix) t of + Just (_, remPfx, remSfx) + | T.null remPfx -> lookup1 rt remSfx + | otherwise -> Nothing + Nothing -> go (i + 1) + | otherwise = Nothing + diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,5 +1,9 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} import Data.Attoparsec.Text import Data.Coerce import Data.List (sortOn) @@ -13,25 +17,40 @@ sortOnLengthDesc :: [T.Text] -> [T.Text] sortOnLengthDesc = sortOn (negate . T.length) +mkAlternatives :: NonEmpty (NonEmpty Char) -> [T.Text] +mkAlternatives = sortOnLengthDesc . map T.pack . coerce + naiiveSameAsRadix :: Monad m => Bool -> Property m naiiveSameAsRadix doCompress = - forAll $ \(alternativesS :: NonEmpty (NonEmpty Char)) -> + forAll $ \(mkAlternatives -> alternatives) -> let - alternatives = sortOnLengthDesc (map T.pack (coerce alternativesS)) rparse - | doCompress = R.parse $! R.fromFoldable alternatives - | otherwise = case R.compressBy (T.concat alternatives) (R.fromFoldable alternatives) of - Just crt -> R.parse $! crt - Nothing -> error "could not compress radixtree!" - + | doCompress = R.parse_ $! R.fromFoldable_ alternatives + | otherwise = case R.compressBy (T.concat alternatives) (R.fromFoldable_ alternatives) of + Just crt -> R.parse_ $! crt + Nothing -> error "could not compress radixtree!" in forAll $ \(textS :: NonEmpty Char) -> let text = T.pack (coerce textS) in parseOnly (choice (map string alternatives)) text == parseOnly rparse text +lookupSameishAsParse :: Property IO +lookupSameishAsParse = + forAll $ \alternatives -> + let + !rt = R.fromFoldable_ (mkAlternatives alternatives) + !p = R.parse_ rt <* endOfInput + in forAll $ \(textS :: NonEmpty Char) -> + let text = T.pack (coerce textS) + in case (parseOnly p text, R.lookup_ rt text) of + (Right x1, Just x2) -> x1 == x2 + (Left _ , Nothing) -> True + _ -> False + main :: IO () main = defaultMain $ testGroup "radixtree" [ testProperty "naiive parsing has the same result as radix tree parsing" (naiiveSameAsRadix False) , testProperty "naiive parsing has the same result as radix tree parsing when compressed" (naiiveSameAsRadix True) + , testProperty "lookup ~ parse" lookupSameishAsParse ]