fields-json 0.1 → 0.2

raw patch · 7 files changed

+350/−125 lines, 7 filesdep +base64-bytestringdep +utf8-stringPVP ok

version bump matches the API change (PVP)

Dependencies added: base64-bytestring, utf8-string

API changes (from Hackage documentation)

Files

• fields-json.cabal +15/−7
• src/Text/JSON/Fields.hs +0/−76
• src/Text/JSON/FromJSValue.hs +137/−0
• src/Text/JSON/Gen.hs +121/−0
• src/Text/JSON/JSValueContainer.hs +35/−0
• src/Text/JSON/ToJSON.hs +0/−42
• src/Text/JSON/ToJSValue.hs +42/−0

@@ -1,10 +1,10 @@ Name:                fields-json-Version:             0.1+Version:             0.2 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.-  Check haddock of Fields module for more info.+  Check documentation of Text.JSON.Gen for more info.  License:             BSD3 License-file:        LICENSE@@ -13,22 +13,30 @@ Stability:           Development Category:            Web Build-type:          Simple-Cabal-version:       >=1.2+Cabal-version:       >=1.4   library   exposed-modules: -     Text.JSON.Fields-     Text.JSON.ToJSON+     Text.JSON.Gen+     Text.JSON.ToJSValue+     Text.JSON.FromJSValue+     Text.JSON.JSValueContainer    hs-source-dirs: src -+  GHC-Options: -Werror   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:    FlexibleInstances,                  TypeSynonymInstances,                  UndecidableInstances,                  OverlappingInstances,-                 IncoherentInstances+                 IncoherentInstances,+                 DeriveFunctor,+                 GeneralizedNewtypeDeriving,+                 MultiParamTypeClasses,+                 StandaloneDeriving

@@ -1,76 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Text.JSON.Fields--- Copyright   :  (c) Scrive 2011--- License     :  BSD-style (see the LICENSE file in the distribution)------ Maintainer  :  mariusz@scrive.com--- Stability   :  development--- Portability :  portable------ Abusing monadic do notation library for generating JSON object. --- Hard-binded to json package from hackage.--- Main ideas------ * Overloaded function 'field', that may set values of fields of different types - 'Bool', 'Int', 'String', lists  etc.------ * Internal IO - value of the field can be IO a, is we know how to put a into JSON. That means that there is no need to do prebinding ------ * Compositionality - value of field can also be fields. Easy to do embeded  objects------ * Monadic notation - it really looks nicer then composition with '.' or some magic combinator------ >--- > json $ do--- >     field "a" "a"--- >     field "b" [1,2,3]--- >     field "c" $ do--- >         field "x" True--- >         field "y" False--- >--- --- Will generate json object ---  {a : "a", b: [1,2,3], c: {x: true, y : false}} -----module Text.JSON.Fields (json, JSField(..))where--import Text.JSON-import Text.JSON.ToJSON-import Data.Map as Map-import Control.Monad.State.Strict---type JSFields = State ([(String, IO JSValue)]) ()---{- | Function for changing 'JSFields' into real JSON object -}--json :: JSFields -> IO JSValue-json fields = fmap (JSObject . toJSObject) $ sequence $ fmap pack $ execState fields []--{- | The 'JSField' class instances are object that in some sence can be interpreted as value of JSON object fields. -     To derive new instances use existing instances since internal structure 'JSFields' is hidden.--}--class JSField a where-  field :: String -> a -> JSFields-  -instance (ToJSON a) => JSField a where  -  field n v = modify $ \s -> (n, return $ toJSON v) : s--instance (ToJSON a) => JSField (IO a) where  -  field n v = modify $ \s -> (n, fmap toJSON v) : s--instance JSField (JSFields) where  -  field n v = modify $ \s -> (n, fmap toJSON val) : s-   where-      val = fmap Map.fromList (sequence $ fmap pack $ execState v [])-  -instance JSField [JSFields] where  -  field n fs = modify $ \s -> (n, fmap toJSON $ mapM vals fs) : s-      where-        vals f = fmap Map.fromList  (sequence $ fmap pack $ execState f [])--pack :: (Functor f) => (a, f b) -> f (a, b)-pack (name, comp)=  fmap (\res -> (name,res)) comp

