fields-json 0.2.2.4 → 0.4.0.0

raw patch · 7 files changed

+189/−156 lines, 7 filesdep ~basenew-uploaderPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• README.md +7/−0
• fields-json.cabal +27/−25
• src/Text/JSON/FromJSValue.hs +68/−65
• src/Text/JSON/Gen.hs +39/−28
• src/Text/JSON/JSValueContainer.hs +0/−34
• src/Text/JSON/ToJSValue.hs +42/−4

@@ -0,0 +1,6 @@+# fields-json-0.4.0.0 (2019-10-31)+* Drop support for GHC < 8.0+* Don't use IncoherentInstances++# fields-json-0.3.0.1 (2018-11-20)+* Don't enable OverlappingInstances by default.

@@ -0,0 +1,7 @@+# fields-json [![Hackage version](https://img.shields.io/hackage/v/fields-json.svg?label=Hackage)](https://hackage.haskell.org/package/fields-json) [![Build Status](https://secure.travis-ci.org/scrive/fields-json.svg?branch=master)](http://travis-ci.org/scrive/fields-json)++Abusing monadic syntax for generation of JSON objects.++Generation of big, complex JSON objects with Text.JSON is painful and+autoderivation is not always posible. Check documentation of+Text.JSON.Gen for more info.

@@ -1,45 +1,47 @@ Name:                fields-json-Version:             0.2.2.4+Version:             0.4.0.0 Synopsis:   Abusing monadic syntax JSON objects generation.  Description:   Generation of big, complex JSON objects with 'Text.JSON' is painful.-  And autoderivation is not always posible.+  And autoderivation is not always possible.   Check documentation of 'Text.JSON.Gen' for more info. +Homepage:            https://github.com/scrive/fields-json License:             BSD3 License-file:        LICENSE-Author:              Scrive-Maintainer:          mariusz@scrive.com+Author:              Scrive AB+Maintainer:          Mariusz Rak <mariusz@scrive.com>+Copyright:           Scrive AB Stability:           Development Category:            Web Build-type:          Simple-Cabal-version:       >=1.6+Cabal-version:       >=1.10+tested-with:         GHC == 8.0.2 || == 8.2.2 || == 8.4.4 || == 8.6.5+Extra-Source-Files:  README.md CHANGELOG.md +source-repository head+    type: git+    location: git://github.com/scrive/fields-json.git  library-  exposed-modules:-     Text.JSON.Gen-     Text.JSON.ToJSValue-     Text.JSON.FromJSValue-     Text.JSON.JSValueContainer+  exposed-modules: Text.JSON.Gen+                   Text.JSON.ToJSValue+                   Text.JSON.FromJSValue    hs-source-dirs: src+   GHC-Options: -Wall-  build-depends: base >= 4 && < 5-  build-depends: json >= 0.4.4-  build-depends: containers-  build-depends: base64-bytestring >= 0.1.0.2-  build-depends: utf8-string  >= 0.3.6-  build-depends: mtl-  extensions:    OverlappingInstances,-                 FlexibleInstances,-                 UndecidableInstances,-                 MultiParamTypeClasses,-                 GeneralizedNewtypeDeriving,-                 IncoherentInstances -source-repository head-    type: git-    location: git://github.com/scrive/fields-json.git+  build-depends: base >= 4.9 && < 5+               , base64-bytestring >= 0.1.0.2+               , containers+               , json >= 0.4.4+               , mtl+               , utf8-string >= 0.3.6++  default-language: Haskell2010+  default-extensions: FlexibleContexts+                      FlexibleInstances+                      GeneralizedNewtypeDeriving

