diff --git a/json-sop.cabal b/json-sop.cabal --- a/json-sop.cabal +++ b/json-sop.cabal @@ -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 diff --git a/src/Generics/SOP/JSON.hs b/src/Generics/SOP/JSON.hs --- a/src/Generics/SOP/JSON.hs +++ b/src/Generics/SOP/JSON.hs @@ -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) diff --git a/src/Generics/SOP/JSON/Model.hs b/src/Generics/SOP/JSON/Model.hs --- a/src/Generics/SOP/JSON/Model.hs +++ b/src/Generics/SOP/JSON/Model.hs @@ -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 diff --git a/test/Test_JSON_SOP.hs b/test/Test_JSON_SOP.hs new file mode 100644 --- /dev/null +++ b/test/Test_JSON_SOP.hs @@ -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