json-sop 0.1.0.4 → 0.2.0.0
raw patch · 3 files changed
+72/−31 lines, 3 filesdep ~aesondep ~generics-sopdep ~lens-sop
Dependency ranges changed: aeson, generics-sop, lens-sop, vector
Files
- json-sop.cabal +9/−7
- src/Generics/SOP/JSON.hs +37/−16
- src/Generics/SOP/JSON/Model.hs +26/−8
json-sop.cabal view
@@ -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
src/Generics/SOP/JSON.hs view
@@ -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
src/Generics/SOP/JSON/Model.hs view
@@ -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