diff --git a/benchmark/Main.hs b/benchmark/Main.hs new file mode 100644 --- /dev/null +++ b/benchmark/Main.hs @@ -0,0 +1,26 @@ +module Main where + +import Rebase.Prelude +import Criterion.Main +import qualified Main.Model +import qualified Main.JSONBytesBuilder +import qualified Main.Aeson +import qualified Data.Aeson +import qualified Rebase.Data.ByteString.Lazy +import qualified JSONBytesBuilder.ByteString.ByteString +import qualified JSONBytesBuilder.ByteString.LazyByteString + +main = + do + input <- load "samples/twitter100.json" + defaultMain + [ + bench "strict" (nf (JSONBytesBuilder.ByteString.ByteString.jsonLiteral . Main.JSONBytesBuilder.result) input) + , + bench "lazy" (nf (JSONBytesBuilder.ByteString.LazyByteString.jsonLiteral . Main.JSONBytesBuilder.result) input) + ] + +load :: FilePath -> IO Main.Model.Result +load fileName = + (=<<) (either fail return . Data.Aeson.eitherDecode') $ + Rebase.Data.ByteString.Lazy.readFile fileName diff --git a/benchmark/Main/Aeson.hs b/benchmark/Main/Aeson.hs new file mode 100644 --- /dev/null +++ b/benchmark/Main/Aeson.hs @@ -0,0 +1,129 @@ +module Main.Aeson where + +import Rebase.Prelude +import Main.Model +import Data.Aeson hiding (Result) + + +instance ToJSON Metadata where + toJSON Metadata{..} = object [ + "result_type" .= result_type + ] + + toEncoding Metadata{..} = pairs $ + "result_type" .= result_type + +instance FromJSON Metadata where + parseJSON (Object v) = Metadata <$> v .: "result_type" + parseJSON _ = empty + +instance ToJSON Geo where + toJSON Geo{..} = object [ + "type_" .= type_ + , "coordinates" .= coordinates + ] + + toEncoding Geo{..} = pairs $ + "type_" .= type_ + <> "coordinates" .= coordinates + +instance FromJSON Geo where + parseJSON (Object v) = Geo <$> + v .: "type_" + <*> v .: "coordinates" + parseJSON _ = empty + +instance ToJSON Story where + toJSON Story{..} = object [ + "from_user_id_str" .= from_user_id_str + , "profile_image_url" .= profile_image_url + , "created_at" .= created_at + , "from_user" .= from_user + , "id_str" .= id_str + , "metadata" .= metadata + , "to_user_id" .= to_user_id + , "text" .= text + , "id" .= id + , "from_user_id" .= from_user_id + , "geo" .= geo + , "iso_language_code" .= iso_language_code + , "to_user_id_str" .= to_user_id_str + , "source" .= source + ] + + toEncoding Story{..} = pairs $ + "from_user_id_str" .= from_user_id_str + <> "profile_image_url" .= profile_image_url + <> "created_at" .= created_at + <> "from_user" .= from_user + <> "id_str" .= id_str + <> "metadata" .= metadata + <> "to_user_id" .= to_user_id + <> "text" .= text + <> "id" .= id + <> "from_user_id" .= from_user_id + <> "geo" .= geo + <> "iso_language_code" .= iso_language_code + <> "to_user_id_str" .= to_user_id_str + <> "source" .= source + +instance FromJSON Story where + parseJSON (Object v) = Story <$> + v .: "from_user_id_str" + <*> v .: "profile_image_url" + <*> v .: "created_at" + <*> v .: "from_user" + <*> v .: "id_str" + <*> v .: "metadata" + <*> v .: "to_user_id" + <*> v .: "text" + <*> v .: "id" + <*> v .: "from_user_id" + <*> v .: "geo" + <*> v .: "iso_language_code" + <*> v .: "to_user_id_str" + <*> v .: "source" + parseJSON _ = empty + +instance ToJSON Result where + toJSON Result{..} = object [ + "results" .= results + , "max_id" .= max_id + , "since_id" .= since_id + , "refresh_url" .= refresh_url + , "next_page" .= next_page + , "results_per_page" .= results_per_page + , "page" .= page + , "completed_in" .= completed_in + , "since_id_str" .= since_id_str + , "max_id_str" .= max_id_str + , "query" .= query + ] + + toEncoding Result{..} = pairs $ + "results" .= results + <> "max_id" .= max_id + <> "since_id" .= since_id + <> "refresh_url" .= refresh_url + <> "next_page" .= next_page + <> "results_per_page" .= results_per_page + <> "page" .= page + <> "completed_in" .= completed_in + <> "since_id_str" .= since_id_str + <> "max_id_str" .= max_id_str + <> "query" .= query + +instance FromJSON Result where + parseJSON (Object v) = Result <$> + v .: "results" + <*> v .: "max_id" + <*> v .: "since_id" + <*> v .: "refresh_url" + <*> v .: "next_page" + <*> v .: "results_per_page" + <*> v .: "page" + <*> v .: "completed_in" + <*> v .: "since_id_str" + <*> v .: "max_id_str" + <*> v .: "query" + parseJSON _ = empty diff --git a/benchmark/Main/JSONBytesBuilder.hs b/benchmark/Main/JSONBytesBuilder.hs new file mode 100644 --- /dev/null +++ b/benchmark/Main/JSONBytesBuilder.hs @@ -0,0 +1,54 @@ +module Main.JSONBytesBuilder where + +import Rebase.Prelude hiding (null) +import JSONBytesBuilder.Builder +import qualified Main.Model as A + + +result :: A.Result -> Literal +result x = + object $ + row "results" (array (foldMap (element . story) (A.results x))) <> + row "max_id" ((numberFromInt . fromIntegral) (A.max_id x)) <> + row "since_id" ((numberFromInt . fromIntegral) (A.since_id x)) <> + row "refresh_url" (stringFromText (A.refresh_url x)) <> + row "next_page" (stringFromText (A.next_page x)) <> + row "results_per_page" ((numberFromInt . fromIntegral) (A.results_per_page x)) <> + row "page" ((numberFromInt . fromIntegral) (A.page x)) <> + row "completed_in" (numberFromDouble (A.completed_in x)) <> + row "since_id_str" (stringFromText (A.since_id_str x)) <> + row "max_id_str" (stringFromText (A.max_id_str x)) <> + row "query" (stringFromText (A.query x)) + +story :: A.Story -> Literal +story x = + object $ + row "from_user_id_str" (stringFromText (A.from_user_id_str x)) <> + row "profile_image_url" (stringFromText (A.profile_image_url x)) <> + row "created_at" (stringFromText (A.created_at x)) <> + row "from_user" (stringFromText (A.from_user x)) <> + row "id_str" (stringFromText (A.id_str x)) <> + row "metadata" (metadata (A.metadata x)) <> + row "to_user_id" (maybe null (numberFromInt . fromIntegral) (A.to_user_id x)) <> + row "text" (stringFromText (A.text x)) <> + row "id" ((numberFromInt . fromIntegral) (A.id x)) <> + row "from_user_id" ((numberFromInt . fromIntegral) (A.from_user_id x)) <> + row "geo" (maybe null geo (A.geo x)) <> + row "iso_language_code" (stringFromText (A.iso_language_code x)) <> + row "to_user_id_str" (maybe null stringFromText (A.to_user_id_str x)) <> + row "source" (stringFromText (A.source x)) + +geo :: A.Geo -> Literal +geo x = + object $ + row "type_" (stringFromText (A.type_ x)) <> + row "coordinates" (coordinates (A.coordinates x)) + +coordinates :: (Double, Double) -> Literal +coordinates (x, y) = + array (element (numberFromDouble x) <> element (numberFromDouble y)) + +metadata :: A.Metadata -> Literal +metadata x = + object $ + row "result_type" (stringFromText (A.result_type x)) diff --git a/benchmark/Main/Model.hs b/benchmark/Main/Model.hs new file mode 100644 --- /dev/null +++ b/benchmark/Main/Model.hs @@ -0,0 +1,66 @@ +module Main.Model +( + Metadata(..), + Geo(..), + Story(..), + Result(..) +) +where + +import Rebase.Prelude hiding (id) + +data Metadata = + Metadata { + result_type :: Text + } + deriving (Eq, Show, Typeable, Data, Generic) + +instance NFData Metadata + +data Geo = + Geo { + type_ :: Text, + coordinates :: (Double, Double) + } + deriving (Eq, Show, Typeable, Data, Generic) + +instance NFData Geo + +data Story = + Story { + from_user_id_str :: Text, + profile_image_url :: Text, + created_at :: Text, + from_user :: Text, + id_str :: Text, + metadata :: Metadata, + to_user_id :: Maybe Int64, + text :: Text, + id :: Int64, + from_user_id :: Int64, + geo :: Maybe Geo, + iso_language_code :: Text, + to_user_id_str :: Maybe Text, + source :: Text + } + deriving (Show, Typeable, Data, Generic) + +instance NFData Story + +data Result = + Result { + results :: [Story], + max_id :: Int64, + since_id :: Int64, + refresh_url :: Text, + next_page :: Text, + results_per_page :: Int, + page :: Int, + completed_in :: Double, + since_id_str :: Text, + max_id_str :: Text, + query :: Text + } + deriving (Show, Typeable, Data, Generic) + +instance NFData Result diff --git a/json-bytes-builder.cabal b/json-bytes-builder.cabal --- a/json-bytes-builder.cabal +++ b/json-bytes-builder.cabal @@ -1,7 +1,7 @@ name: json-bytes-builder version: - 0.5 + 0.5.1 synopsis: Direct-to-bytes JSON Builder description: @@ -9,7 +9,7 @@ which is faster and simpler than \"aeson\". . Check out - . + . category: JSON, Codecs homepage: @@ -31,19 +31,17 @@ cabal-version: >=1.10 - source-repository head type: git location: git://github.com/nikita-volkov/json-bytes-builder.git - library hs-source-dirs: library default-extensions: - Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples + Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, PatternSynonyms, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples default-language: Haskell2010 other-modules: @@ -64,11 +62,7 @@ base-prelude < 2, base >= 4.7 && < 5 - --- Well, it's not a benchmark actually, --- but Cabal provides no better way to specify an executable, --- which is not intended for distribution. -benchmark demo +test-suite demo type: exitcode-stdio-1.0 hs-source-dirs: @@ -76,7 +70,7 @@ main-is: Main.hs default-extensions: - Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples + Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, PatternSynonyms, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples default-language: Haskell2010 build-depends: @@ -84,3 +78,35 @@ text, bytestring, base-prelude + +benchmark benchmark + type: + exitcode-stdio-1.0 + hs-source-dirs: + benchmark + main-is: + Main.hs + other-modules: + Main.Model + Main.JSONBytesBuilder + Main.Aeson + ghc-options: + -O2 + -threaded + "-with-rtsopts=-N" + ghc-prof-options: + -O2 + -threaded + -fprof-auto + "-with-rtsopts=-N -p -s -h -i0.1" + default-extensions: + Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, PatternSynonyms, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples + default-language: + Haskell2010 + build-depends: + json-bytes-builder, + -- benchmarking: + criterion == 1.1.*, + -- + aeson >= 0.10 && < 2, + rebase == 1.* diff --git a/library/JSONBytesBuilder/Private/Builder.hs b/library/JSONBytesBuilder/Private/Builder.hs --- a/library/JSONBytesBuilder/Private/Builder.hs +++ b/library/JSONBytesBuilder/Private/Builder.hs @@ -34,6 +34,8 @@ Rows Nothing -> id +instance Semigroup Rows + -- | -- Builder of JSON Array elements. newtype Elements = @@ -54,6 +56,8 @@ Elements (Just left) Elements Nothing -> id + +instance Semigroup Elements -- | -- JSON Null literal.