@@ -31,16 +31,15 @@ ) where -import Text.JSON-import Text.JSON.JSValueContainer import Control.Monad-import Control.Monad.Reader-import qualified Data.ByteString.UTF8 as BS-import qualified Data.ByteString.Base64 as BASE64-import Control.Applicative import Control.Monad.Identity+import Control.Monad.Reader import Data.Int import Data.List+import Data.Word+import Text.JSON+import qualified Data.ByteString.Base64 as BASE64+import qualified Data.ByteString.UTF8 as BS  -- | Structures that can be 'parsed' from JSON. Instances must declare -- either 'fromJSValue' (parse directly from 'JSValue') or@@ -52,8 +51,8 @@ -- > -- > instance FromJSValue D where -- >   fromJSValue = do--- >     s <- fromJSValue "string_key"--- >     i <- fromJSValue "int_key"+-- >     s <- fromJSValueField "string_key"+-- >     i <- fromJSValueField "int_key" -- >     return (D <$> s <*> i) -- -- Note that we make use of 'MonadReader' instance for "(->)" and of@@ -63,9 +62,9 @@ -- generalized to work in any 'Control.Monad.Reader.MonadReader' 'Text.JSON.JSValue'. class FromJSValue a where     fromJSValue :: JSValue -> Maybe a-    fromJSValue j = runIdentity $ withJSValue j $ liftM fromJSValueM askJSValue-    fromJSValueM :: (JSValueContainer c, MonadReader c m) => m (Maybe a)-    fromJSValueM = liftM fromJSValue askJSValue+    fromJSValue j = runIdentity $ withJSValue j $ liftM fromJSValueM ask+    fromJSValueM :: (MonadReader JSValue m) => m (Maybe a)+    fromJSValueM = liftM fromJSValue ask   -- | Structures that can be 'parsed' from JSON, fields absent in the@@ -75,16 +74,16 @@ -- structure element to default value. class FromJSValueWithUpdate a where     fromJSValueWithUpdate :: Maybe a -> JSValue -> Maybe a-    fromJSValueWithUpdate ma j = runIdentity $ withJSValue j $ liftM (fromJSValueWithUpdateM ma) askJSValue-    fromJSValueWithUpdateM :: (JSValueContainer c, MonadReader c m) =>  Maybe a  -> m (Maybe a)-    fromJSValueWithUpdateM ma = liftM (fromJSValueWithUpdate ma) askJSValue+    fromJSValueWithUpdate ma j = runIdentity $ withJSValue j $ liftM (fromJSValueWithUpdateM ma) ask+    fromJSValueWithUpdateM :: (MonadReader JSValue m) =>  Maybe a  -> m (Maybe a)+    fromJSValueWithUpdateM ma = liftM (fromJSValueWithUpdate ma) ask  -- | Structures that can be matched with JSValue class MatchWithJSValue a where     matchesWithJSValue :: a -> JSValue -> Bool-    matchesWithJSValue a j = runIdentity $ withJSValue j $ liftM (matchesWithJSValueM a) askJSValue-    matchesWithJSValueM :: (JSValueContainer c, MonadReader c m) =>  a  -> m Bool-    matchesWithJSValueM a = liftM (matchesWithJSValue a) askJSValue+    matchesWithJSValue a j = runIdentity $ withJSValue j $ liftM (matchesWithJSValueM a) ask+    matchesWithJSValueM :: (MonadReader JSValue m) =>  a  -> m Bool+    matchesWithJSValueM a = liftM (matchesWithJSValue a) ask   -- ---------------------------------------------------------------------------@@ -94,7 +93,7 @@ instance FromJSValue JSValue where     fromJSValue = Just -instance FromJSValue String where+instance {-# OVERLAPPING #-} FromJSValue String where     fromJSValue (JSString string) = Just $ fromJSString string     fromJSValue _ = Nothing @@ -106,17 +105,29 @@     fromJSValue _ = Nothing  instance FromJSValue Int where-    fromJSValue j = liftM fromIntegral (fromJSValue j :: Maybe Integer)+    fromJSValue j = fromInteger <$> fromJSValue j  instance FromJSValue Int16 where-    fromJSValue j = fromIntegral <$> (fromJSValue j :: Maybe Integer)+    fromJSValue j = fromInteger <$> fromJSValue j  instance FromJSValue Int32 where-    fromJSValue j = fromIntegral <$> (fromJSValue j :: Maybe Integer)+    fromJSValue j = fromInteger <$> fromJSValue j  instance FromJSValue Int64 where-    fromJSValue j = fromIntegral <$> (fromJSValue j :: Maybe Integer)+    fromJSValue j = fromInteger <$> fromJSValue j +instance FromJSValue Word where+    fromJSValue j = fromInteger <$> fromJSValue j++instance FromJSValue Word16 where+    fromJSValue j = fromInteger <$> fromJSValue j++instance FromJSValue Word32 where+    fromJSValue j = fromInteger <$> fromJSValue j++instance FromJSValue Word64 where+    fromJSValue j = fromInteger <$> fromJSValue j+ instance FromJSValue Bool where     fromJSValue (JSBool v) = Just $ v     fromJSValue _ = Nothing@@ -129,11 +140,10 @@     fromJSValue (JSRational _ r) = Just $ fromRational r     fromJSValue _ = Nothing -instance (FromJSValue a) => FromJSValue [a] where+instance FromJSValue a => FromJSValue [a] where     fromJSValue (JSArray list) = mapM fromJSValue list     fromJSValue _ = Nothing - -- | Parsing any Maybe always returns Just instance (FromJSValue a) => FromJSValue (Maybe a) where     fromJSValue = Just . fromJSValue@@ -187,16 +197,12 @@  -- ---------------------------------------------------------------- --- | Getting JSON part of envirement-askJSValue :: (JSValueContainer c, MonadReader c m) => m JSValue-askJSValue = liftM getJSValue ask - -- | Reading the value that is on some field. Returns 'Nothing' if -- JSON is not an object or field is present but cannot be parsed, -- 'Just Nothing' if absent, and 'Just (Just a)' otherwise-jsValueField ::  (JSValueContainer c, MonadReader c m, FromJSValue a) => String -> m (Maybe (Maybe a))-jsValueField s = askJSValue >>= fromObject+jsValueField ::  (MonadReader JSValue m, FromJSValue a) => String -> m (Maybe (Maybe a))+jsValueField s = ask >>= fromObject     where       fromObject (JSObject object) =         case lookup s (fromJSObject object) of@@ -207,40 +213,37 @@ -- | Reading the value that is on a field. Semantics are a bit -- involved, example GHCi session should clarify: -------- @--- Prelude> :set -XNoMonomorphismRestriction--- Prelude> let x = withJSValue (JSObject (toJSObject [("key",JSString $ toJSString "value")]))--- Prelude> x (fromJSValueField "key") :: IO (Maybe Int)--- Nothing--- Prelude> x (fromJSValueField "key") :: IO (Maybe (Maybe Int))--- Just Nothing--- Prelude> x (fromJSValueField "key") :: IO (Maybe (Maybe (Maybe Int)))--- Just (Just Nothing)--- Prelude> x (fromJSValueField "key") :: IO (Maybe String)--- Just "value"--- Prelude> x (fromJSValueField "key") :: IO (Maybe (Maybe String))--- Just (Just "value")--- Prelude> x (fromJSValueField "key") :: IO (Maybe (Maybe (Maybe String)))--- Just (Just (Just "value"))--- Prelude> let x = withJSValue (JSArray [])--- Prelude> x (fromJSValueField "key") :: IO (Maybe String)--- Nothing--- Prelude> x (fromJSValueField "key") :: IO (Maybe (Maybe String))--- Nothing--- Prelude> x (fromJSValueField "key") :: IO (Maybe (Maybe (Maybe String)))--- Nothing--- @+-- > Prelude> :set -XNoMonomorphismRestriction+-- > Prelude> let x = withJSValue (JSObject (toJSObject [("key",JSString $ toJSString "value")]))+-- > Prelude> x (fromJSValueField "key") :: IO (Maybe Int)+-- > Nothing+-- > Prelude> x (fromJSValueField "key") :: IO (Maybe (Maybe Int))+-- > Just Nothing+-- > Prelude> x (fromJSValueField "key") :: IO (Maybe (Maybe (Maybe Int)))+-- > Just (Just Nothing)+-- > Prelude> x (fromJSValueField "key") :: IO (Maybe String)+-- > Just "value"+-- > Prelude> x (fromJSValueField "key") :: IO (Maybe (Maybe String))+-- > Just (Just "value")+-- > Prelude> x (fromJSValueField "key") :: IO (Maybe (Maybe (Maybe String)))+-- > Just (Just (Just "value"))+-- > Prelude> let x = withJSValue (JSArray [])+-- > Prelude> x (fromJSValueField "key") :: IO (Maybe String)+-- > Nothing+-- > Prelude> x (fromJSValueField "key") :: IO (Maybe (Maybe String))+-- > Nothing+-- > Prelude> x (fromJSValueField "key") :: IO (Maybe (Maybe (Maybe String)))+-- > Nothing ---fromJSValueField :: (JSValueContainer c, MonadReader c m, FromJSValue a) => String -> m (Maybe a)-fromJSValueField s = liftM fromObject askJSValue+fromJSValueField :: (MonadReader JSValue m, FromJSValue a) => String -> m (Maybe a)+fromJSValueField s = liftM fromObject ask     where       fromObject (JSObject object) = join (fmap fromJSValue (lookup s $ fromJSObject object))       fromObject _ = Nothing  -- | Version of 'fromJSValueField' for Base64 encoded data to avoid -- memory leak.-fromJSValueFieldBase64 :: (JSValueContainer c, MonadReader c m) => String -> m (Maybe BS.ByteString)+fromJSValueFieldBase64 :: (MonadReader JSValue m) => String -> m (Maybe BS.ByteString) fromJSValueFieldBase64 s =  liftM dc (fromJSValueField s)     where dc s' = case fmap BASE64.decode s' of                     Just (Right r) -> Just r@@ -248,21 +251,21 @@  -- | Generalization of 'fromJSValueField'. Does not use 'FromJSValue' -- instances.-fromJSValueFieldCustom :: (JSValueContainer c, MonadReader c m) => String -> m (Maybe a) -> m (Maybe a)+fromJSValueFieldCustom :: (MonadReader JSValue m) => String -> m (Maybe a) -> m (Maybe a) fromJSValueFieldCustom s digger = do     mobj <- fromJSValueField s     case mobj of-      Just obj -> local (setJSValue obj) (digger)+      Just obj -> local (const obj) (digger)       Nothing -> return Nothing  -- | Runs parser on each element of underlaying json. Returns Just iff -- JSON is array.-fromJSValueCustomMany :: (JSValueContainer c, MonadReader c m) => m (Maybe a) -> m (Maybe [a])+fromJSValueCustomMany :: (MonadReader JSValue m) => m (Maybe a) -> m (Maybe [a]) fromJSValueCustomMany digger = fromJSValueCustomList (repeat digger)  -- | Generalization of 'fromJSValueCustomMany', where each element of -- array can have different parser.-fromJSValueCustomList :: (JSValueContainer c, MonadReader c m) => [m (Maybe a)] -> m (Maybe [a])+fromJSValueCustomList :: (MonadReader JSValue m) => [m (Maybe a)] -> m (Maybe [a]) fromJSValueCustomList diggers = do     mlist <- fromJSValueM     case mlist of@@ -270,7 +273,7 @@          Just list -> runDiggers list diggers     where          runDiggers (j:js) (d:ds) = do-             mres <- local (setJSValue j) d+             mres <- local (const j) d              case mres of                  Just res -> do                      mress <- runDiggers js ds@@ -286,7 +289,7 @@ -- -- Note: This method has quadratic complexity. It is better to write -- less general matching algorithms that use Maps.-fromJSValueManyWithUpdate :: (JSValueContainer c, MonadReader c m, FromJSValueWithUpdate a, MatchWithJSValue a) => [a] -> m (Maybe [a])+fromJSValueManyWithUpdate :: (MonadReader JSValue m, FromJSValueWithUpdate a, MatchWithJSValue a) => [a] -> m (Maybe [a]) fromJSValueManyWithUpdate values = do     mjs <- fromJSValueM     case mjs of@@ -294,7 +297,7 @@          Just js -> runFromJSValueAndUpdate js     where          runFromJSValueAndUpdate (j:js) =  do-             mres <- local (setJSValue j) (fromJSValueWithUpdateM (find (\v -> matchesWithJSValue v j) values))+             mres <- local (const j) (fromJSValueWithUpdateM (find (\v -> matchesWithJSValue v j) values))              case mres of                  Just res -> do                      mress <- runFromJSValueAndUpdate js@@ -314,7 +317,7 @@ -- >             a <- fromJSValueField "a" -- >             b <- fromJSValueField "b" -- >             c <- fromJSValueField "c"--- >             return ((,,) <$> a <*> b <*> <*> c)+-- >             return ((,,) <$> a <*> b <*> c) -- -- or using the monad transformer: --

@@ -53,72 +53,83 @@   , objects   ) where -import Control.Applicative import Control.Monad import Control.Monad.Identity-import Control.Monad.Trans import Control.Monad.State.Strict-import Control.Monad.Reader--import Data.Sequence as S+import Data.Foldable import Text.JSON+import qualified Data.Sequence as S+ import Text.JSON.ToJSValue-import Text.JSON.JSValueContainer  -- --------------------------------------------------------------  -- | Basic types type JSONGen = JSONGenT Identity -newtype JSONGenT m a = JSONGenT (StateT (Seq (String, JSValue)) m a)+-- | A monad that keeps currently constructed JSON.+newtype JSONGenT m a = JSONGenT (StateT (S.Seq (String, JSValue)) m a)   deriving (Applicative, Functor, Monad, MonadTrans)  --- | This instance gives us the ability to use FromJSValue function while generating.-instance (Monad m) => MonadReader (Seq (String, JSValue)) (JSONGenT m) where-    ask = JSONGenT (get)-    local f (JSONGenT m) = JSONGenT $ do-                             s <- get-                             put (f s)-                             res <- m-                             put s-                             return res-- instance MonadIO m => MonadIO (JSONGenT m) where   liftIO = JSONGenT . liftIO  -- -------------------------------------------------------------- --- | Simple runner+-- | Runner. Example:+--+-- > let js = runJSONGen $ do+-- >            value "abc" "def" runJSONGen :: JSONGen () -> JSValue runJSONGen = runIdentity . runJSONGenT  +-- | Runner as monad transformer. Example:+--+-- > js <- runJSONGenT $ do+-- >            d <- lift $ getFromOuterMonad+-- >            value "abc" d runJSONGenT :: Monad m => JSONGenT m () -> m JSValue-runJSONGenT (JSONGenT f) = getJSValue `liftM` execStateT f S.empty+runJSONGenT (JSONGenT f) = (JSObject . toJSObject . toList) `liftM` execStateT f S.empty  -- -------------------------------------------------------------- --- | Set pure value under given name in final JSON object+-- | Set pure value under given name in final JSON object. Example:+--+-- > value "key" "value" value :: (Monad m, ToJSValue a) => String -> a -> JSONGenT m ()-value name val = JSONGenT $ modify (|> (name, toJSValue val))+value name val = JSONGenT $ modify (S.|> (name, toJSValue val)) --- | Monadic verion of 'value'+-- | Monadic verion of 'value' using monad transformer. Example:+--+-- > js <- runJSONGenT $ do+-- >          valueM "abc" (getLine) valueM :: (Monad m, ToJSValue a) => String -> m a -> JSONGenT m () valueM name mval = lift mval >>= value name  --- | Embed other JSON object as field in resulting JSON object.+-- | Embed other JSON object as field in a resulting JSON object. Example:+--+-- > let js = runJSONGen $ do+-- >            object "nested" $ do+-- >                value "abc" "def" object :: Monad m => String -> JSONGenT m () -> JSONGenT m () object name json = JSONGenT $ do   val <- lift $ runJSONGenT json-  modify (|> (name, toJSValue val))+  modify (S.|> (name, toJSValue val))  --- | Version for lists of objects.  +-- | Version for lists of objects. Example:+--+-- > let js = runJSONGen $ do+-- >            objects "nested" [ do+-- >                                 value "abc" "def"+-- >                                 value "x" "y",+-- >                               do+-- >                                 value "qwe" "rty"+-- >                             ] objects :: Monad m => String -> [JSONGenT m ()] -> JSONGenT m () objects name jsons = JSONGenT $ do   val <- mapM (lift . runJSONGenT) jsons-  modify (|> (name, toJSValue val))-+  modify (S.|> (name, toJSValue val))

