highjson 0.3.0.0 → 0.4.0.0

raw patch · 5 files changed

+282/−79 lines, 5 filesdep ~hvectPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: hvect

API changes (from Hackage documentation)

Files

• bench/Twitter.hs +28/−32
• highjson.cabal +2/−2
• src/Data/HighJson.hs +141/−10
• src/Data/HighJson/Types.hs +61/−18
• test/Data/JsonSpec.hs +50/−17

@@ -23,11 +23,10 @@     result_type :: Text   } deriving (Eq, Show, Typeable, Data, Generic) -metadataSpec :: HighSpec Metadata '[Text]+metadataSpec :: RecordTypeSpec Metadata '[Text] metadataSpec =     recSpec "MetaData" Nothing Metadata $     "result_type" .= result_type-    :+: RFEmpty  instance FromJSON Metadata where     parseJSON = jsonParser metadataSpec@@ -49,12 +48,11 @@   , coordinates :: (Double, Double)   } deriving (Eq, Show, Typeable, Data, Generic) -geoSpec :: HighSpec Geo '[Text, (Double, Double)]+geoSpec :: RecordTypeSpec Geo '[Text, (Double, Double)] geoSpec =     recSpec "Geo" Nothing Geo $     "type_" .= type_-    :+: "coordinates" .= coordinates-    :+: RFEmpty+    :& "coordinates" .= coordinates  instance FromJSON Geo where     parseJSON = jsonParser geoSpec@@ -89,25 +87,24 @@   , source            :: Text   } deriving (Show, Typeable, Data, Generic) -storySpec :: HighSpec Story '[Text, Text, Text, Text, Text, Metadata, Maybe Int64, Text, Int64,+storySpec :: RecordTypeSpec Story '[Text, Text, Text, Text, Text, Metadata, Maybe Int64, Text, Int64,                               Int64, Maybe Geo, Text, Maybe Text, Text] storySpec =     recSpec "Story" Nothing Story $     "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-    :+: RFEmpty+    :& "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 = jsonParser storySpec@@ -150,22 +147,21 @@   , query            :: Text   } deriving (Show, Typeable, Data, Generic) -resultSpec :: HighSpec Result '[[Story], Int64, Int64, Text, Text, Int, Int, Double, Text, Text,+resultSpec :: RecordTypeSpec Result '[[Story], Int64, Int64, Text, Text, Int, Int, Double, Text, Text,                                 Text] resultSpec =     recSpec "Result" Nothing Result $     "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-    :+: RFEmpty+    :& "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 = jsonParser resultSpec

@@ -1,5 +1,5 @@ name:                highjson-version:             0.3.0.0+version:             0.4.0.0 synopsis:            Spec based JSON parsing/serialisation description:         Low boilerplate, easy to use and very fast JSON serialisation and parsing without generics or TemplateHaskell homepage:            https://github.com/agrafix/highjson@@ -26,7 +26,7 @@   build-depends:                 aeson >= 1.0,                 base >=4.8 && <5,-                hvect >=0.2,+                hvect >=0.4,                 text >=1.1.1,                 lens   hs-source-dirs:      src

