radixtree 0.4.0.0 → 0.6.0.0

raw patch · 6 files changed

+284/−168 lines, 6 filesdep +ghc-compactdep −storesetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: ghc-compact

Dependencies removed: store

API changes (from Hackage documentation)

Files

• Setup.hs +0/−2
• bench/Parsing.hs +12/−6
• bench/Search.hs +3/−4
• radixtree.cabal +85/−69
• src/Data/RadixTree.hs +156/−78
• test/Spec.hs +28/−9

@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain

@@ -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|]-

@@ -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|]-

@@ -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

@@ -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+ 

@@ -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   ]