highjson 0.1.0.0 → 0.2.0.0
raw patch · 7 files changed
+339/−26 lines, 7 filesdep +QuickCheckdep +buffer-builder
Dependencies added: QuickCheck, buffer-builder
Files
- README.md +18/−9
- bench/Twitter.hs +4/−4
- highjson.cabal +9/−5
- src/Data/Json.hs +93/−0
- src/Data/Json/Parser.hs +70/−6
- src/Data/Json/Serialiser.hs +110/−0
- test/Data/Json/ParserSpec.hs +35/−2
README.md view
@@ -9,14 +9,12 @@ Hackage: [highjson](http://hackage.haskell.org/package/highjson) -Low boilerplate, easy to use and very fast Haskell JSON parsing. **WARNING: Work in progress!**+Low boilerplate, easy to use and very fast Haskell JSON serialisation and parsing. **WARNING: Work in progress!** ## Usage ```haskell {-# LANGUAGE OverloadedStrings #-}-import Data.Json.Parser- data SomeDummy = SomeDummy { sd_int :: Int@@ -26,16 +24,28 @@ , sd_maybe :: Maybe Int } deriving (Show, Eq) +someDummySpec =+ JsonSpec SomeDummy $+ "int" .= sd_int+ :+: "bool" .= sd_bool+ :+: "text" .= sd_text+ :+: "either" .= sd_either+ :+: "maybe" .=? sd_maybe+ :+: EmptySpec++instance ToJson SomeDummy where+ toJson = makeSerialiser someDummySpec+ instance JsonReadable SomeDummy where- readJson =- runSpec SomeDummy $- "int" :&&: "bool" :&&: "text" :&&: "either" :&&: "maybe" :&&: ObjSpecNil+ readJson = makeParser someDummySpec test = parseJsonBs "{\"int\": 34, \"text\": \"Teext\", \"bool\": true, \"either\": false}"- == Right (SomeDummy 34 True "Teext" (Left False) Nothing)-```+ == Right (SomeDummy 34 True "Teext" (Left False) Nothing)+ ``` +For more usage examples check the tests.+ ## Install * Using cabal: `cabal install highjson`@@ -45,7 +55,6 @@ * Implement proper string parsing (handle escape charaters) * Write more tests-* Allow fast json generation via object specs * Generate typescript interfaces from object specs * ...
bench/Twitter.hs view
@@ -24,7 +24,7 @@ instance JsonReadable Metadata where readJson =- runSpec Metadata $ "result_type" :&&: ObjSpecNil+ runParseSpec $ OnlyConstr Metadata $ "result_type" :&&: ObjSpecNil instance NFData Metadata @@ -35,7 +35,7 @@ instance JsonReadable Geo where readJson =- runSpec Geo $ "type_" :&&: "coordinates" :&&: ObjSpecNil+ runParseSpec $ OnlyConstr Geo $ "type_" :&&: "coordinates" :&&: ObjSpecNil instance NFData Geo @@ -58,7 +58,7 @@ instance JsonReadable Story where readJson =- runSpec Story $+ runParseSpec $ OnlyConstr Story $ "from_user_id_str" :&&: "profile_image_url" :&&: "created_at" :&&: "from_user" :&&: "id_str" :&&: "metadata" :&&: "to_user_id" :&&: "text" :&&: "id" :&&: "from_user_id" :&&: "geo" :&&: "iso_language_code"@@ -83,7 +83,7 @@ instance JsonReadable Result where readJson =- runSpec Result $+ runParseSpec $ OnlyConstr Result $ "results" :&&: "max_id" :&&: "since_id" :&&: "refresh_url" :&&: "next_page" :&&: "results_per_page" :&&: "page" :&&: "completed_in" :&&: "since_id_str" :&&: "max_id_str" :&&: "query"
highjson.cabal view
@@ -1,7 +1,7 @@ name: highjson-version: 0.1.0.0-synopsis: Very fast JSON parsing-description: Low boilerplate, easy to use and very fast JSON parsing+version: 0.2.0.0+synopsis: Very fast JSON serialisation and parsing library+description: Low boilerplate, easy to use and very fast JSON serialisation and parsing homepage: https://github.com/agrafix/highjson bug-reports: https://github.com/agrafix/highjson/issues license: MIT@@ -21,6 +21,8 @@ library exposed-modules: Data.Json.Parser+ Data.Json.Serialiser+ Data.Json build-depends: base >=4.7 && <5, attoparsec >=0.13.0.0, bytestring >=0.10.4.0,@@ -30,7 +32,8 @@ text >=1.1.1, hashable >=1.1.2, scientific >=0.3.3,- hvect >=0.2+ hvect >=0.2,+ buffer-builder >=0.2.4 hs-source-dirs: src default-language: Haskell2010 @@ -44,7 +47,8 @@ base, hspec >= 2.0, highjson,- text+ text,+ QuickCheck >=2.8 default-language: Haskell2010 ghc-options: -Wall
+ src/Data/Json.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeOperators #-}+module Data.Json+ ( -- * DSL to define JSON structure+ JsonSpec(..), FieldSpec(..), FieldKey, P.reqKey, P.optKey, P.TypedKey+ , (.=), (.=?)+ -- * DSL to define JSON structure for sum types+ , JsonSumSpec(..), (P..->), (P.<||>), (S..<-)+ , -- * Make parsers and serialisers from spec+ makeParser, makeSerialiser, makeSumParser, makeSumSerialiser+ , S.ToJson(..), P.JsonReadable(..)+ , -- * Run parsers / serialisers+ P.parseJsonBs, P.parseJsonBsl, P.parseJsonT+ , S.serialiseJsonBs, S.serialiseJsonBsl, S.serialiseJsonT+ )+where++import Data.HVect+import Data.Typeable+import qualified Data.Json.Serialiser as S+import qualified Data.Json.Parser as P++-- | Describes JSON parsing and serialisation of a Haskell type+data JsonSpec k (ts :: [*])+ = JsonSpec+ { j_constr :: !(HVectElim ts k)+ , j_fields :: !(FieldSpec k ts)+ }++-- | Describes JSON parsing and serialisation of a list of fields+data FieldSpec k (ts :: [*]) where+ EmptySpec :: FieldSpec k '[]+ (:+:) :: (S.ToJson t, P.JsonReadable t, Typeable t) => !(FieldKey k t) -> !(FieldSpec k ts) -> FieldSpec k (t ': ts)++infixr 5 :+:++-- | Describes a json key+data FieldKey k t+ = FieldKey+ { fk_tk :: !(P.TypedKey t)+ , fk_sk :: !(S.SpecKey k t)+ }++-- | Construct a 'FieldKey' mapping a json key to a getter function+(.=) :: (S.ToJson t, P.JsonReadable t, Typeable t) => P.TypedKey t -> (k -> t) -> FieldKey k t+tk .= getter = FieldKey tk ((P.typedKeyKey tk) S..: getter)+{-# INLINE (.=) #-}++-- | Construct a 'FieldKey' mapping a json key to a getter function of+-- a 'Maybe' type. This allows to omit the key when generating json instead of+-- setting it to null.+(.=?) :: (S.ToJson t, P.JsonReadable t, Typeable t) => P.TypedKey (Maybe t) -> (k -> Maybe t) -> FieldKey k (Maybe t)+tk .=? getter = FieldKey tk ((P.typedKeyKey tk) S..:? getter)+{-# INLINE (.=?) #-}++-- | Construct a 'P.Parser' from 'JsonSpec' to implement 'P.JsonReadable' instances+makeParser :: JsonSpec k ts -> P.Parser k+makeParser spec = P.runParseSpec $ (j_constr spec) P.:$: (mkObjSpec $ j_fields spec)+{-# INLINE makeParser #-}++mkObjSpec :: FieldSpec k ts -> P.ObjSpec ts+mkObjSpec EmptySpec = P.ObjSpecNil+mkObjSpec (FieldKey k _ :+: xs) = k P.:&&: mkObjSpec xs++-- | Construct a function from 'JsonSpec' to implement 'S.ToJson' instances+makeSerialiser :: JsonSpec k ts -> k -> S.Value+makeSerialiser spec = S.runSerSpec (S.SingleConstr $ mkSerSpec (j_fields spec))+{-# INLINE makeSerialiser #-}++mkSerSpec :: FieldSpec k ts -> S.SerObjSpec k ts+mkSerSpec EmptySpec = S.SerObjSpecNil+mkSerSpec (FieldKey _ getter :+: xs) = getter S.:&&&: mkSerSpec xs++-- | Describes JSON parsing and serialisation of a Haskell sum type. Currently+-- the library can only guarantee matching parsers/serialisers for+-- non-sum types using 'JsonSpec'.+data JsonSumSpec k+ = JsonSumSpec+ { js_parser :: !P.ParseSpec k+ , js_serialiser :: !(k -> S.KeyedSerialiser k)+ }++-- | Construct a 'P.Parser' from 'JsonSumSpec' to implement 'P.JsonReadable' instances+makeSumParser :: JsonSumSpec k -> P.Parser k+makeSumParser = P.runParseSpec . js_parser+{-# INLINE makeSumParser #-}++-- | Construct a function from 'JsonSumSpec' to implement 'S.ToJson' instances+makeSumSerialiser :: JsonSumSpec k -> k -> S.Value+makeSumSerialiser s = S.runSerSpec (S.MultiConstr (js_serialiser s))+{-# INLINE makeSumSerialiser #-}
src/Data/Json/Parser.hs view
@@ -4,21 +4,23 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-}-{-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-} module Data.Json.Parser ( -- * Parsing from different types parseJsonBs, parseJsonBsl, parseJsonT -- * Description how to parse JSON to a Haskell type , JsonReadable(..) -- * DSL to easily create parser for custom Haskell types- , runSpec, ObjSpec(..)- , TypedKey, reqKey, optKey+ , runParseSpec, ObjSpec(..), ParseSpec(..), KeyedConstr, (.->), (<||>)+ , ConstrTagger, ResultType+ , TypedKey, reqKey, optKey, typedKeyKey -- * Low level JSON parsing helpers- , readObject, WrappedValue(..), getValueByKey, getOptValueByKey+ , readObject, Parser, WrappedValue(..), getValueByKey, getOptValueByKey ) where @@ -200,8 +202,11 @@ <|> () <$ readJList readAnyJsonVal {-# INLINE readAnyJsonVal #-} +instance JsonReadable a => JsonReadable (HVect '[a]) where+ readJson = liftM singleton readJson+ -- | Parse a json object given a value parser for each key-readObject :: (T.Text -> Maybe (Parser WrappedValue)) -> Parser (HM.HashMap T.Text WrappedValue)+readObject :: (T.Text -> Maybe (Parser a)) -> Parser (HM.HashMap T.Text a) readObject getKeyParser = do skipSpace char '{'@@ -263,9 +268,15 @@ data TypedKey t = TypedKey !(KeyReader t) !T.Text +-- | Get the textual key of a 'TypedKey'+typedKeyKey :: TypedKey t -> T.Text+typedKeyKey (TypedKey _ t) = t+{-# INLINE typedKeyKey #-}+ -- | Required json object key. Use 'IsString' instance for automatic choice reqKey :: Typeable t => T.Text -> TypedKey t reqKey = TypedKey getValueByKey+{-# INLINE reqKey #-} -- | Optional json object key. Use 'IsString' instance for automatic choice optKey :: Typeable t => T.Text -> TypedKey (Maybe t)@@ -275,6 +286,7 @@ optGetter k hm = do mOpt <- getOptValueByKey k hm return $ join mOpt+{-# INLINE optKey #-} instance Typeable t => IsString (TypedKey (Maybe t)) where fromString = optKey . T.pack@@ -282,6 +294,58 @@ instance Typeable t => IsString (TypedKey t) where fromString = reqKey . T.pack +-- | Associates a json key with a parser+data KeyedConstr k+ = KeyedConstr+ { kc_key :: !T.Text+ , kc_parser :: !(Parser k)+ }++class ConstrTagger r where+ type ResultType r :: *+ -- | Associate a json key with a parser+ (.->) :: T.Text -> Parser (ResultType r) -> r++instance ConstrTagger (KeyedConstr k) where+ type ResultType (KeyedConstr k) = k+ key .-> parser = KeyedConstr key parser++instance ConstrTagger (ParseSpec k) where+ type ResultType (ParseSpec k) = k+ key .-> parser = FirstConstr (KeyedConstr key parser)++-- | Parser specification. Use ':$:' for normal types and 'FirstConstr' / ':|:' for sum types+data ParseSpec k where+ (:$:) :: HVectElim ts k -> ObjSpec ts -> ParseSpec k+ FirstConstr :: KeyedConstr k -> ParseSpec k+ (:|:) :: KeyedConstr k -> ParseSpec k -> ParseSpec k++infixr 4 :$:+infixr 3 <||>++-- | Choice between multiple constructors+(<||>) :: KeyedConstr k -> ParseSpec k -> ParseSpec k+(<||>) = (:|:)+{-# INLINE (<||>) #-}++-- | Convert a 'ParseSpec' into a 'Parser'+runParseSpec :: ParseSpec k -> Parser k+runParseSpec x =+ case x of+ constr :$: spec ->+ runSpec constr spec+ FirstConstr (KeyedConstr key parser) ->+ let keyGetter reqKey =+ if reqKey == key+ then Just parser+ else Nothing+ in do hm <- readObject keyGetter+ case HM.lookup key hm of+ Nothing -> fail ("Missing key " ++ show key)+ Just x -> return x+ constr :|: next ->+ runParseSpec (FirstConstr constr) <|> runParseSpec next+ -- | List of 'TypedKey's, should be in the same order as your -- constructor in 'runSpec' will expect them data ObjSpec (ts :: [*]) where@@ -308,7 +372,7 @@ ) -- | Convert an 'ObjSpec' into a 'Parser' provided a constructor--- function+-- function for defining 'JsonReadable' instances. runSpec :: HVectElim ts x -> ObjSpec ts -> Parser x runSpec mkVal spec = do let (mkTyVect, kv) = compileSpec spec
+ src/Data/Json/Serialiser.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeOperators #-}+module Data.Json.Serialiser+ ( -- * Serialising to different types+ serialiseJsonBs, serialiseJsonBsl, serialiseJsonT+ -- * Description how to serialise JSON from a Haskell type+ , ToJson(..)+ -- * DSL to easily create serialiser for custom Haskell types+ , runSerSpec, SerSpec(..), (.<-), KeyedSerialiser, SerObjSpec(..)+ , SpecKey, (.:), (.:?)+ -- * Low level JSON serialising helpers+ , ObjectBuilder, emptyObject, Value, (.=), (.=#), row, array, nullValue+ )+where++import Data.BufferBuilder.Json+import Data.Monoid+import Data.Typeable+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL+import qualified Data.Text as T+import qualified Data.Text.Encoding as T++instance (ToJson a, ToJson b) => ToJson (Either a b) where+ toJson x =+ case x of+ Left y -> toJson y+ Right z -> toJson z++-- | A json key and a getter+data SpecKey k t+ = SpecKey+ { k_key :: !T.Text+ , k_getVal :: !(k -> Maybe t)+ }++-- | Construct a 'SpecKey' mapping a json key to a getter function+(.:) :: (ToJson t, Typeable t) => T.Text -> (k -> t) -> SpecKey k t+k .: getter = SpecKey k (Just . getter)+{-# INLINE (.:) #-}++-- | Construct a 'SpecKey' mapping a json key to a getter function of+-- a 'Maybe' type. This allows to omit the key when generating json instead of+-- setting it to null.+(.:?) :: (ToJson t, Typeable t) => T.Text -> (k -> Maybe t) -> SpecKey k (Maybe t)+k .:? getter =+ SpecKey k $ \obj ->+ let val = getter obj+ in case val of+ Nothing -> Nothing+ Just _ -> Just val+{-# INLINE (.:?) #-}++newtype KeyedSerialiser k+ = KeyedSerialiser { unKeyedSerialiser :: Value }++-- | Associate a JSON key with a serialiser+(.<-) :: ToJson a => T.Text -> a -> KeyedSerialiser k+a .<- b = KeyedSerialiser $ toJson (a .= b)+{-# INLINE (.<-) #-}++-- | Parser specification. Use 'OnlyConstr' for normal types and 'FirstConstr'/'NextConstr' for sum types+data SerSpec k where+ SingleConstr :: SerObjSpec k ts -> SerSpec k+ MultiConstr :: (k -> KeyedSerialiser k) -> SerSpec k++runSerSpec :: SerSpec k -> k -> Value+runSerSpec spec input =+ case spec of+ SingleConstr fullSpec -> runSerObjSpec fullSpec input+ MultiConstr getVal -> unKeyedSerialiser $ getVal input+{-# INLINE runSerSpec #-}++-- | List of 'SpecKey's defining the serialisation of values to json+data SerObjSpec k (ts :: [*]) where+ SerObjSpecNil :: SerObjSpec k '[]+ (:&&&:) :: (ToJson t, Typeable t) => !(SpecKey k t) -> !(SerObjSpec k ts) -> SerObjSpec k (t ': ts)++infixr 5 :&&&:++-- | Convert a 'SerObjSpec' into an 'Value' for defining 'ToJson' instances+runSerObjSpec :: SerObjSpec k ts -> k -> Value+runSerObjSpec spec input = toJson (buildSpec spec input)+{-# INLINE runSerObjSpec #-}++buildSpec :: SerObjSpec k ts -> k -> ObjectBuilder+buildSpec spec input =+ case spec of+ SerObjSpecNil -> mempty+ (SpecKey key getVal :&&&: xs) ->+ case getVal input of+ Nothing -> buildSpec xs input+ Just val -> key .= getVal input <> buildSpec xs input++-- | Serialise json to a strict 'BS.ByteString'+serialiseJsonBs :: ToJson a => a -> BS.ByteString+serialiseJsonBs = encodeJson+{-# INLINE serialiseJsonBs #-}++-- | Serialise json to a lazy 'BSL.ByteString'+serialiseJsonBsl :: ToJson a => a -> BSL.ByteString+serialiseJsonBsl = BSL.fromStrict . serialiseJsonBs+{-# INLINE serialiseJsonBsl #-}++-- | Serialise json to a strict 'T.Text'+serialiseJsonT :: ToJson a => a -> T.Text+serialiseJsonT = T.decodeUtf8 . serialiseJsonBs+{-# INLINE serialiseJsonT #-}
test/Data/Json/ParserSpec.hs view
@@ -4,6 +4,7 @@ import Data.Json.Parser +import Control.Applicative import Data.Typeable import qualified Data.Text as T import Test.Hspec@@ -19,7 +20,7 @@ instance JsonReadable SomeDummy where readJson =- runSpec SomeDummy $ "int" :&&: "bool" :&&: "text" :&&: "either" :&&: "maybe" :&&: ObjSpecNil+ runParseSpec $ SomeDummy :$: "int" :&&: "bool" :&&: "text" :&&: "either" :&&: "maybe" :&&: ObjSpecNil data SomeNested = SomeNested@@ -29,8 +30,37 @@ instance JsonReadable SomeNested where readJson =- runSpec SomeNested $ "list" :&&: "obj" :&&: ObjSpecNil+ runParseSpec $ SomeNested :$: "list" :&&: "obj" :&&: ObjSpecNil +data Foo+ = Foo+ { f_fooVal :: Int+ } deriving (Show, Eq)++instance JsonReadable Foo where+ readJson =+ runParseSpec $ Foo :$: "value" :&&: ObjSpecNil++data Bar+ = Bar+ { b_barVal :: Int+ } deriving (Show, Eq)++instance JsonReadable Bar where+ readJson =+ runParseSpec $ Bar :$: "value" :&&: ObjSpecNil++data SumType+ = SumFoo Foo+ | SumBar Bar+ deriving (Show, Eq)++instance JsonReadable SumType where+ readJson =+ runParseSpec $+ "foo" .-> (SumFoo <$> readJson)+ <||> "bar" .-> (SumBar <$> readJson)+ spec :: Spec spec = describe "Parser" $@@ -48,3 +78,6 @@ it "Parses bools correctly" $ do parseJsonBs "true" `shouldBe` Right True parseJsonBs "false" `shouldBe` Right False+ it "Handles sum types correctly" $+ do parseJsonBs "{\"foo\": {\"value\": 42}}" `shouldBe` Right (SumFoo (Foo 42))+ parseJsonBs "{\"bar\": {\"value\": 42}}" `shouldBe` Right (SumBar (Bar 42))