json-sop 0.2.0.5 → 0.2.1
raw patch · 4 files changed
+136/−66 lines, 4 filesdep +json-sopdep +tastydep +tasty-quickcheckdep ~aesondep ~basedep ~generics-sopPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: json-sop, tasty, tasty-quickcheck
Dependency ranges changed: aeson, base, generics-sop, time, vector
API changes (from Hackage documentation)
- Generics.SOP.JSON: data JsonInfo :: [*] -> *
+ Generics.SOP.JSON: data JsonInfo :: [Type] -> Type
- Generics.SOP.JSON.Model: class JsonModel (a :: *)
+ Generics.SOP.JSON.Model: class JsonModel (a :: Type)
Files
- json-sop.cabal +19/−9
- src/Generics/SOP/JSON.hs +34/−37
- src/Generics/SOP/JSON/Model.hs +9/−20
- test/Test_JSON_SOP.hs +74/−0
json-sop.cabal view
@@ -1,5 +1,5 @@ name: json-sop-version: 0.2.0.5+version: 0.2.1 synopsis: Generics JSON (de)serialization using generics-sop description: This library contains generic serialization and deserialization functions@@ -13,7 +13,7 @@ category: Generics build-type: Simple cabal-version: >=1.10-tested-with: GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.2+tested-with: GHC ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.1 || ==9.2.1 source-repository head type: git@@ -23,15 +23,15 @@ exposed-modules: Generics.SOP.JSON Generics.SOP.JSON.Model other-modules: Generics.SOP.Util.PartialResult- build-depends: base >= 4.6 && < 5,+ build-depends: base >= 4.11 && < 4.17, generics-sop >= 0.2.3 && < 0.6, lens-sop >= 0.2 && < 0.3, tagged >= 0.7 && < 0.9,- aeson >= 0.7 && < 1.6,+ aeson >= 1.4 && < 2.1, vector >= 0.10 && < 0.13, text >= 1.1 && < 1.3, unordered-containers >= 0.2 && < 0.3,- time >= 1.4 && < 1.10,+ time >= 1.4 && < 1.12, transformers >= 0.3 && < 0.6 hs-source-dirs: src default-language: Haskell2010@@ -54,9 +54,19 @@ DataKinds FunctionalDependencies CPP- if impl (ghc >= 7.8) && impl (ghc < 8.2)- default-extensions: AutoDeriveTypeable other-extensions: OverloadedStrings PolyKinds- if impl (ghc < 7.10)- other-extensions: OverlappingInstances++test-suite test-json-sop+ type: exitcode-stdio-1.0+ main-is: Test_JSON_SOP.hs+ default-language: Haskell2010+ hs-source-dirs: test+ build-depends: base+ , json-sop++ , aeson+ , tasty+ , tasty-quickcheck+ , generics-sop+ ghc-options: -Wall
src/Generics/SOP/JSON.hs view
@@ -1,7 +1,5 @@ {-# LANGUAGE PolyKinds #-}-#if __GLASGOW_HASKELL__ < 710-{-# LANGUAGE OverlappingInstances #-}-#endif+ module Generics.SOP.JSON ( -- * Configuration JsonFieldName@@ -28,13 +26,22 @@ import Control.Arrow (first) import Control.Monad-import Data.Aeson (ToJSON(..), FromJSON(..), Value(..))+import Data.Aeson (ToJSON(..), FromJSON(..), Value(..), object, (.=)) import Data.Aeson.Types (Parser, modifyFailure)+import Data.Kind import Data.List (intercalate)+import Data.String (fromString) import Data.Text (Text)++import qualified Data.Text as Text+import qualified Data.Vector as Vector++#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.Key as Key+import qualified Data.Aeson.KeyMap as KeyMap+#else import qualified Data.HashMap.Strict as HashMap-import qualified Data.Text as Text-import qualified Data.Vector as Vector+#endif import Generics.SOP import Generics.SOP.Lens@@ -83,7 +90,7 @@ -- their constructor; but for a datatype with multiple constructors we do. data Tag = NoTag | Tag JsonTagName -data JsonInfo :: [*] -> * where+data JsonInfo :: [Type] -> Type where -- Constructor without arguments -- -- In this we _just_ output the name of the constructor (as a string);@@ -124,7 +131,7 @@ jsonInfo pa opts = case datatypeInfo pa of Newtype {} -> JsonOne NoTag :* Nil- d @ ADT {} ->+ d@ADT {} -> hliftA (jsonInfoFor opts@@ -161,13 +168,9 @@ $ cs gtoJSON' (JsonRecord tag fields) cs = tagValue tag- . Object- . HashMap.fromList+ . object . hcollapse- $ hcliftA2 pt (\(K field) (I a) -> K (Text.pack field, toJSON a)) fields cs-#if __GLASGOW_HASKELL__ < 800-gtoJSON' _ _ = error "inaccessible"-#endif+ $ hcliftA2 pt (\(K field) (I a) -> K (fromString field .= a)) fields cs {------------------------------------------------------------------------------- Decoder@@ -188,7 +191,7 @@ => JsonOptions -> Value -> Parser a gparseJSON opts v = to `liftM` gparseJSON' v (jsonInfo (Proxy :: Proxy a) opts) -gparseJSON' :: forall (xss :: [[*]]). All2 FromJSON xss+gparseJSON' :: forall (xss :: [[Type]]). All2 FromJSON xss => Value -> NP JsonInfo xss -> Parser (SOP I xss) gparseJSON' v info = runPartial failWith . msum@@ -203,7 +206,7 @@ injs :: NP (Injection (NP I) xss) xss injs = injections -parseConstructor :: forall (xss :: [[*]]) (xs :: [*]). All FromJSON xs+parseConstructor :: forall (xss :: [[Type]]) (xs :: [Type]). All FromJSON xs => Value -> JsonInfo xs -> Injection (NP I) xss xs -> K (Partial Parser (SOP I xss)) xs parseConstructor v info (Fn inj) = K $ do vals <- parseValues info v@@ -217,7 +220,7 @@ -- | Given information about a constructor, check if the given value has the -- right shape, and if so, return a product of (still encoded) values for -- each of the arguments of the constructor-parseValues :: forall (xs :: [*]). SListI xs+parseValues :: forall (xs :: [Type]). SListI xs => JsonInfo xs -> Value -> Partial Parser (NP (K (Maybe String, Value)) xs) parseValues (JsonZero n) = withText ("Expected literal " ++ show n) $ \txt -> do@@ -284,29 +287,22 @@ parseWith :: UpdateFromJSON a => a -> Value -> Parser a parseWith a = liftM ($ a) . updateFromJSON -instance-#if __GLASGOW_HASKELL__ >= 710- {-# OVERLAPPABLE #-}-#endif- FromJSON a => UpdateFromJSON [a] where updateFromJSON = replaceWithJSON-instance-#if __GLASGOW_HASKELL__ >= 710- {-# OVERLAPPABLE #-}-#endif- FromJSON a => UpdateFromJSON (Maybe a) where updateFromJSON = replaceWithJSON+instance {-# OVERLAPPABLE #-} FromJSON a => UpdateFromJSON [a]+ where updateFromJSON = replaceWithJSON +instance {-# OVERLAPPABLE #-} FromJSON a => UpdateFromJSON (Maybe a)+ where updateFromJSON = replaceWithJSON+ -- Primitive types we can only replace whole instance UpdateFromJSON Int where updateFromJSON = replaceWithJSON instance UpdateFromJSON Double where updateFromJSON = replaceWithJSON instance UpdateFromJSON Rational where updateFromJSON = replaceWithJSON instance UpdateFromJSON Bool where updateFromJSON = replaceWithJSON instance UpdateFromJSON Text where updateFromJSON = replaceWithJSON-instance-#if __GLASGOW_HASKELL__ >= 710- {-# OVERLAPPING #-}-#endif- UpdateFromJSON String where updateFromJSON = replaceWithJSON +instance {-# OVERLAPPING #-} UpdateFromJSON String+ where updateFromJSON = replaceWithJSON+ {------------------------------------------------------------------------------- Generic instance for UpdateFromJSON -------------------------------------------------------------------------------}@@ -319,11 +315,8 @@ case jsonInfo (Proxy :: Proxy a) opts of JsonRecord _ fields :* Nil -> gupdateRecord fields glenses v _ :* Nil -> error "cannot update non-record type"-#if __GLASGOW_HASKELL__ < 800- _ -> error "inaccessible"-#endif -gupdateRecord :: forall (xs :: [*]) (a :: *). All UpdateFromJSON xs+gupdateRecord :: forall (xs :: [Type]) (a :: Type). All UpdateFromJSON xs => NP (K String) xs -> NP (GLens (->) (->) a) xs -> Value -> Parser (a -> a) gupdateRecord fields lenses = withObject "Object" $ \obj -> do values :: NP (K (Maybe Value)) xs <- lineup fields obj@@ -383,7 +376,7 @@ tagValue :: Tag -> Value -> K Value a tagValue NoTag v = K v-tagValue (Tag t) v = K $ Object $ HashMap.fromList [(Text.pack t, v)]+tagValue (Tag t) v = K $ object $ [fromString t .= v] {------------------------------------------------------------------------------- Constraint proxies@@ -413,7 +406,11 @@ #else withObject :: Monad m => String -> ([(String, Value)] -> m a) -> Value -> m a #endif+#if MIN_VERSION_aeson(2,0,0)+withObject _ f (Object obj) = f $ map (first Key.toString) (KeyMap.toList obj)+#else withObject _ f (Object obj) = f $ map (first Text.unpack) (HashMap.toList obj)+#endif withObject expected _ v = typeMismatch expected v #if MIN_VERSION_base(4,13,0)
src/Generics/SOP/JSON/Model.hs view
@@ -1,7 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}-#if __GLASGOW_HASKELL__ < 710-{-# LANGUAGE OverlappingInstances #-}-#endif+ module Generics.SOP.JSON.Model ( JsonModel(..) , gjsonModel@@ -11,7 +9,10 @@ ) where import Data.Aeson+import Data.Kind+import Data.String (fromString) import Data.Tagged+ import qualified Data.Text as Text import qualified Data.Text.Lazy as Text.Lazy import qualified Data.Vector as Vector@@ -23,7 +24,7 @@ import Data.Time (UTCTime) import Data.Text (Text) -class JsonModel (a :: *) where+class JsonModel (a :: Type) where jsonModel :: Tagged a Value {-------------------------------------------------------------------------------@@ -39,11 +40,7 @@ instance JsonModel Text.Lazy.Text where jsonModel = Tagged $ String "String" -instance-#if __GLASGOW_HASKELL__ >= 710- {-# OVERLAPPING #-}-#endif- JsonModel String where+instance {-# OVERLAPPING #-} JsonModel String where jsonModel = Tagged $ String "String" instance JsonModel Int where@@ -58,20 +55,12 @@ instance JsonModel Bool where jsonModel = Tagged $ String "Bool" -instance-#if __GLASGOW_HASKELL__ >= 710- {-# OVERLAPPABLE #-}-#endif- JsonModel a => JsonModel [a] where+instance {-# OVERLAPPABLE #-} JsonModel a => JsonModel [a] where jsonModel = let model :: Tagged a Value model = jsonModel in Tagged $ object [ "List" .= untag model ] -instance-#if __GLASGOW_HASKELL__ >= 710- {-# OVERLAPPABLE #-}-#endif- JsonModel a => JsonModel (Maybe a) where+instance {-# OVERLAPPABLE #-} JsonModel a => JsonModel (Maybe a) where jsonModel = let model :: Tagged a Value model = jsonModel in Tagged $ Array $ Vector.fromList [ untag model, Null ]@@ -129,7 +118,7 @@ tagModel :: Tag -> Value -> Value tagModel NoTag v = v-tagModel (Tag n) v = object [ "Object" .= object [ Text.pack n .= v ] ]+tagModel (Tag n) v = object [ "Object" .= object [ fromString n .= v ] ] p :: Proxy JsonModel p = Proxy
+ test/Test_JSON_SOP.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE DeriveGeneric #-}++-- | Minimal test suite+module Main (main) where++import Data.Aeson++import qualified GHC.Generics as GHC+import qualified Generics.SOP as SOP++import Test.Tasty+import Test.Tasty.QuickCheck++import Generics.SOP.JSON++{-------------------------------------------------------------------------------+ Example type+-------------------------------------------------------------------------------}++data ExampleType =+ ExampleA Int+ | ExampleB [Bool] Char+ | ExampleC String ExampleType+ deriving (Show, Eq, GHC.Generic)++instance SOP.Generic ExampleType+instance SOP.HasDatatypeInfo ExampleType++instance ToJSON ExampleType where+ toJSON = gtoJSON defaultJsonOptions++instance FromJSON ExampleType where+ parseJSON = gparseJSON defaultJsonOptions++instance Arbitrary ExampleType where+ arbitrary = sized go+ where+ go :: Int -> Gen ExampleType+ go 0 = oneof [genA, genB]+ go n = oneof [genA, genB, genC (n - 1)]++ genA, genB :: Gen ExampleType+ genA = ExampleA <$> arbitrary+ genB = ExampleB <$> arbitrary <*> arbitrary++ genC :: Int -> Gen ExampleType+ genC n = ExampleC <$> arbitrary <*> go n++ shrink (ExampleA x) = concat [+ ExampleA <$> shrink x+ ]+ shrink (ExampleB x y) = concat [+ ExampleB <$> shrink x <*> pure y+ , ExampleB <$> pure x <*> shrink y+ , pure $ ExampleA 0+ ]+ shrink (ExampleC x y) = concat [+ ExampleC <$> shrink x <*> pure y+ , ExampleC <$> pure x <*> shrink y+ , pure $ ExampleA 0+ , pure $ ExampleB [] '\NUL'+ ]++{-------------------------------------------------------------------------------+ Tests proper+-------------------------------------------------------------------------------}++main :: IO ()+main = defaultMain $ testGroup "Test_JSON_SOP" [+ testProperty "roundtrip" test_roundtrip+ ]++test_roundtrip :: ExampleType -> Property+test_roundtrip ex = decode (encode ex) === Just ex