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.1.0.4 +version: 0.2.0.0 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.6.3, GHC == 7.8.2 +tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.2 source-repository head type: git @@ -24,11 +24,11 @@ Generics.SOP.JSON.Model other-modules: Generics.SOP.Util.PartialResult build-depends: base >= 4.6 && < 5, - generics-sop >= 0.1 && < 0.2, - lens-sop >= 0.1 && < 0.2, + generics-sop >= 0.2 && < 0.3, + lens-sop >= 0.2 && < 0.3, tagged >= 0.7 && < 0.9, - aeson >= 0.7 && < 0.9, - vector >= 0.10 && < 0.11, + aeson >= 0.7 && < 0.11, + vector >= 0.10 && < 0.12, text >= 1.1 && < 1.3, unordered-containers >= 0.2 && < 0.3, time >= 1.4 && < 1.6, @@ -53,8 +53,10 @@ KindSignatures DataKinds FunctionalDependencies + CPP if impl (ghc >= 7.8) default-extensions: AutoDeriveTypeable other-extensions: OverloadedStrings - OverlappingInstances PolyKinds + if impl (ghc < 7.10) + other-extensions: OverlappingInstances 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,4 +1,7 @@ -{-# LANGUAGE PolyKinds, OverlappingInstances #-} +{-# LANGUAGE PolyKinds #-} +#if __GLASGOW_HASKELL__ < 710 +{-# LANGUAGE OverlappingInstances #-} +#endif module Generics.SOP.JSON ( -- * Configuration JsonFieldName @@ -96,12 +99,12 @@ -- Multiple argument constructor, but not a record -- -- We output the arguments as a JSON array - JsonMultiple :: SingI xs => Tag -> JsonInfo xs + JsonMultiple :: SListI xs => Tag -> JsonInfo xs -- Record constructor -- -- We output the arguments as a JSON object (even if there is only one field) - JsonRecord :: SingI xs => Tag -> NP (K String) xs -> JsonInfo xs + JsonRecord :: SListI xs => Tag -> NP (K String) xs -> JsonInfo xs jsonInfoFor :: forall xs. JsonOptions -> DatatypeName -> (ConstructorName -> Tag) -> ConstructorInfo xs -> JsonInfo xs jsonInfoFor _ _ tag (Infix n _ _) = JsonMultiple (tag n) @@ -116,7 +119,7 @@ fieldName :: FieldInfo a -> K String a fieldName (FieldInfo name) = K (jsonFieldName opts d name) -jsonInfo :: forall a. (HasDatatypeInfo a, SingI (Code a)) +jsonInfo :: forall a. (HasDatatypeInfo a, SListI (Code a)) => Proxy a -> JsonOptions -> NP JsonInfo (Code a) jsonInfo pa opts = case datatypeInfo pa of @@ -134,10 +137,10 @@ gtoJSON :: forall a. (Generic a, HasDatatypeInfo a, All2 ToJSON (Code a)) => JsonOptions -> a -> Value gtoJSON opts a = - unI . hcollapse $ hcliftA2' pt gtoJSON' (jsonInfo (Proxy :: Proxy a) opts) - (unSOP $ from a) + hcollapse $ hcliftA2 allpt gtoJSON' (jsonInfo (Proxy :: Proxy a) opts) + (unSOP $ from a) -gtoJSON' :: (All ToJSON xs, SingI xs) => JsonInfo xs -> NP I xs -> K Value xs +gtoJSON' :: All ToJSON xs => JsonInfo xs -> NP I xs -> K Value xs gtoJSON' (JsonZero n) Nil = K $ String (Text.pack n) gtoJSON' (JsonOne tag) (I a :* Nil) = @@ -176,12 +179,12 @@ => JsonOptions -> Value -> Parser a gparseJSON opts v = to `liftM` gparseJSON' v (jsonInfo (Proxy :: Proxy a) opts) -gparseJSON' :: forall (xss :: [[*]]). (All2 FromJSON xss, SingI xss) +gparseJSON' :: forall (xss :: [[*]]). All2 FromJSON xss => Value -> NP JsonInfo xss -> Parser (SOP I xss) gparseJSON' v info = runPartial failWith . msum . hcollapse - $ hcliftA2' pf (parseConstructor v) info injs + $ hcliftA2 allpf (parseConstructor v) info injs where failWith :: [String] -> Parser (SOP I xss) failWith [] = fail $ "Unknown error" @@ -191,7 +194,7 @@ injs :: NP (Injection (NP I) xss) xss injs = injections -parseConstructor :: forall (xss :: [[*]]) (xs :: [*]). (All FromJSON xs, SingI xs) +parseConstructor :: forall (xss :: [[*]]) (xs :: [*]). 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 @@ -205,7 +208,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 :: [*]). SingI xs +parseValues :: forall (xs :: [*]). SListI xs => JsonInfo xs -> Value -> Partial Parser (NP (K (Maybe String, Value)) xs) parseValues (JsonZero n) = withText ("Expected literal " ++ show n) $ \txt -> do @@ -219,7 +222,7 @@ case fromList (map (\v -> (Nothing, v)) arr) of Just values -> return values Nothing -> fail $ "Got " ++ show (length arr) ++ "values, " - ++ "expected " ++ show (lengthSing (Proxy :: Proxy xs)) + ++ "expected " ++ show (lengthSList (Proxy :: Proxy xs)) parseValues (JsonRecord tag fields) = untag tag $ withObject "Object" $ \obj -> do values <- hsequenceK =<< lineup fields obj @@ -272,8 +275,16 @@ parseWith :: UpdateFromJSON a => a -> Value -> Parser a parseWith a = liftM ($ a) . updateFromJSON -instance FromJSON a => UpdateFromJSON [a] where updateFromJSON = replaceWithJSON -instance FromJSON a => UpdateFromJSON (Maybe a) where updateFromJSON = replaceWithJSON +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 -- Primitive types we can only replace whole instance UpdateFromJSON Int where updateFromJSON = replaceWithJSON @@ -281,7 +292,11 @@ instance UpdateFromJSON Rational where updateFromJSON = replaceWithJSON instance UpdateFromJSON Bool where updateFromJSON = replaceWithJSON instance UpdateFromJSON Text where updateFromJSON = replaceWithJSON -instance UpdateFromJSON String where updateFromJSON = replaceWithJSON +instance +#if __GLASGOW_HASKELL__ >= 710 + {-# OVERLAPPING #-} +#endif + UpdateFromJSON String where updateFromJSON = replaceWithJSON {------------------------------------------------------------------------------- Generic instance for UpdateFromJSON @@ -297,7 +312,7 @@ _ :* Nil -> error "cannot update non-record type" _ -> error "inaccessible" -gupdateRecord :: forall (xs :: [*]) (a :: *). (All UpdateFromJSON xs, SingI xs) +gupdateRecord :: forall (xs :: [*]) (a :: *). 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 @@ -357,8 +372,14 @@ pt :: Proxy ToJSON pt = Proxy +allpt :: Proxy (All ToJSON) +allpt = Proxy + pf :: Proxy FromJSON pf = Proxy + +allpf :: Proxy (All FromJSON) +allpf = Proxy pu :: Proxy UpdateFromJSON pu = Proxy 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,4 +1,7 @@ -{-# LANGUAGE OverloadedStrings, OverlappingInstances #-} +{-# LANGUAGE OverloadedStrings #-} +#if __GLASGOW_HASKELL__ < 710 +{-# LANGUAGE OverlappingInstances #-} +#endif module Generics.SOP.JSON.Model ( JsonModel(..) , gjsonModel @@ -36,7 +39,11 @@ instance JsonModel Text.Lazy.Text where jsonModel = Tagged $ String "String" -instance JsonModel String where +instance +#if __GLASGOW_HASKELL__ >= 710 + {-# OVERLAPPING #-} +#endif + JsonModel String where jsonModel = Tagged $ String "String" instance JsonModel Int where @@ -51,12 +58,20 @@ instance JsonModel Bool where jsonModel = Tagged $ String "Bool" -instance JsonModel a => JsonModel [a] where +instance +#if __GLASGOW_HASKELL__ >= 710 + {-# OVERLAPPABLE #-} +#endif + JsonModel a => JsonModel [a] where jsonModel = let model :: Tagged a Value model = jsonModel in Tagged $ object [ "List" .= untag model ] -instance JsonModel a => JsonModel (Maybe a) where +instance +#if __GLASGOW_HASKELL__ >= 710 + {-# OVERLAPPABLE #-} +#endif + JsonModel a => JsonModel (Maybe a) where jsonModel = let model :: Tagged a Value model = jsonModel in Tagged $ Array $ Vector.fromList [ untag model, Null ] @@ -68,12 +83,12 @@ -- | Generic computation of the JSON model -- -- Do NOT use for recursive types, you will get an infinite model. -gjsonModel :: forall a. (HasDatatypeInfo a, All2 JsonModel (Code a), SingI (Code a)) +gjsonModel :: forall a. (HasDatatypeInfo a, All2 JsonModel (Code a)) => JsonOptions -> Tagged a Value gjsonModel opts = unproxy $ \pa -> gjsonModel' (jsonInfo pa opts) -gjsonModel' :: (All2 JsonModel xss, SingI xss) => NP JsonInfo xss -> Value -gjsonModel' = mkValue . hcollapse . hcliftA' p (K . constructorModel) +gjsonModel' :: All2 JsonModel xss => NP JsonInfo xss -> Value +gjsonModel' = mkValue . hcollapse . hcliftA allp (K . constructorModel) where -- In the case of a single-argument datatype, just return the type of -- the constructor, rather than a singleton list of types @@ -89,7 +104,7 @@ constructorModel (JsonMultiple t) = tagModel t $ object [ "Tuple" .= (tupleModel . hcollapse $ aux) ] where - aux :: (SingI xs, All JsonModel xs) => NP (K Value) xs + aux :: All JsonModel xs => NP (K Value) xs aux = hcpure p jsonModelK constructorModel (JsonRecord t fs) = tagModel t $ object [ "Object" .= (objectModel . hcollapse . hcliftA p aux $ fs) ] @@ -118,3 +133,6 @@ p :: Proxy JsonModel p = Proxy + +allp :: Proxy (All JsonModel) +allp = Proxy