@@ -1,34 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Text.JSON.ToJSON--- Copyright   :  (c) Scrive 2011--- License     :  BSD-style (see the LICENSE file in the distribution)------ Maintainer  :  mariusz@scrive.com--- Stability   :  development--- Portability :  portable------ Data structures that hold JSValue inside.--- Value can be extracted or replaced, but is always inside.------module Text.JSON.JSValueContainer (JSValueContainer(..))where--import Text.JSON-import Data.Sequence as S-import Data.Foldable--class JSValueContainer a where-    getJSValue :: a -> JSValue-    setJSValue :: JSValue -> a -> a--instance JSValueContainer JSValue where-    getJSValue = id-    setJSValue= const---- Instance used by generator. Note that putting is not ~ workeround.-instance JSValueContainer (Seq (String, JSValue)) where-    getJSValue s = JSObject $ toJSObject $ toList s-    setJSValue (JSObject o) _ = S.fromList $ fromJSObject o-    setJSValue _ s = s -- We could throw error, but why should we bothered

@@ -14,8 +14,10 @@  module Text.JSON.ToJSValue (ToJSValue(..))where -import Text.JSON+import Data.Int import Data.Map as M+import Data.Word+import Text.JSON  class ToJSValue a where   toJSValue :: a -> JSValue@@ -26,12 +28,48 @@ instance ToJSValue Bool where   toJSValue = JSBool -instance ToJSValue String where+instance {-# OVERLAPPING #-} ToJSValue String where   toJSValue = JSString . toJSString -instance Real a => ToJSValue a where+instance ToJSValue Integer where+  toJSValue = JSRational False . toRational++instance ToJSValue Int where+  toJSValue = JSRational False . toRational++instance ToJSValue Int8 where+  toJSValue = JSRational False . toRational++instance ToJSValue Int16 where+  toJSValue = JSRational False . toRational++instance ToJSValue Int32 where+  toJSValue = JSRational False . toRational++instance ToJSValue Int64 where+  toJSValue = JSRational False . toRational++instance ToJSValue Word where+  toJSValue = JSRational False . toRational++instance ToJSValue Word8 where+  toJSValue = JSRational False . toRational++instance ToJSValue Word16 where+  toJSValue = JSRational False . toRational++instance ToJSValue Word32 where+  toJSValue = JSRational False . toRational++instance ToJSValue Word64 where+  toJSValue = JSRational False . toRational++instance ToJSValue Double where+  toJSValue = JSRational False . toRational++instance ToJSValue Float where   toJSValue = JSRational True . toRational-  + instance ToJSValue a => ToJSValue [a] where   toJSValue = JSArray . fmap toJSValue