@@ -0,0 +1,137 @@+-----------------------------------------------------------------------------+-- |+-- 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+--+-- Interface for extracting data from JSValue.+--+++module Text.JSON.FromJSValue (+                               -- * Basic Parsing+                                 FromJSValue(..)+                               -- * Data Extraction+                               , fromJSValueField+                               , fromJSValueFieldBase64+                               , fromJSValueFieldCustom+                               , fromJSValueCustomMany+                               , fromJSValueCustomList+                               -- * Running+                               , withJSValue  ) 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 Data.Ratio+import Control.Monad.Identity+import Data.Maybe+import Text.JSON.String+++-- | Structures that can be 'parsed' from JSON. Instances must declare either 'fromJSValue' (parse directly from 'JSValue') or 'fromJSValueM' (uses 'MonadReader')+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++-- ---------------------------------------------------------------------------+-- Instances for basic datatypes+--++instance FromJSValue JSValue where+    fromJSValue = Just++instance FromJSValue String where+    fromJSValue (JSString string) = Just $ fromJSString string+    fromJSValue _ = Nothing++instance FromJSValue BS.ByteString where+    fromJSValue s = fmap BS.fromString (fromJSValue s)++instance FromJSValue Integer where+    fromJSValue (JSRational _ r) = Just $ numerator r+    fromJSValue _ = Nothing++instance FromJSValue Int where+    fromJSValue j = liftM fromIntegral (fromJSValue j :: Maybe Integer)++instance FromJSValue Bool where+    fromJSValue (JSBool v) = Just $ v+    fromJSValue _ = Nothing++instance (FromJSValue a) => FromJSValue [a] where+    fromJSValue (JSArray list) = let plist = map fromJSValue list+                                 in if (all isJust plist)+                                     then Just $ map fromJust plist+                                     else Nothing++    fromJSValue _ = Nothing++instance (FromJSValue a) => FromJSValue (Maybe a) where+    fromJSValue = join . fromJSValue+++-- ----------------------------------------------------------------++-- | 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. With field if current JSON is not object+fromJSValueField ::  (JSValueContainer c , MonadReader c m, FromJSValue a) => String -> m (Maybe a)+fromJSValueField s = liftM fromObject askJSValue+    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 s =  liftM dc (fromJSValueField s)+    where dc s' = case (fmap BASE64.decode s') of+                            Just (Right r) -> Just r+                            _ -> Nothing++-- | Generalization of 'fromJSValueField'. Does not use 'FromJSValue' instances+fromJSValueFieldCustom :: (JSValueContainer c , MonadReader c m) =>  String -> m (Maybe a) -> m (Maybe a)+fromJSValueFieldCustom s digger = do+    mobj <- fromJSValueField s+    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)++-- | 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 diggers = do+    mlist <- fromJSValueM+    case mlist of+         Nothing -> return Nothing+         Just list ->  runDiggers list diggers+    where+         runDiggers (j:js) (d:ds) = do+             mres <- local (setJSValue j) d+             case mres of+                 Just res -> do+                     mress <- runDiggers js ds+                     case mress of+                         Just ress -> return $ Just (res:ress)+                         _ -> return Nothing+                 _ -> return Nothing+         runDiggers _ _ = return $ Just []+         +-- ----------------------------------------------------------------+-- | Simple runner+withJSValue :: (Monad m) => JSValue -> ReaderT JSValue m a -> m a+withJSValue j a = runReaderT a j

