diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 * ... diff --git a/bench/Twitter.hs b/bench/Twitter.hs --- a/bench/Twitter.hs +++ b/bench/Twitter.hs @@ -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" diff --git a/highjson.cabal b/highjson.cabal --- a/highjson.cabal +++ b/highjson.cabal @@ -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 diff --git a/src/Data/Json.hs b/src/Data/Json.hs new file mode 100644 --- /dev/null +++ b/src/Data/Json.hs @@ -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 #-} diff --git a/src/Data/Json/Parser.hs b/src/Data/Json/Parser.hs --- a/src/Data/Json/Parser.hs +++ b/src/Data/Json/Parser.hs @@ -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 diff --git a/src/Data/Json/Serialiser.hs b/src/Data/Json/Serialiser.hs new file mode 100644 --- /dev/null +++ b/src/Data/Json/Serialiser.hs @@ -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 #-} diff --git a/test/Data/Json/ParserSpec.hs b/test/Data/Json/ParserSpec.hs --- a/test/Data/Json/ParserSpec.hs +++ b/test/Data/Json/ParserSpec.hs @@ -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))