@@ -1,20 +1,33 @@+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE DataKinds #-} module Data.HighJson     ( -- * A json specification for any type-      HighSpec(..)+      HighSpec(..), SpecType(..)       -- * Construct specifications for records-    , recSpec, RecordFields(..), reqField, (.=), optField, (.=?)+    , recSpec, RecordTypeSpec, reqField, (.=), optField, (.=?)       -- * Construct specifications for sum types-    , sumSpec, SumOptions(..), sumOpt, (.->)+    , sumSpec, SumTypeSpec, sumOpt, (.->)+      -- * Construct specifications for enum types+    , enumSpec, EnumTypeSpec, enumOpt, (@->)+      -- * Shared between specifications for simplicity+    , IsDataSpec(..), (:&)(..)       -- * Generate json serializers/encoders and parsers from specs     , jsonSerializer, jsonEncoder, jsonParser       -- * Specification structures     , BodySpec(..)-    , RecordField(..), RecordSpec(..)-    , SumOption(..), SumSpec(..)+    , RecordField(..), RecordSpec(..), RecordFields(..)+    , SumOption(..), SumSpec(..), SumOptions(..)+    , EnumOption(..), EnumSpec(..)       -- * Aeson reexports     , ToJSON(..), FromJSON(..)+      -- * Implementation detail structures+    , PhantomEnumContainer(..), CombinableContainer(..)     ) where @@ -22,9 +35,79 @@  import Control.Lens hiding ((.=)) import Data.Aeson ((.:), (.:?), FromJSON(..), ToJSON(..))+import Data.Typeable import qualified Data.HVect as HV import qualified Data.Text as T +-- | Combination of two local specifications. For records, these are fields, for sum types and enums+-- these are the options.+data a :& b+    = a :& b+    deriving (Typeable, Eq, Show, Functor, Traversable, Foldable, Bounded)+infixr 8 :&++instance (Monoid a, Monoid b) => Monoid (a :& b) where+    mempty = mempty :& mempty+    (a :& b) `mappend` (a' :& b') = (a `mappend` a') :& (b `mappend` b')++-- | A monoidal type class that respects type level lists associated to the bodies+class CombinableContainer t where+    combineContainer :: t a (as :: [*]) -> t a (bs :: [*]) -> t a (HV.Append as bs)++instance CombinableContainer RecordFields where+    combineContainer = recAppend++instance CombinableContainer SumOptions where+    combineContainer = sumAppend++instance CombinableContainer PhantomEnumContainer where+    combineContainer (PhantomEnumContainer x) (PhantomEnumContainer y) =+        PhantomEnumContainer $ x ++ y++-- | A type class that allows a unified notation for records and sum types. Build specifications+-- using '(:&)' and '(.=)', '(.=?)', '(.->)' or '(@->)'+class IsDataSpec t where+    type DFields t :: [*]+    type DType t+    type DContainer t :: * -> [*] -> *+    compileRec :: t -> (DContainer t) (DType t) (DFields t)++instance IsDataSpec (RecordField t f) where+    type DFields (RecordField t f) = (f ': '[])+    type DType (RecordField t f) = t+    type DContainer (RecordField t f) = RecordFields+    compileRec x = x :+: RFEmpty++instance IsDataSpec (SumOption t f) where+    type DFields (SumOption t f) = (f ': '[])+    type DType (SumOption t f) = t+    type DContainer (SumOption t f) = SumOptions+    compileRec x = x :|: SOEmpty++newtype PhantomEnumContainer t (ts :: [*])+    = PhantomEnumContainer { unPhantomEnumContainer :: [EnumOption t] }++instance IsDataSpec (EnumOption t) where+    type DFields (EnumOption t) = (() ': '[])+    type DType (EnumOption t) = t+    type DContainer (EnumOption t) = PhantomEnumContainer+    compileRec x = PhantomEnumContainer [x]++instance (IsDataSpec x, IsDataSpec y, DType x ~ DType y, DContainer x ~ DContainer y, CombinableContainer (DContainer x)) => IsDataSpec (x :& y) where+    type DFields (x :& y) = HV.Append (DFields x) (DFields y)+    type DType (x :& y) = DType x+    type DContainer (x :& y) = DContainer x+    compileRec (x :& y) = combineContainer (compileRec x) (compileRec y)++recAppend :: RecordFields t as -> RecordFields t bs -> RecordFields t (HV.Append as bs)+recAppend RFEmpty bs = bs+recAppend (a :+: as) bs = a :+: (as `recAppend` bs)++sumAppend :: SumOptions t as -> SumOptions t bs -> SumOptions t (HV.Append as bs)+sumAppend SOEmpty bs = bs+sumAppend (a :|: as) bs = a :|: (as `sumAppend` bs)++-- | A required json field. The key must be present in the json. reqField :: FromJSON f => T.Text -> (t -> f) -> RecordField t f reqField jsonKey g =     RecordField@@ -34,9 +117,11 @@     , rf_get = g     } +-- | Alias for 'reqField' (.=) :: FromJSON f =>  T.Text -> (t -> f) -> RecordField t f jsonKey .= reader = reqField jsonKey reader +-- | An optional json field. optField :: FromJSON f => T.Text -> (t -> Maybe f) -> RecordField t (Maybe f) optField jsonKey g =     RecordField@@ -46,9 +131,11 @@     , rf_get = g     } +-- | Alias for 'optField' (.=?) :: FromJSON f =>  T.Text -> (t -> Maybe f) -> RecordField t (Maybe f) name .=? reader = optField name reader +-- | An option of a sum type sumOpt :: T.Text -> Prism' t o -> SumOption t o sumOpt jsonKey p =     SumOption@@ -56,22 +143,66 @@     , so_prism = p     } +-- | Alias for 'sumOpt' (.->) :: T.Text -> Prism' t o -> SumOption t o jsonKey .-> p = sumOpt jsonKey p -recSpec :: T.Text -> Maybe T.Text -> HV.HVectElim flds t -> RecordFields t flds -> HighSpec t flds+-- | An option of a classic enum+enumOpt :: T.Text -> Prism' t () -> EnumOption t+enumOpt jsonKey p =+    EnumOption+    { eo_jsonKey = jsonKey+    , eo_prism = p+    }++-- | Alias for 'enumOpt'+(@->) :: T.Text -> Prism' t () -> EnumOption t+jsonKey @-> p = enumOpt jsonKey p++-- | A specification for a record+type RecordTypeSpec t flds = HighSpec t 'SpecRecord flds++-- | The specification for a record. Contains a name, an optional description,+-- the constructor and a description how to parse and serialize fields respecting+-- a given json key.+recSpec ::+    (IsDataSpec q, DContainer q ~ RecordFields)+    => T.Text -> Maybe T.Text -> HV.HVectElim (DFields q) (DType q)+    -> q+    -> RecordTypeSpec (DType q) (DFields q) recSpec name mDesc mk fields =     HighSpec     { hs_name = name     , hs_description = mDesc-    , hs_bodySpec =-            BodySpecRecord $ RecordSpec (HV.uncurry mk) fields+    , hs_bodySpec = BodySpecRecord $ RecordSpec (HV.uncurry mk) (compileRec fields)     } -sumSpec :: T.Text -> Maybe T.Text -> SumOptions t flds -> HighSpec t flds+-- | A specification for an arbitrary sum type+type SumTypeSpec t flds = HighSpec t 'SpecSum flds++-- | The specification for a sum type. Contains a name, an optional description+-- and a mapping from all constructor (prims) to their respective json fields+sumSpec ::+    (IsDataSpec q, DContainer q ~ SumOptions)+    => T.Text -> Maybe T.Text -> q -> SumTypeSpec (DType q) (DFields q) sumSpec name mDesc opts =     HighSpec     { hs_name = name     , hs_description = mDesc-    , hs_bodySpec = BodySpecSum $ SumSpec opts+    , hs_bodySpec = BodySpecSum $ SumSpec (compileRec opts)+    }++-- | A specification for a classic enum+type EnumTypeSpec t flds = HighSpec t 'SpecEnum flds++-- | The specification for a classic enum type. Contains a name, an optional description+-- and a mapping from all constructors to ther counterpart json string names.+enumSpec ::+    (IsDataSpec q, DContainer q ~ PhantomEnumContainer)+    => T.Text -> Maybe T.Text -> q -> EnumTypeSpec (DType q) (DFields q)+enumSpec name mDesc opts =+    HighSpec+    { hs_name = name+    , hs_description = mDesc+    , hs_bodySpec = BodySpecEnum $ EnumSpec (unPhantomEnumContainer $ compileRec opts)     }

