Commit 5d4d800a authored by Mike Ledger's avatar Mike Ledger

lookup function

parent e6ae8b80
Pipeline #18794131 failed with stage
in 46 seconds
......@@ -33,7 +33,6 @@ benchmark radixtree-parsing
build-depends: base
, radixtree
, text
, QuasiText
, criterion
, attoparsec
, deepseq
......@@ -49,7 +48,6 @@ benchmark radixtree-search
build-depends: base
, radixtree
, text
, QuasiText
, criterion
, attoparsec
, deepseq
......
......@@ -229,6 +229,7 @@ makeStore ''RadixTree
class RadixParsing radixtree where
parse :: CharParsing m => radixtree -> m Text
lookup :: radixtree -> Text -> Maybe Text
{-# INLINE search #-}
-- | Find all occurences of the terms in a 'RadixTree' from this point on. This
......@@ -254,12 +255,33 @@ instance RadixParsing RadixTree where
| T.null l -> empty
| otherwise -> asum (V.map parseRadixNode nodes) <|> pure l
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 -> Text -> Maybe Text
lookup rt t
| T.null t = case rt of
RadixAccept v _ -> Just v
RadixSkip _ -> Nothing
| otherwise = case rt of
RadixAccept _ ns -> lookupRadixNodes t ns
RadixSkip ns -> lookupRadixNodes t ns
lookupRadixNodes :: Text -> Vector RadixNode -> Maybe Text
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
{-# INLINE parse #-}
-- | Parse from a 'RadixTree'
......
......@@ -15,7 +15,7 @@
# resolver:
# name: custom-snapshot
# location: "./custom-snapshot.yaml"
resolver: lts-9.0
resolver: lts-11.0
# User packages to be built.
# Various formats can be used as shown in the example below.
......
{-# 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)
import Data.Maybe
import qualified Data.RadixTree as R
import qualified Data.Text as T
import Test.SmallCheck
......@@ -13,25 +18,48 @@ import Test.Tasty.SmallCheck
sortOnLengthDesc :: [T.Text] -> [T.Text]
sortOnLengthDesc = sortOn (negate . T.length)
mkAlternatives :: NonEmpty (NonEmpty Char) -> [T.Text]
mkAlternatives = sortOnLengthDesc . map T.pack . coerce
instance Monad m => Serial m R.RadixTree where
series = fmap (R.fromFoldable . mkAlternatives) series
instance Monad m => Serial m R.CompressedRadixTree where
series =
fmap
(fromJust . (R.compressBy <$> T.concat <*> R.fromFoldable) . mkAlternatives)
series
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!"
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
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
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
]
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment