fields-json 0.2.2 → 0.2.2.2
raw patch · 2 files changed
+53/−10 lines, 2 files
Files
- fields-json.cabal +5/−5
- src/Text/JSON/FromJSValue.hs +48/−5
fields-json.cabal view
@@ -1,8 +1,8 @@ Name: fields-json-Version: 0.2.2-Synopsis: Abusing monadic syntax JSON objects generation. +Version: 0.2.2.2+Synopsis: Abusing monadic syntax JSON objects generation. -Description: +Description: 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. @@ -17,13 +17,13 @@ library- exposed-modules: + exposed-modules: Text.JSON.Gen Text.JSON.ToJSValue Text.JSON.FromJSValue Text.JSON.JSValueContainer - hs-source-dirs: src + hs-source-dirs: src GHC-Options: -Wall build-depends: base >= 4 && < 5 build-depends: json >= 0.4.4
src/Text/JSON/FromJSValue.hs view
@@ -15,6 +15,8 @@ module Text.JSON.FromJSValue ( -- * Basic Parsing FromJSValue(..)+ , FromJSValueWithUpdate(..)+ , MatchWithJSValue(..) -- * Data Extraction , jsValueField , fromJSValueField@@ -22,6 +24,7 @@ , fromJSValueFieldCustom , fromJSValueCustomMany , fromJSValueCustomList+ , fromJSValueManyWithUpdate -- * Running , withJSValue ) where import Text.JSON@@ -32,7 +35,7 @@ import qualified Data.ByteString.Base64 as BASE64 import Control.Monad.Identity import Data.Maybe-+import Data.List -- | Structures that can be 'parsed' from JSON. Instances must declare either 'fromJSValue' (parse directly from 'JSValue') or 'fromJSValueM' (uses 'MonadReader') class FromJSValue a where@@ -41,6 +44,22 @@ fromJSValueM :: (JSValueContainer c , MonadReader c m) => m (Maybe a) fromJSValueM = liftM fromJSValue askJSValue ++-- | Structures that can be 'parsed' from JSON if some structure for update is provided+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++-- | 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++ -- --------------------------------------------------------------------------- -- Instances for basic datatypes --@@ -74,9 +93,12 @@ fromJSValue _ = Nothing ++-- | Parsing any Maybe always returns Just instance (FromJSValue a) => FromJSValue (Maybe a) where- fromJSValue = join . fromJSValue+ fromJSValue = Just . fromJSValue + instance (FromJSValue a, FromJSValue b) => FromJSValue (a,b) where fromJSValue (JSArray [a,b]) = do a' <- fromJSValue a b' <- fromJSValue b@@ -100,7 +122,8 @@ Just a -> return (Just `fmap` fromJSValue a) fromObject _ = return Nothing --- | Reading the value that is on some field. With field if current JSON is not object+-- | Reading the value that is on some field. With fail if current JSON is not object.+-- | It can be ussed with 'Maybe a'. In such case Nothing will be returned iif field was not set. fromJSValueField :: (JSValueContainer c , MonadReader c m, FromJSValue a) => String -> m (Maybe a) fromJSValueField s = liftM fromObject askJSValue where@@ -121,7 +144,7 @@ case mobj of Just obj -> local (setJSValue 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 digger = fromJSValueCustomList (repeat digger)@@ -144,7 +167,27 @@ _ -> return Nothing _ -> return Nothing runDiggers _ _ = return $ Just []- +++-- | Runs parser on each element of underlaying json. Returns Just iff JSON is array.+fromJSValueManyWithUpdate :: (JSValueContainer c , MonadReader c m, FromJSValueWithUpdate a, MatchWithJSValue a) => [a] -> m (Maybe [a])+fromJSValueManyWithUpdate values = do+ mjs <- fromJSValueM+ case mjs of+ Nothing -> return Nothing+ Just js -> runFromJSValueAndUpdate js+ where+ runFromJSValueAndUpdate (j:js)= do+ mres <- local (setJSValue j) (fromJSValueWithUpdateM (find (\v -> matchesWithJSValue v j) values))+ case mres of+ Just res -> do+ mress <- runFromJSValueAndUpdate js+ case mress of+ Just ress -> return $ Just (res:ress)+ _ -> return Nothing+ _ -> return Nothing+ runFromJSValueAndUpdate [] = return $ Just []+ -- ---------------------------------------------------------------- -- | Simple runner withJSValue :: (Monad m) => JSValue -> ReaderT JSValue m a -> m a