@@ -1,13 +1,15 @@+{-# LANGUAGE KindSignatures #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} module Data.HighJson.Types-    ( HighSpec(..)+    ( HighSpec(..), SpecType(..)     , BodySpec(..)     , RecordFields(..), RecordField(..), RecordSpec(..)     , SumOptions(..), SumOption(..), SumSpec(..)+    , EnumOption(..), EnumSpec(..)     , jsonSerializer, jsonEncoder, jsonParser     ) where@@ -21,16 +23,22 @@ import Data.Monoid import qualified Data.Text as T -data HighSpec a as+data SpecType+    = SpecRecord+    | SpecSum+    | SpecEnum++data HighSpec a (ty :: SpecType) as     = HighSpec     { hs_name :: !T.Text     , hs_description :: !(Maybe T.Text)-    , hs_bodySpec :: !(BodySpec a as)+    , hs_bodySpec :: !(BodySpec ty a as)     } -data BodySpec a as-    = BodySpecRecord !(RecordSpec a as)-    | BodySpecSum !(SumSpec a as)+data BodySpec ty a as where+    BodySpecRecord :: !(RecordSpec a as) -> BodySpec 'SpecRecord a as+    BodySpecSum :: !(SumSpec a as) -> BodySpec 'SpecSum a as+    BodySpecEnum :: !(EnumSpec a) -> BodySpec 'SpecEnum a as  data RecordFields t fs where     RFEmpty :: RecordFields t '[]@@ -69,20 +77,41 @@     { ss_options :: SumOptions a os     } -jsonSerializer :: AllHave ToJSON as => HighSpec a as -> a -> Value+data EnumOption t+    = EnumOption+    { eo_jsonKey :: !T.Text+    , eo_prism :: !(Prism' t ())+    }++data EnumSpec a+    = EnumSpec+    { es_options :: [EnumOption a]+    }++jsonSerializer :: AllHave ToJSON as => HighSpec a ty as -> a -> Value jsonSerializer hs val =-    object $ fst $     case hs_bodySpec hs of-      BodySpecSum s -> jsonSerSum s val-      BodySpecRecord r -> jsonSerRec r val+      BodySpecSum s -> object $ fst $ jsonSerSum s val+      BodySpecRecord r -> object $ fst $ jsonSerRec r val+      BodySpecEnum e -> toJSON $ jsonSerEnum e val -jsonEncoder :: AllHave ToJSON as => HighSpec a as -> a -> Encoding+jsonEncoder :: AllHave ToJSON as => HighSpec a ty as -> a -> Encoding jsonEncoder hs val =-    pairs $ snd $     case hs_bodySpec hs of-      BodySpecSum s -> jsonSerSum s val-      BodySpecRecord r -> jsonSerRec r val+      BodySpecSum s -> pairs $ snd $ jsonSerSum s val+      BodySpecRecord r -> pairs $ snd $ jsonSerRec r val+      BodySpecEnum e -> toEncoding $ jsonSerEnum e val +jsonSerEnum :: EnumSpec a -> a -> T.Text+jsonSerEnum (EnumSpec opts) val =+    loop opts+    where+      loop [] = error "Empty enum spec"+      loop (x : xs) =+          case val ^? eo_prism x of+            Just () -> eo_jsonKey x+            Nothing -> loop xs+ jsonSerSum :: forall a as. AllHave ToJSON as => SumSpec a as -> a -> ([Pair], Series) jsonSerSum (SumSpec sopts) val =     loop sopts@@ -115,12 +144,15 @@                     encoder = rf_jsonKey f .= rf_get f val                 in loop fs ((pair : ps), encoder <> encoding) -jsonParser :: AllHave FromJSON as => HighSpec a as -> Value -> Parser a+jsonParser :: AllHave FromJSON as => HighSpec a ty as -> Value -> Parser a jsonParser hs =-    withObject (T.unpack $ hs_name hs) $ \obj ->     case hs_bodySpec hs of-      BodySpecRecord r -> jsonParserRecord r obj-      BodySpecSum s -> jsonParserSum (hs_name hs) s obj+      BodySpecRecord r ->+          withObject (T.unpack $ hs_name hs) (jsonParserRecord r)+      BodySpecSum s ->+          withObject (T.unpack $ hs_name hs) (jsonParserSum (hs_name hs) s)+      BodySpecEnum e ->+          withText (T.unpack $ hs_name hs) (jsonParserEnum (hs_name hs) e)  jsonParserRecord :: forall a as. AllHave FromJSON as => RecordSpec a as -> Object -> Parser a jsonParserRecord (RecordSpec mk rflds) obj =@@ -151,3 +183,14 @@                 let parse =                         liftM (so_prism o #) $ obj .: so_jsonKey o                 in parse <|> loop os+++jsonParserEnum :: Monad m => T.Text -> EnumSpec a -> T.Text -> m a+jsonParserEnum name (EnumSpec sopts) t =+    loop sopts+    where+      loop [] = fail $ "Failed to parse as " ++ T.unpack name+      loop (x : xs) =+          if t == eo_jsonKey x+          then pure (eo_prism x # ())+          else loop xs

@@ -22,15 +22,14 @@    , sd_maybe :: Maybe Int    } deriving (Show, Eq) -someDummySpec :: HighSpec SomeDummy '[Int, Bool, T.Text, Either Bool T.Text, Maybe Int]+someDummySpec :: RecordTypeSpec SomeDummy '[Int, Bool, T.Text, Either Bool T.Text, Maybe Int] someDummySpec =     recSpec "Some Dummy" Nothing SomeDummy $     "int" .= sd_int-    :+: "bool" .= sd_bool-    :+: "text" .= sd_text-    :+: "either" .= sd_either-    :+: "maybe" .= sd_maybe-    :+: RFEmpty+    :& "bool" .= sd_bool+    :& "text" .= sd_text+    :& "either" .= sd_either+    :& "maybe" .= sd_maybe  instance ToJSON SomeDummy where     toJSON = jsonSerializer someDummySpec@@ -65,12 +64,11 @@    , sn_obj :: Maybe SomeNested    } deriving (Show, Eq, Typeable) -someNestedSpec :: HighSpec SomeNested '[[SomeNested], Maybe SomeNested]+someNestedSpec :: RecordTypeSpec SomeNested '[[SomeNested], Maybe SomeNested] someNestedSpec =     recSpec "Nested" Nothing SomeNested $     "list" .= sn_list-    :+: "obj" .=? sn_obj-    :+: RFEmpty+    :& "obj" .=? sn_obj  instance ToJSON SomeNested where     toJSON = jsonSerializer someNestedSpec@@ -88,14 +86,13 @@  makePrisms ''SomeSumType -someSumSpec :: HighSpec SomeSumType '[SomeDummy, Int, Bool, ()]+someSumSpec :: SumTypeSpec SomeSumType '[SomeDummy, Int, Bool, ()] someSumSpec =     sumSpec "SomeSum" Nothing $     "some_dummy" .-> _SomeDummyT-    :|: "some_int" .-> _SomeInt-    :|: "some_bool" .-> _SomeBool-    :|: "some_enum" .-> _SomeEnum-    :|: SOEmpty+    :& "some_int" .-> _SomeInt+    :& "some_bool" .-> _SomeBool+    :& "some_enum" .-> _SomeEnum  instance ToJSON SomeSumType where     toJSON = jsonSerializer someSumSpec@@ -118,12 +115,11 @@    , pt_val :: T.Text    } deriving (Show, Eq, Typeable) -paramTypeSpec :: FromJSON a => HighSpec (ParamType a) '[a, T.Text]+paramTypeSpec :: FromJSON a => RecordTypeSpec (ParamType a) '[a, T.Text] paramTypeSpec =     recSpec "Some Param" Nothing ParamType $     "key" .= pt_key-    :+: "val" .= pt_val-    :+: RFEmpty+    :& "val" .= pt_val  instance (ToJSON a, FromJSON a) => ToJSON (ParamType a) where     toJSON = jsonSerializer paramTypeSpec@@ -136,6 +132,39 @@     arbitrary =         ParamType <$> arbitrary <*> (unSomeText <$> arbitrary) +data SomeEnumType+   = SomeEnumA+   | SomeEnumB+   | SomeEnumC+   | SomeEnumD+   deriving (Show, Eq, Typeable)++makePrisms ''SomeEnumType++someEnumSpec :: EnumTypeSpec SomeEnumType '[(), (), (), ()]+someEnumSpec =+    enumSpec "SomeSum" Nothing $+    "a" @-> _SomeEnumA+    :& "b" @-> _SomeEnumB+    :& "c" @-> _SomeEnumC+    :& "d" @-> _SomeEnumD++instance ToJSON SomeEnumType where+    toJSON = jsonSerializer someEnumSpec+    toEncoding = jsonEncoder someEnumSpec++instance FromJSON SomeEnumType where+    parseJSON = jsonParser someEnumSpec++instance Arbitrary SomeEnumType where+    arbitrary =+        oneof+        [ pure SomeEnumA+        , pure SomeEnumB+        , pure SomeEnumC+        , pure SomeEnumD+        ]+ spec :: Spec spec =     describe "Parser and Serialiser" $@@ -148,8 +177,12 @@            (eitherDecode . encode) t == Right (t :: SomeDummy)        it "Handles arbitrary custom sum types correctly" $ property $ \t ->            (eitherDecode . encode) t == Right (t :: SomeSumType)+       it "Handles arbitrary custom enum types correctly" $ property $ \t ->+           (eitherDecode . encode) t == Right (t :: SomeEnumType)        it "Handles arbitrary custom parametrized types correctly" $ property $ \t ->            (eitherDecode . encode) t == Right (t :: ParamType SomeSumType)+       it "Handles arbitrary custom parametrized types correctly 2" $ property $ \t ->+           (eitherDecode . encode) t == Right (t :: ParamType SomeEnumType)        it "Handles nested types correctly" $           do let nested = SomeNested [SomeNested [] Nothing] (Just $ SomeNested [] Nothing)              eitherDecode (encode nested) `shouldBe` Right nested