diff --git a/Data/Aeson.hs b/Data/Aeson.hs new file mode 100644 --- /dev/null +++ b/Data/Aeson.hs @@ -0,0 +1,33 @@ +-- Module: Data.Aeson +-- Copyright: (c) 2011 MailRank, Inc. +-- License: Apache +-- Maintainer: Bryan O'Sullivan +-- Stability: experimental +-- Portability: portable +-- +-- Types and functions for working efficiently with JSON data. +-- +-- (A note on naming: in Greek mythology, Aeson was the father of Jason.) + +module Data.Aeson + ( + -- * Core JSON types + Value(..) + , Array + , Object + -- * Type conversion + , FromJSON(..) + , ToJSON(..) + -- * Constructors and accessors + , (.=) + , (.:) + , (.:?) + , object + -- * Encoding and parsing + , encode + , json + ) where + +import Data.Aeson.Encode +import Data.Aeson.Parser +import Data.Aeson.Types diff --git a/Data/Aeson/Encode.hs b/Data/Aeson/Encode.hs new file mode 100644 --- /dev/null +++ b/Data/Aeson/Encode.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- Module: Data.Aeson.Encode +-- Copyright: (c) 2011 MailRank, Inc. +-- License: Apache +-- Maintainer: Bryan O'Sullivan +-- Stability: experimental +-- Portability: portable +-- +-- Efficiently serialize a JSON value as a lazy 'L.ByteString'. + +module Data.Aeson.Encode + ( + fromValue + , encode + ) where + +import Blaze.ByteString.Builder +import Blaze.ByteString.Builder.Char.Utf8 +import Data.Aeson.Types (ToJSON(..), Value(..)) +import Data.Monoid (mappend) +import Numeric (showHex) +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as L +import qualified Data.Map as M +import qualified Data.Text as T +import qualified Data.Vector as V + +-- | Encode a JSON value to a 'Builder'. +fromValue :: Value -> Builder +fromValue Null = fromByteString "null" +fromValue (Bool b) = fromByteString $ if b then "true" else "false" +fromValue (Number n) = fromByteString (B.pack (show n)) +fromValue (String s) = string s +fromValue (Array v) + | V.null v = fromByteString "[]" + | otherwise = fromChar '[' `mappend` + fromValue (V.unsafeHead v) `mappend` + V.foldr f (fromChar ']') (V.unsafeTail v) + where f a z = fromChar ',' `mappend` fromValue a `mappend` z +fromValue (Object m) = + case M.toList m of + (x:xs) -> fromChar '{' `mappend` + one x `mappend` + foldr f (fromChar '}') xs + _ -> fromByteString "{}" + where f a z = fromChar ',' `mappend` one a `mappend` z + one (k,v) = string k `mappend` fromChar ':' `mappend` fromValue v + +string :: T.Text -> Builder +string s = fromChar '"' `mappend` quote s `mappend` fromChar '"' + where + quote q = case T.uncons t of + Just (c,t') -> fromText h `mappend` escape c `mappend` quote t' + Nothing -> fromText h + where (h,t) = T.break isEscape q + isEscape c = c == '\"' || c == '\\' || c < '\x20' + escape '\"' = fromByteString "\\\"" + escape '\\' = fromByteString "\\\\" + escape '\n' = fromByteString "\\n" + escape '\r' = fromByteString "\\r" + escape '\t' = fromByteString "\\t" + escape c + | c < '\x20' = fromString $ "\\u" ++ replicate (4 - length h) '0' ++ h + | otherwise = fromChar c + where h = showHex (fromEnum c) "" + +-- | Efficiently serialize a JSON value as a lazy 'L.ByteString'. +encode :: ToJSON a => a -> L.ByteString +encode = toLazyByteString . fromValue . toJSON +{-# INLINE encode #-} diff --git a/Data/Aeson/Parser.hs b/Data/Aeson/Parser.hs new file mode 100644 --- /dev/null +++ b/Data/Aeson/Parser.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- Module: Data.Aeson.Parser +-- Copyright: (c) 2011 MailRank, Inc. +-- License: Apache +-- Maintainer: Bryan O'Sullivan +-- Stability: experimental +-- Portability: portable +-- +-- Efficiently and correctly parse a JSON string. + +module Data.Aeson.Parser + ( + json + , value + ) where + +import Blaze.ByteString.Builder (fromByteString, toByteString) +import Blaze.ByteString.Builder.Char.Utf8 (fromChar) +import Blaze.ByteString.Builder.Word (fromWord8) +import Control.Applicative as A +import Control.Monad (when) +import Data.Aeson.Types (Value(..)) +import Data.Attoparsec.Char8 +import Data.Bits ((.|.), shiftL) +import Data.ByteString as B +import Data.Char (chr) +import Data.Map as Map +import Data.Monoid (mappend, mempty) +import Data.Text as T +import Data.Text.Encoding (decodeUtf8) +import Data.Vector as Vector hiding ((++)) +import Data.Word (Word8) +import qualified Data.Attoparsec as A +import qualified Data.ByteString.Unsafe as B + +-- | Parse a top-level JSON value. This must be either an object or +-- an array. +json :: Parser Value +json = do + c <- skipSpace *> anyChar + case c of + '{' -> object_ + '[' -> array_ + _ -> fail "root value is not an object or array" + +object_ :: Parser Value +object_ = do + skipSpace + let pair = do + a <- jstring <* skipSpace + b <- char ':' *> skipSpace *> value + return (a,b) + vals <- ((pair <* skipSpace) `sepBy` (char ',' *> skipSpace)) <* char '}' + return . Object $ Map.fromList vals + +array_ :: Parser Value +array_ = do + skipSpace + vals <- ((value <* skipSpace) `sepBy` (char ',' *> skipSpace)) <* char ']' + return . Array $ Vector.fromList vals + +-- | Parse any JSON value. Use 'json' in preference to this function +-- if you are parsing data from an untrusted source. +value :: Parser Value +value = most <|> (Number <$> double) + where + most = do + c <- anyChar + case c of + '{' -> object_ + '[' -> array_ + '"' -> String <$> jstring_ + 'f' -> string "alse" *> pure (Bool False) + 't' -> string "rue" *> pure (Bool True) + 'n' -> string "ull" *> pure Null + _ -> fail "not a valid JSON value" + +doubleQuote, backslash :: Word8 +doubleQuote = 34 +backslash = 92 + +jstring :: Parser Text +jstring = A.word8 doubleQuote *> jstring_ + +-- | Parse a string without a leading quote. +jstring_ :: Parser Text +jstring_ = do + s <- A.scan False $ \s c -> if s then Just False + else if c == doubleQuote + then Nothing + else Just (c == backslash) + _ <- A.word8 doubleQuote + if backslash `B.elem` s + then decodeUtf8 <$> reparse unescape s + else return (decodeUtf8 s) + +reparse :: Parser a -> ByteString -> Parser a +reparse p s = case (case parse p s of {Partial k -> k ""; r -> r}) of + Done "" r -> return r + Fail _ _ msg -> fail msg + _ -> fail "unexpected failure" + +unescape :: Parser ByteString +unescape = toByteString <$> go mempty where + go acc = do + h <- A.takeWhile (/=backslash) + let rest = do + start <- A.take 2 + let !slash = B.unsafeHead start + !t = B.unsafeIndex start 1 + escape = case B.findIndex (==t) "\"\\/ntbrfu" of + Just i -> i + _ -> 255 + when (slash /= backslash || escape == 255) $ + fail "invalid JSON escape sequence" + let continue m = go (acc `mappend` fromByteString h `mappend` m) + {-# INLINE continue #-} + if t /= 117 -- 'u' + then continue (fromWord8 (B.unsafeIndex mapping escape)) + else do + a <- hexQuad + if a < 0xd800 || a > 0xdfff + then continue (fromChar (chr a)) + else do + b <- string "\\u" *> hexQuad + if a <= 0xdbff && b >= 0xdc00 && b <= 0xdfff + then let !c = ((a - 0xd800) `shiftL` 10) + (b - 0xdc00) + + 0x10000 + in continue (fromChar (chr c)) + else fail "invalid UTF-16 surrogates" + rest <|> return (acc `mappend` fromByteString h) + mapping = "\"\\/\n\t\b\r\f" + +hexQuad :: Parser Int +hexQuad = do + s <- A.take 4 + let hex n | w >= 48 && w <= 57 = w - 48 + | w >= 97 && w <= 122 = w - 87 + | w >= 65 && w <= 90 = w - 55 + | otherwise = 255 + where w = fromIntegral $ B.unsafeIndex s n + a = hex 0; b = hex 1; c = hex 2; d = hex 3 + if (a .|. b .|. c .|. d) /= 255 + then return $! d .|. (c `shiftL` 4) .|. (b `shiftL` 8) .|. (a `shiftL` 12) + else fail "invalid hex escape" diff --git a/Data/Aeson/Types.hs b/Data/Aeson/Types.hs new file mode 100644 --- /dev/null +++ b/Data/Aeson/Types.hs @@ -0,0 +1,291 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +-- Module: Data.Aeson.Types +-- Copyright: (c) 2011 MailRank, Inc. +-- License: Apache +-- Maintainer: Bryan O'Sullivan +-- Stability: experimental +-- Portability: portable +-- +-- Types for working with JSON data. + +module Data.Aeson.Types + ( + -- * Core JSON types + Value(..) + , Array + , Object + -- * Type conversion + , FromJSON(..) + , ToJSON(..) + -- * Constructors and accessors + , (.=) + , (.:) + , (.:?) + , object + ) where + +import Control.Applicative +import Control.DeepSeq (NFData(..)) +import Data.Map (Map) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as LB +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Data.Text (Text, pack, unpack) +import qualified Data.Text.Lazy as LT +import Data.Time.Clock (UTCTime) +import Data.Time.Format (formatTime, parseTime) +import Data.Typeable (Typeable) +import Data.Vector (Vector) +import System.Locale (defaultTimeLocale) +import qualified Data.Map as M +import qualified Data.Vector as V + +type Object = Map Text Value +type Array = Vector Value + +-- | A JSON value represented as a Haskell value. +data Value = Object Object + | Array Array + | String Text + | Number Double + | Bool !Bool + | Null + deriving (Eq, Show, Typeable) + +instance NFData Value where + rnf (Object o) = rnf o + rnf (Array a) = V.foldl' (\x y -> rnf y `seq` x) () a + rnf (String s) = rnf s + rnf (Number n) = rnf n + rnf (Bool b) = rnf b + rnf Null = () + +-- | Construct an 'Object' from a key and a value. +(.=) :: ToJSON a => Text -> a -> Object +name .= value = M.singleton name (toJSON value) +{-# INLINE (.=) #-} + +-- | Retrieve the value associated with the given key of an 'Object'. +-- The result is 'empty' if the key is not present or the value cannot +-- be converted to the desired type. +-- +-- This accessor is appropriate if the key and value /must/ be present +-- in an object for it to be valid. If the key and value are +-- optional, use '(.:?)' instead. +(.:) :: (Alternative f, FromJSON a) => Object -> Text -> f a +obj .: key = case M.lookup key obj of + Nothing -> empty + Just v -> fromJSON v +{-# INLINE (.:) #-} + +-- | Retrieve the value associated with the given key of an 'Object'. +-- The result is 'Nothing' if the key is not present, or 'empty' if +-- the value cannot be converted to the desired type. +-- +-- This accessor is most useful if the key and value can be absent +-- from an object without affecting its validity. If the key and +-- value are mandatory, use '(.:?)' instead. +(.:?) :: (Alternative f, FromJSON a) => Object -> Text -> f (Maybe a) +obj .:? key = case M.lookup key obj of + Nothing -> pure Nothing + Just v -> fromJSON v +{-# INLINE (.:?) #-} + +-- | Create a 'Value' from a list of 'Object's. If duplicate +-- keys arise, earlier keys and their associated values win. +object :: [Object] -> Value +object = Object . M.unions +{-# INLINE object #-} + +-- | A type that can be converted to JSON. +-- +-- An example type and instance: +-- +-- @data Coord { x :: Double, y :: Double } +-- +-- instance ToJSON Coord where +-- toJSON (Coord x y) = 'object' [\"x\" '.=' x, \"y\" '.=' y] +-- @ +class ToJSON a where + toJSON :: a -> Value + +-- | A type that can be converted from JSON, with the possibility of +-- failure. +-- +-- When writing an instance, use 'empty' to make a conversion fail, +-- e.g. if an 'Object' is missing a required key, or the value is of +-- the wrong type. +-- +-- An example type and instance: +-- +-- @data Coord { x :: Double, y :: Double } +-- +-- instance FromJSON Coord where +-- fromJSON ('Object' v) = Coord '<$>' +-- v '.:' \"x\" '<*>' +-- v '.:' \"y\" +-- +-- \-- A non-'Object' value is of the wrong type, so use 'empty' to fail. +-- fromJSON _ = 'empty' +-- @ +class FromJSON a where + fromJSON :: Alternative f => Value -> f a + +instance (ToJSON a) => ToJSON (Maybe a) where + toJSON (Just a) = toJSON a + toJSON Nothing = Null + {-# INLINE toJSON #-} + +instance (FromJSON a) => FromJSON (Maybe a) where + fromJSON Null = pure Nothing + fromJSON a = Just <$> fromJSON a + {-# INLINE fromJSON #-} + +instance (ToJSON a, ToJSON b) => ToJSON (Either a b) where + toJSON (Left a) = toJSON a + toJSON (Right b) = toJSON b + {-# INLINE toJSON #-} + +instance (FromJSON a, FromJSON b) => FromJSON (Either a b) where + fromJSON a = Left <$> fromJSON a <|> Right <$> fromJSON a + {-# INLINE fromJSON #-} + +instance ToJSON Bool where + toJSON = Bool + {-# INLINE toJSON #-} + +instance FromJSON Bool where + fromJSON (Bool b) = pure b + fromJSON _ = empty + {-# INLINE fromJSON #-} + +instance ToJSON Double where + toJSON = Number + {-# INLINE toJSON #-} + +instance FromJSON Double where + fromJSON (Number n) = pure n + fromJSON _ = empty + {-# INLINE fromJSON #-} + +instance ToJSON Int where + toJSON = Number . fromIntegral + {-# INLINE toJSON #-} + +instance FromJSON Int where + fromJSON (Number n) = pure (floor n) + fromJSON _ = empty + {-# INLINE fromJSON #-} + +instance ToJSON Integer where + toJSON = Number . fromIntegral + {-# INLINE toJSON #-} + +instance FromJSON Integer where + fromJSON (Number n) = pure (floor n) + fromJSON _ = empty + {-# INLINE fromJSON #-} + +instance ToJSON Text where + toJSON = String + {-# INLINE toJSON #-} + +instance FromJSON Text where + fromJSON (String t) = pure t + fromJSON _ = empty + {-# INLINE fromJSON #-} + +instance ToJSON LT.Text where + toJSON = String . LT.toStrict + {-# INLINE toJSON #-} + +instance FromJSON LT.Text where + fromJSON (String t) = pure (LT.fromStrict t) + fromJSON _ = empty + {-# INLINE fromJSON #-} + +instance ToJSON B.ByteString where + toJSON = String . decodeUtf8 + {-# INLINE toJSON #-} + +instance FromJSON B.ByteString where + fromJSON (String t) = pure . encodeUtf8 $ t + fromJSON _ = empty + {-# INLINE fromJSON #-} + +instance ToJSON LB.ByteString where + toJSON = toJSON . B.concat . LB.toChunks + {-# INLINE toJSON #-} + +instance FromJSON LB.ByteString where + fromJSON (String t) = pure . LB.fromChunks . (:[]) . encodeUtf8 $ t + fromJSON _ = empty + {-# INLINE fromJSON #-} + +mapA :: (Applicative f) => (t -> f a) -> [t] -> f [a] +mapA f = go + where + go (a:as) = (:) <$> f a <*> go as + go [] = pure [] + +instance (ToJSON a) => ToJSON [a] where + toJSON = Array . V.fromList . map toJSON + {-# INLINE toJSON #-} + +instance (FromJSON a) => FromJSON [a] where + fromJSON (Array a) = mapA fromJSON (V.toList a) + fromJSON _ = empty + {-# INLINE fromJSON #-} + +instance (ToJSON a) => ToJSON (Vector a) where + toJSON = Array . V.map toJSON + {-# INLINE toJSON #-} + +instance (FromJSON a) => FromJSON (Vector a) where + fromJSON (Array a) = V.fromList <$> mapA fromJSON (V.toList a) + fromJSON _ = empty + {-# INLINE fromJSON #-} + +instance ToJSON Value where + toJSON a = a + {-# INLINE toJSON #-} + +instance FromJSON Value where + fromJSON a = pure a + {-# INLINE fromJSON #-} + +-- We happen to use the same JSON formatting for a UTCTime as .NET +-- does for a DateTime. How handy! +instance ToJSON UTCTime where + toJSON t = String (pack (formatTime defaultTimeLocale "/Date(%s)/" t)) + {-# INLINE toJSON #-} + +instance FromJSON UTCTime where + fromJSON (String t) = + case parseTime defaultTimeLocale "/Date(%s)/" (unpack t) of + Just d -> pure d + _ -> empty + fromJSON _ = empty + {-# INLINE fromJSON #-} + +instance (ToJSON a, ToJSON b) => ToJSON (a,b) where + toJSON (a,b) = toJSON [toJSON a, toJSON b] + {-# INLINE toJSON #-} + +instance (FromJSON a, FromJSON b) => FromJSON (a,b) where + fromJSON (Array ab) = case V.toList ab of + [a,b] -> (,) <$> fromJSON a <*> fromJSON b + _ -> empty + fromJSON _ = empty + {-# INLINE fromJSON #-} + + + + + + + + + + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2011, MailRank, Inc. + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS +OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/README.markdown b/README.markdown new file mode 100644 --- /dev/null +++ b/README.markdown @@ -0,0 +1,27 @@ +# Welcome to aeson + +aeson is a fast Haskell library for working with JSON data. + +# Join in! + +We are happy to receive bug reports, fixes, documentation enhancements, +and other improvements. + +Please report bugs via the +[github issue tracker](http://github.com/mailrank/aeson/issues). + +Master [git repository](http://github.com/mailrank/aeson): + +* `git clone git://github.com/mailrank/aeson.git` + +There's also a [Mercurial mirror](http://bitbucket.org/bos/aeson): + +* `hg clone http://bitbucket.org/bos/aeson` + +(You can create and contribute changes using either git or Mercurial.) + +Authors +------- + +This library is written and maintained by Bryan O'Sullivan, +. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/aeson.cabal b/aeson.cabal new file mode 100644 --- /dev/null +++ b/aeson.cabal @@ -0,0 +1,94 @@ +name: aeson +version: 0.1.0.0 +license: BSD3 +license-file: LICENSE +category: Text, Web, JSON +copyright: Copyright 2011 MailRank, Inc. +author: Bryan O'Sullivan +maintainer: Bryan O'Sullivan +stability: experimental +tested-with: GHC == 6.12.3 +synopsis: Fast JSON parsing and generation +cabal-version: >= 1.8 +homepage: http://github.com/mailrank/aeson +bug-reports: http://github.com/mailrank/aeson/issues +build-type: Simple +description: + A JSON parsing and generation library optimized for ease of use + and high performance. + . + Parsing performance with GHC 6.12.3 on a late 2010 MacBook Pro + (2.66GHz Core i7), for mostly-English tweets from Twitter's JSON + search API: + . + * 854 bytes: 21054 msg\/sec (17.1 MB/sec) + . + * 6.4 KB: 4545 msg\/sec (28.6 MB/sec) + . + * 31.2 KB: 856 msg\/sec (26.1 MB/sec) + . + * 61.5 KB: 403 msg\/sec (24.2 MB/sec) + . + Handling heavily-escaped text is a little more work. Here is + parsing performance with Japanese tweets, where much of the text + is entirely Unicode-escaped: + . + * 14.6 KB: 1250 msg\/sec (17.9 MB/sec) + . + * 44.1 KB: 363 msg\/sec (15.6 MB/sec) + . + Encoding performance on the same machine and data: + . + * 854 bytes: 10647 msg\/sec (8.7 MB/sec) + . + * 6.4 KB: 2098 msg\/sec (13.2 MB/sec) + . + * 31.2 KB: 422 msg\/sec (12.9 MB/sec) + . + * 61.5 KB: 219 msg\/sec (13.2 MB/sec) + . + (A note on naming: in Greek mythology, Aeson was the father of Jason.) + +extra-source-files: + README.markdown + benchmarks/AesonParse.hs + benchmarks/EncodeFile.hs + benchmarks/JsonParse.hs + benchmarks/ReadFile.hs + +flag developer + description: operate in developer mode + default: False + +library + exposed-modules: + Data.Aeson + Data.Aeson.Encode + Data.Aeson.Parser + Data.Aeson.Types + + build-depends: + attoparsec >= 0.8.4.0, + base == 4.*, + blaze-builder >= 0.2.1.4, + bytestring, + containers, + deepseq, + old-locale, + text >= 0.11.0.2, + time, + vector >= 0.7 + + if flag(developer) + ghc-options: -Werror + ghc-prof-options: -auto-all + + ghc-options: -Wall + +source-repository head + type: git + location: http://github.com/mailrank/aeson + +source-repository head + type: mercurial + location: http://bitbucket.org/bos/aeson diff --git a/benchmarks/AesonParse.hs b/benchmarks/AesonParse.hs new file mode 100644 --- /dev/null +++ b/benchmarks/AesonParse.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE BangPatterns, OverloadedStrings #-} + +import Control.DeepSeq +import Control.Exception +import Control.Monad +import Data.Aeson +import Data.Aeson.Parser +import Data.Attoparsec +import Data.Time.Clock +import System.Environment (getArgs) +import System.IO +import qualified Data.ByteString as B + +main = do + (cnt:args) <- getArgs + let count = read cnt :: Int + forM_ args $ \arg -> bracket (openFile arg ReadMode) hClose $ \h -> do + putStrLn $ arg ++ ":" + start <- getCurrentTime + let loop !good !bad + | good+bad >= count = return (good, bad) + | otherwise = do + hSeek h AbsoluteSeek 0 + let refill = B.hGet h 16384 + result <- parseWith refill json =<< refill + case result of + Done _ r -> loop (good+1) bad + _ -> loop good (bad+1) + (good, _) <- loop 0 0 + end <- getCurrentTime + putStrLn $ " " ++ show good ++ " good, " ++ show (diffUTCTime end start) diff --git a/benchmarks/EncodeFile.hs b/benchmarks/EncodeFile.hs new file mode 100644 --- /dev/null +++ b/benchmarks/EncodeFile.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE BangPatterns, OverloadedStrings #-} + +import Control.Exception +import Control.Monad +import Data.Aeson +import Data.Aeson.Encode +import Data.Aeson.Parser +import Data.Attoparsec +import Data.Time.Clock +import System.Environment (getArgs) +import System.IO +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L + +main = do + (cnt:args) <- getArgs + let count = read cnt :: Int + forM_ args $ \arg -> bracket (openFile arg ReadMode) hClose $ \h -> do + putStrLn $ arg ++ ":" + start <- getCurrentTime + let loop !n + | n >= count = return () + | otherwise = {-# SCC "loop" #-} do + hSeek h AbsoluteSeek 0 + let refill = B.hGet h 16384 + result <- parseWith refill json =<< refill + case result of + Done _ r -> L.length (encode r) `seq` loop (n+1) + _ -> error $ "failed to read " ++ show arg + loop 0 + end <- getCurrentTime + putStrLn $ " " ++ show (diffUTCTime end start) diff --git a/benchmarks/JsonParse.hs b/benchmarks/JsonParse.hs new file mode 100644 --- /dev/null +++ b/benchmarks/JsonParse.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE BangPatterns, ScopedTypeVariables #-} + +import Control.DeepSeq +import Control.Exception +import Control.Monad +import Text.JSON +import Data.Time.Clock +import System.Environment (getArgs) +import System.IO +import qualified Data.ByteString as B + +instance NFData JSValue where + rnf JSNull = () + rnf (JSBool b) = rnf b + rnf (JSRational b r) = rnf b `seq` rnf r `seq` () + rnf (JSString s) = rnf (fromJSString s) + rnf (JSArray vs) = rnf vs + rnf (JSObject kvs) = rnf (fromJSObject kvs) + +main = do + (cnt:args) <- getArgs + let count = read cnt :: Int + forM_ args $ \arg -> do + putStrLn $ arg ++ ":" + start <- getCurrentTime + let loop !good !bad + | good+bad >= count = return (good, bad) + | otherwise = do + s <- readFile arg + case decodeStrict s of + Ok (v::JSValue) -> loop (good+1) 0 + _ -> loop 0 (bad+1) + (good, _) <- loop 0 0 + end <- getCurrentTime + putStrLn $ " " ++ show good ++ " good, " ++ show (diffUTCTime end start) diff --git a/benchmarks/ReadFile.hs b/benchmarks/ReadFile.hs new file mode 100644 --- /dev/null +++ b/benchmarks/ReadFile.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE BangPatterns, OverloadedStrings #-} + +import Control.DeepSeq +import Control.Exception +import Control.Monad +import Data.Aeson +import Data.Aeson.Parser +import Data.Attoparsec +import Data.Time.Clock +import System.Environment (getArgs) +import System.IO +import qualified Data.ByteString as B + +main = do + (cnt:args) <- getArgs + let count = read cnt :: Int + forM_ args $ \arg -> bracket (openFile arg ReadMode) hClose $ \h -> do + putStrLn $ arg ++ ":" + start <- getCurrentTime + let loop !n + | n >= count = return () + | otherwise = do + let go = do + s <- B.hGet h 16384 + if B.null s + then loop (n+1) + else go + go + loop 0 + end <- getCurrentTime + putStrLn $ " " ++ show (diffUTCTime end start)