module Text.JSON.FromJSValue (
FromJSValue(..)
, jsValueField
, fromJSValueField
, fromJSValueFieldBase64
, fromJSValueFieldCustom
, fromJSValueCustomMany
, fromJSValueCustomList
, 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 Control.Monad.Identity
import Data.Maybe
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
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 $ round 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
instance (FromJSValue a, FromJSValue b) => FromJSValue (a,b) where
fromJSValue (JSArray [a,b]) = do a' <- fromJSValue a
b' <- fromJSValue b
return (a',b')
fromJSValue _ = Nothing
askJSValue :: (JSValueContainer c , MonadReader c m) => m JSValue
askJSValue = liftM getJSValue ask
jsValueField :: (JSValueContainer c , MonadReader c m, FromJSValue a) => String -> m (Maybe (Maybe a))
jsValueField s = askJSValue >>= fromObject
where
fromObject (JSObject object) = case lookup s (fromJSObject object) of Nothing -> return (Just Nothing)
Just a -> return (Just `fmap` fromJSValue a)
fromObject _ = return Nothing
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
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
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
fromJSValueCustomMany :: (JSValueContainer c , MonadReader c m) => m (Maybe a) -> m (Maybe [a])
fromJSValueCustomMany digger = fromJSValueCustomList (repeat digger)
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 []
withJSValue :: (Monad m) => JSValue -> ReaderT JSValue m a -> m a
withJSValue j a = runReaderT a j