diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,22 @@ +Copyright (c) 2015, Nikita Volkov + +Permission is hereby granted, free of charge, to any person +obtaining a copy of this software and associated documentation +files (the "Software"), to deal in the Software without +restriction, including without limitation the rights to use, +copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the +Software is furnished to do so, subject to the following +conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES +OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT +HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +OTHER DEALINGS IN THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/benchmark/Main.hs b/benchmark/Main.hs new file mode 100644 --- /dev/null +++ b/benchmark/Main.hs @@ -0,0 +1,48 @@ +module Main where + +import BasePrelude +import Control.DeepSeq +import Criterion.Main +import Data.ByteString (ByteString) +import qualified ByteString.TreeBuilder as A + + +main = + defaultMain $ + map sampleGroup $ + [("Small Input", smallSample), ("Medium Input", mediumSample), ("Large Input", largeSample)] + +sampleGroup :: (String, Sample) -> Benchmark +sampleGroup (title, sample) = + bench title $ nf sample $ + (A.byteString, mappend, mempty, A.toByteString) + +type Sample = + forall a. (ByteString -> a, a -> a -> a, a, a -> ByteString) -> ByteString + +{-# NOINLINE smallSample #-} +smallSample :: Sample +smallSample (fromByteString, (<>), mempty, toByteString) = + toByteString $ + (fromByteString "hello" <> fromByteString "asdf") <> + fromByteString "fsndfn" <> + (fromByteString "dfgknfg" <> fromByteString "aaaaaa") + +{-# NOINLINE mediumSample #-} +mediumSample :: Sample +mediumSample (fromByteString, (<>), mempty, toByteString) = + toByteString $ + foldl' (<>) mempty $ replicate 1000 $ + (fromByteString "hello" <> fromByteString "asdf") <> + fromByteString "fsndfn" <> + (fromByteString "dfgknfg" <> fromByteString "aaaaaa") + +{-# NOINLINE largeSample #-} +largeSample :: Sample +largeSample (fromByteString, (<>), mempty, toByteString) = + toByteString $ + foldl' (<>) mempty $ replicate 100000 $ + (fromByteString "hello" <> fromByteString "asdf") <> + fromByteString "fsndfn" <> + (fromByteString "dfgknfg" <> fromByteString "aaaaaa") + diff --git a/bytestring-tree-builder.cabal b/bytestring-tree-builder.cabal new file mode 100644 --- /dev/null +++ b/bytestring-tree-builder.cabal @@ -0,0 +1,114 @@ +name: + bytestring-tree-builder +version: + 0.2.1.1 +category: + ByteString +synopsis: + A very efficient ByteString builder implementation based on the binary tree +description: + According to + + this builder implementation beats all the alternative implementations. + It is especially well-suited for producing strict bytestrings, + beating the standard builder by at least the factor of 4. +homepage: + https://github.com/nikita-volkov/bytestring-tree-builder +bug-reports: + https://github.com/nikita-volkov/bytestring-tree-builder/issues +author: + Nikita Volkov +maintainer: + Nikita Volkov +copyright: + (c) 2015, Nikita Volkov +license: + MIT +license-file: + LICENSE +build-type: + Simple +cabal-version: + >=1.10 + + +source-repository head + type: + git + location: + git://github.com/nikita-volkov/bytestring-tree-builder.git + + +library + hs-source-dirs: + library + ghc-options: + default-extensions: + Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, ImpredicativeTypes, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples + default-language: + Haskell2010 + other-modules: + ByteString.TreeBuilder.Prelude + ByteString.TreeBuilder.Poker + ByteString.TreeBuilder.Tree + exposed-modules: + ByteString.TreeBuilder + build-depends: + bytestring >= 0.10 && < 0.11, + base-prelude >= 0.1.19 && < 0.2, + base >= 4.6 && < 5 + + +benchmark benchmark + type: + exitcode-stdio-1.0 + hs-source-dirs: + benchmark + main-is: + Main.hs + ghc-options: + -O2 + -threaded + "-with-rtsopts=-N" + -funbox-strict-fields + default-extensions: + Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveTraversable, DeriveGeneric, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, ImpredicativeTypes, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples + default-language: + Haskell2010 + build-depends: + -- + bytestring-tree-builder, + -- benchmarking: + criterion == 1.1.*, + -- data: + bytestring, + -- general: + deepseq == 1.*, + base-prelude + + +test-suite tasty + type: + exitcode-stdio-1.0 + hs-source-dirs: + tasty + main-is: + Main.hs + default-extensions: + Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, ImpredicativeTypes, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples + default-language: + Haskell2010 + build-depends: + bytestring-tree-builder, + -- testing: + tasty == 0.11.*, + tasty-quickcheck == 0.8.*, + tasty-smallcheck == 0.8.*, + tasty-hunit == 0.9.*, + quickcheck-instances >= 0.3.11 && < 0.4, + QuickCheck >= 2.8.1 && < 2.9, + -- data: + bytestring, + -- general: + base-prelude + diff --git a/library/ByteString/TreeBuilder.hs b/library/ByteString/TreeBuilder.hs new file mode 100644 --- /dev/null +++ b/library/ByteString/TreeBuilder.hs @@ -0,0 +1,90 @@ +module ByteString.TreeBuilder +( + Builder, + -- * Declaration + byteString, + byte, + -- * Execution + toByteString, + toLazyByteString, +) +where + +import ByteString.TreeBuilder.Prelude hiding (foldl, length) +import qualified ByteString.TreeBuilder.Tree as A +import qualified ByteString.TreeBuilder.Poker as D +import qualified ByteString.TreeBuilder.Prelude as F +import qualified Data.ByteString as B +import qualified Data.ByteString.Internal as C +import qualified Data.ByteString.Lazy.Internal as E + + +-- | +-- A binary-tree-based datastructure optimized for aggregation of bytestrings. +-- Implements the appending operation with /O(1)/ complexity. +data Builder = + Builder !Int !A.Tree + +-- | +-- Implements an /O(1)/ `mappend`. +instance Monoid Builder where + {-# INLINE mempty #-} + mempty = + Builder 0 A.Empty + {-# INLINABLE mappend #-} + mappend (Builder length1 tree1) (Builder length2 tree2) = + Builder (length1 + length2) (A.Branch tree1 tree2) + +instance IsString Builder where + {-# INLINE fromString #-} + fromString string = + Builder (B.length bytes) (A.Leaf bytes) + where + bytes = + fromString string + +-- | +-- Lifts a bytestring into the builder. +{-# INLINE byteString #-} +byteString :: ByteString -> Builder +byteString bytes = + Builder (B.length bytes) (A.Leaf bytes) + +-- | +-- Lifts a single bytestring into the builder. +{-# INLINE byte #-} +byte :: Word8 -> Builder +byte byte = + Builder 1 (A.Leaf (B.singleton byte)) + +-- * Execution +------------------------- + +-- | +-- Performs a left-fold over the chunks of which the builder consists. +{-# INLINE foldl #-} +foldl :: (a -> ByteString -> a) -> a -> Builder -> a +foldl step init (Builder length tree) = + A.foldl step init tree + +-- | +-- /O(1)/. Gets the total length. +{-# INLINE length #-} +length :: Builder -> Int +length (Builder length tree) = + length + +-- | +-- /O(n)/. Converts the builder into a strict bytestring. +{-# INLINABLE toByteString #-} +toByteString :: Builder -> ByteString +toByteString (Builder length tree) = + C.unsafeCreate length $ \ptr -> + void $ D.pokeTree tree ptr + +-- | +-- /O(n)/. Converts the builder into a lazy bytestring. +{-# INLINABLE toLazyByteString #-} +toLazyByteString :: Builder -> E.ByteString +toLazyByteString = + foldl (flip E.Chunk) E.Empty diff --git a/library/ByteString/TreeBuilder/Poker.hs b/library/ByteString/TreeBuilder/Poker.hs new file mode 100644 --- /dev/null +++ b/library/ByteString/TreeBuilder/Poker.hs @@ -0,0 +1,39 @@ +module ByteString.TreeBuilder.Poker where + +import ByteString.TreeBuilder.Prelude +import Foreign hiding (void) +import qualified Data.ByteString as A +import qualified Data.ByteString.Internal as B +import qualified Foreign as D +import qualified ByteString.TreeBuilder.Tree as E + + +-- | +-- Write the given bytes into the pointer and +-- return a pointer incremented by the amount of written bytes. +pokeBytes :: ByteString -> Ptr Word8 -> IO (Ptr Word8) +pokeBytes (B.PS foreignPointer offset length) pointer = + do + withForeignPtr foreignPointer $ \pointer' -> + B.memcpy pointer (plusPtr pointer' offset) length + pure (plusPtr pointer length) + +-- | +-- Write the given bytes into the pointer and +-- return a pointer decremented by the amount of written bytes. +pokeBytesMinus :: ByteString -> Ptr Word8 -> IO (Ptr Word8) +pokeBytesMinus (B.PS foreignPointer offset length) pointer = + do + withForeignPtr foreignPointer $ \pointer' -> + B.memcpy targetPointer (plusPtr pointer' offset) length + pure targetPointer + where + targetPointer = + plusPtr pointer (negate length) + +pokeTree :: E.Tree -> D.Ptr Word8 -> IO (D.Ptr Word8) +pokeTree tree ptr = + case tree of + E.Empty -> pure ptr + E.Leaf bytes -> pokeBytes bytes ptr + E.Branch tree1 tree2 -> pokeTree tree1 ptr >>= pokeTree tree2 diff --git a/library/ByteString/TreeBuilder/Prelude.hs b/library/ByteString/TreeBuilder/Prelude.hs new file mode 100644 --- /dev/null +++ b/library/ByteString/TreeBuilder/Prelude.hs @@ -0,0 +1,14 @@ +module ByteString.TreeBuilder.Prelude +( + module Exports, +) +where + + +-- base-prelude +------------------------- +import BasePrelude as Exports hiding (assert, left, right, isLeft, isRight, error) + +-- bytestring +------------------------- +import Data.ByteString as Exports (ByteString) diff --git a/library/ByteString/TreeBuilder/Tree.hs b/library/ByteString/TreeBuilder/Tree.hs new file mode 100644 --- /dev/null +++ b/library/ByteString/TreeBuilder/Tree.hs @@ -0,0 +1,48 @@ +module ByteString.TreeBuilder.Tree where + +import ByteString.TreeBuilder.Prelude hiding (foldl, foldr, foldlM, length) +import qualified Data.ByteString as B +import qualified Data.ByteString.Internal as C +import qualified Data.ByteString.Lazy.Internal as E +import qualified ByteString.TreeBuilder.Prelude as F +import qualified Data.ByteString.Internal as G +import qualified Foreign as H + + +data Tree = + Empty | + Leaf !ByteString | + Branch !Tree !Tree + +{-# INLINE foldl #-} +foldl :: (a -> ByteString -> a) -> a -> Tree -> a +foldl step init = + \case + Empty -> + init + Leaf value -> + step init value + Branch tree1 tree2 -> + foldl step (foldl step init tree1) tree2 + +{-# INLINE foldr #-} +foldr :: (ByteString -> a -> a) -> a -> Tree -> a +foldr step init = + \case + Empty -> + init + Leaf value -> + step value init + Branch tree1 tree2 -> + foldr step (foldr step init tree2) tree1 + +{-# INLINE foldlM #-} +foldlM :: Monad m => (a -> ByteString -> m a) -> a -> Tree -> m a +foldlM step init = + \case + Empty -> + pure init + Leaf value -> + step init value + Branch tree1 tree2 -> + foldlM step init tree1 >>= \init2 -> foldlM step init2 tree2 diff --git a/tasty/Main.hs b/tasty/Main.hs new file mode 100644 --- /dev/null +++ b/tasty/Main.hs @@ -0,0 +1,21 @@ +module Main where + +import BasePrelude hiding (assert) +import Test.QuickCheck.Instances +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck +import ByteString.TreeBuilder + + +main = + defaultMain tree + +tree = + testGroup "All tests" + [ + testProperty "Concatting a list of bytestrings is isomorphic to appending a list of builders" $ + \bytestrings -> + mconcat bytestrings == + toByteString (foldMap byteString bytestrings) + ]