@@ -0,0 +1,121 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.JSON.Gen+-- Copyright   :  (c) Scrive 2011+-- License     :  BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  :  andrzej@scrive.com+-- Stability   :  development+-- Portability :  portable+--+-- Abusing monadic 'do' notation library for generating JSON object. +-- Hard-binded to json package from hackage.+-- Main ideas+--+-- * Overloaded function 'value' to set values in underlying JSON - 'Bool', 'Int', 'String', lists  etc.+--+-- * JSON generation may not be pure  with 'valueM'. You can perform some IO while generating JSON. This is usefull skip useless inner binding.+--+-- * Compositionality - use 'object' to easy create JSON objects+--+-- * Monadic notation - it really looks nicer then composition with '.' or some magic combinator+--+-- >+-- > runJSONGen $ do+-- >     value "a" "a"+-- >     value "b" [1,2,3]+-- >     object "c" $ do+-- >         value "x" True+-- >         value "y" False+-- >+-- +-- Will generate json object +--  {a : "a", b: [1,2,3], c: {x: true, y : false}} +++ module Text.JSON.Gen (+    module Text.JSON.ToJSValue+    -- * Basic types+  , JSONGen+  , JSONGenT+    -- * Runners+  , runJSONGen+  , runJSONGenT+    -- * Creating JSON's+  , value+  , valueM+  , object+  , 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 Control.Monad.Reader.Class++import Data.Foldable+import Data.Sequence as S+import Text.JSON+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)+  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+runJSONGen :: JSONGen () -> JSValue+runJSONGen = runIdentity . runJSONGenT+++runJSONGenT :: Monad m => JSONGenT m () -> m JSValue+runJSONGenT (JSONGenT f) = getJSValue `liftM` execStateT f S.empty++-- --------------------------------------------------------------++-- | Set pure value under given name in final JSON object+value :: (Monad m, ToJSValue a) => String -> a -> JSONGenT m ()+value name val = JSONGenT $ modify (|> (name, toJSValue val))++-- | Monadic verion of 'value'+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.+object :: Monad m => String -> JSONGenT m () -> JSONGenT m ()+object name json = JSONGenT $ do+  val <- lift $ runJSONGenT json+  modify (|> (name, toJSValue val))+++-- | Version for lists of objects.  +objects :: Monad m => String -> [JSONGenT m ()] -> JSONGenT m ()+objects name jsons = JSONGenT $ do+  val <- mapM (lift . runJSONGenT) jsons+  modify (|> (name, toJSValue val))+

@@ -0,0 +1,35 @@+-----------------------------------------------------------------------------+-- |+-- 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+import Text.JSON++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

@@ -1,42 +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------ Unifing some structures to JSValue------module Text.JSON.ToJSON (ToJSON(..))where--import Text.JSON-import Data.Map--class ToJSON a where-  toJSON:: a -> JSValue--instance ToJSON JSValue where-  toJSON = id-  -instance ToJSON String where-  toJSON = JSString . toJSString --instance ToJSON Bool where-  toJSON = JSBool--instance ToJSON Int where-  toJSON = JSRational True . toRational-  -instance ToJSON Integer where-  toJSON = JSRational True . toRational-  -instance (ToJSON a) =>  ToJSON [a] where-  toJSON = JSArray . fmap toJSON -  -instance (ToJSON a) => ToJSON (Map String a) where  -  toJSON = JSObject . toJSObject . toList . (fmap toJSON) 

@@ -0,0 +1,42 @@+-----------------------------------------------------------------------------+-- |+-- 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+--+-- Unifing some structures so they can be serialized to JSValue+--+++module Text.JSON.ToJSValue (ToJSValue(..))where++import Text.JSON+import Data.Map as M++class ToJSValue a where+  toJSValue :: a -> JSValue++instance ToJSValue JSValue where+  toJSValue = id++instance ToJSValue Bool where+  toJSValue = JSBool++instance ToJSValue String where+  toJSValue = JSString . toJSString++instance Real a => ToJSValue a where+  toJSValue = JSRational True . toRational+  +instance ToJSValue a => ToJSValue [a] where+  toJSValue = JSArray . fmap toJSValue++instance ToJSValue a => ToJSValue (M.Map String a) where+  toJSValue = JSObject . toJSObject . M.toList . fmap toJSValue++instance ToJSValue a => ToJSValue (Maybe a) where+  toJSValue = maybe JSNull toJSValue