Commit 389f7f19 authored by Mike Ledger's avatar Mike Ledger

benchmark

parent b59bb928
Pipeline #14999658 passed with stage
in 17 minutes and 58 seconds
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
import Control.DeepSeq
import Criterion.Main
import qualified Data.Attoparsec.Text as A
import Data.List (sortOn)
import qualified Data.RadixTree as R
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Vector as V
import Text.QuasiText
parseNaiive :: [Text] -> A.Parser Text
......@@ -14,29 +15,31 @@ parseNaiive = A.choice . map A.string . sortOn (negate . T.length)
main :: IO ()
main = defaultMain
[ env (return (source, sourceRadix)) $ \ ~(src, radix) ->
bgroup "megaparsec"
[ bgroup "radix"
[ bench (show t) (A.parseOnly (R.parse radix :: A.Parser Text) `nf` t)
| t <- tests
[ env (return (source, sourceRadix, sourceRadixCompressed, tests0)) $ \
~(src, radix, radix2, tests) ->
bgroup "attoparsec"
[ bench "radix" $
V.foldl' (\() t -> rnf $ A.parseOnly (R.parse radix) t) () `nf` tests
, bench "radix compressed" $
V.foldl' (\() t -> rnf $ A.parseOnly (R.parse radix2) t) () `nf` tests
, bench "naiive" $
V.foldl' (\() t -> rnf $ A.parseOnly (parseNaiive src) t) () `nf` tests
]
, bgroup "naiive"
[ bench (show t) (A.parseOnly (parseNaiive src :: A.Parser Text) `nf` t)
| t <- tests
]
]
]
tests :: [Text]
tests =
[ "acceleration"
, "acceleration, braking or coasting"
, "axle"
, "AAA"
, "2+2 seating"
, "long thing that doesn't parse"
, "z"
]
tests0 :: V.Vector Text
tests0 = V.fromList $! T.lines
"acceleration\n\
\acceleration, braking or coasting\n\
\axle\n\
\AAA\n\
\2+2 seating\n\
\long thing that doesn't parse\n\
\z"
sourceRadixCompressed :: R.RadixTree
sourceRadixCompressed =
R.compressBy (T.concat source) sourceRadix
sourceRadix :: R.RadixTree
sourceRadix = R.fromFoldable source
......
......@@ -28,13 +28,15 @@ benchmark radixtree-parsing
type: exitcode-stdio-1.0
hs-source-dirs: bench
main-is: RadixTree.hs
ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
ghc-options: -O2
build-depends: base
, radixtree
, text
, QuasiText
, criterion
, attoparsec
, deepseq
, vector
default-language: Haskell2010
test-suite radixtree-test
......
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
......@@ -46,10 +47,8 @@ import Text.Parser.Combinators (Parsing (try))
-- packing the final result into an efficient structure using 'Text' nodes.
--
-- TODO:
-- - Generate RadixTree directly
-- - Use offsets into original 'Text' values. Would be much better for memory
-- locality
-- - Or 'just' use compact regions?
-- - generate RadixTree directly
-- - just use compact regions?
data PrefixNode a = Accept !Text !a | Skip !a
deriving (Show, Eq)
......@@ -132,11 +131,15 @@ instance Monoid RadixTree where
fromTrie :: Trie -> RadixTree
fromTrie = go . compress
where
!z = V.empty
radixNode :: Seq Char -> CompressedTrie -> RadixNode
radixNode l t = RadixNode (T.pack (toList l)) (go t)
mapToVector :: Map k a -> Vector (k, a)
mapToVector m = V.fromListN (M.size m) (M.toList m)
mapToVector m = case M.size m of
0 -> z
sz -> V.fromListN sz (M.toList m)
go :: CompressedTrie -> RadixTree
go (CompressedTrie n) = case n of
......
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