module Text.JSON (
JSValue(..)
, JSON(..)
, Result(..)
, encode
, decode
, encodeStrict
, decodeStrict
, JSString
, toJSString
, fromJSString
, JSObject
, toJSObject
, fromJSObject
, resultToEither
, readJSNull, readJSBool, readJSString, readJSRational
, readJSArray, readJSObject, readJSValue
, showJSNull, showJSBool, showJSRational, showJSArray
, showJSObject, showJSValue
, makeObj, valFromObj
) where
import Text.JSON.Types
import Text.JSON.String
import Data.Char
import Data.List
import Data.Int
import Data.Word
import Data.Either
import Control.Monad(liftM,ap,MonadPlus(..))
import Control.Applicative
import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.IntSet as I
import qualified Data.Map as M
decode :: (JSON a) => String -> Result a
decode s = case runGetJSON readJSValue s of
Right a -> readJSON a
Left err -> Error err
encode :: (JSON a) => a -> String
encode = (flip showJSValue [] . showJSON)
decodeStrict :: (JSON a) => String -> Result a
decodeStrict s = case runGetJSON readJSTopType s of
Right a -> readJSON a
Left err -> Error err
encodeStrict :: (JSON a) => a -> String
encodeStrict = (flip showJSTopType [] . showJSON)
class JSON a where
readJSON :: JSValue -> Result a
showJSON :: a -> JSValue
readJSONs :: JSValue -> Result [a]
readJSONs (JSArray as) = mapM readJSON as
readJSONs _ = mkError "Unable to read list"
showJSONs :: [a] -> JSValue
showJSONs = JSArray . map showJSON
data Result a = Ok a | Error String
deriving (Eq,Show)
resultToEither :: Result a -> Either String a
resultToEither (Ok a) = Right a
resultToEither (Error s) = Left s
instance Functor Result where fmap = liftM
instance Applicative Result where
(<*>) = ap
pure = return
instance Alternative Result where
Ok a <|> _ = Ok a
Error _ <|> b = b
empty = Error "empty"
instance MonadPlus Result where
Ok a `mplus` _ = Ok a
_ `mplus` x = x
mzero = Error "Result: MonadPlus.empty"
instance Monad Result where
return x = Ok x
fail x = Error x
Ok a >>= f = f a
Error x >>= _ = Error x
mkError :: (JSON a) => String -> Result a
mkError s = Error s
instance JSON JSValue where
showJSON = id
readJSON = return
second :: (a -> b) -> (x,a) -> (x,b)
second f (a,b) = (a, f b)
instance JSON JSString where
readJSON (JSString s) = return s
readJSON _ = mkError "Unable to read JSString"
showJSON = JSString
instance (JSON a) => JSON (JSObject a) where
readJSON (JSObject o) =
let f (x,y) = do y' <- readJSON y; return (x,y')
in toJSObject `fmap` mapM f (fromJSObject o)
readJSON _ = mkError "Unable to read JSObject"
showJSON = JSObject . toJSObject . map (second showJSON) . fromJSObject
instance JSON Bool where
showJSON = JSBool
readJSON (JSBool b) = return b
readJSON _ = mkError "Unable to read Bool"
instance JSON Char where
showJSON = JSString . toJSString . (:[])
showJSONs = JSString . toJSString
readJSON (JSString s) = case fromJSString s of
[c] -> return c
_ -> mkError "Unable to read Char"
readJSON _ = mkError "Unable to read Char"
readJSONs (JSString s) = return (fromJSString s)
readJSONs (JSArray a) = mapM readJSON a
readJSONs _ = mkError "Unable to read String"
instance JSON Ordering where
showJSON LT = JSRational (1)
showJSON EQ = JSRational 0
showJSON GT = JSRational 1
readJSON (JSRational (1)) = return LT
readJSON (JSRational 0) = return EQ
readJSON (JSRational 1) = return GT
readJSON _ = mkError "Unable to read Ordering"
instance JSON Integer where
showJSON = JSRational . fromIntegral
readJSON (JSRational i) = return $ round i
readJSON _ = mkError "Unable to read Integer"
instance JSON Int where
showJSON = JSRational . fromIntegral
readJSON (JSRational i) = return $ round i
readJSON _ = mkError "Unable to read Int"
instance JSON Word where
showJSON = JSRational . toRational
readJSON (JSRational i) = return $ truncate i
readJSON _ = mkError "Unable to read Word"
instance JSON Word8 where
showJSON = JSRational . fromIntegral
readJSON (JSRational i) = return $ truncate i
readJSON _ = mkError "Unable to read Word8"
instance JSON Word16 where
showJSON = JSRational . fromIntegral
readJSON (JSRational i) = return $ truncate i
readJSON _ = mkError "Unable to read Word16"
instance JSON Word32 where
showJSON = JSRational . fromIntegral
readJSON (JSRational i) = return $ truncate i
readJSON _ = mkError "Unable to read Word32"
instance JSON Word64 where
showJSON = JSRational . fromIntegral
readJSON (JSRational i) = return $ truncate i
readJSON _ = mkError "Unable to read Word64"
instance JSON Int8 where
showJSON = JSRational . fromIntegral
readJSON (JSRational i) = return $ truncate i
readJSON _ = mkError "Unable to read Int8"
instance JSON Int16 where
showJSON = JSRational . fromIntegral
readJSON (JSRational i) = return $ truncate i
readJSON _ = mkError "Unable to read Int16"
instance JSON Int32 where
showJSON = JSRational . fromIntegral
readJSON (JSRational i) = return $ truncate i
readJSON _ = mkError "Unable to read Int32"
instance JSON Int64 where
showJSON = JSRational . fromIntegral
readJSON (JSRational i) = return $ truncate i
readJSON _ = mkError "Unable to read Int64"
instance JSON Double where
showJSON = JSRational . toRational
readJSON (JSRational r) = return $ fromRational r
readJSON _ = mkError "Unable to read Double"
instance JSON Float where
showJSON = JSRational . toRational
readJSON (JSRational r) = return $ fromRational r
readJSON _ = mkError "Unable to read Float"
instance (JSON a) => JSON (Maybe a) where
readJSON (JSObject o) = case "just" `lookup` as of
Just x -> Just <$> readJSON x
_ -> case "nothing" `lookup` as of
Just JSNull -> return Nothing
_ -> mkError "Unable to read Maybe"
where as = fromJSObject o
readJSON _ = mkError "Unable to read Maybe"
showJSON (Just x) = JSObject $ toJSObject [("just", showJSON x)]
showJSON Nothing = JSObject $ toJSObject [("nothing", JSNull)]
instance (JSON a, JSON b) => JSON (Either a b) where
readJSON (JSObject o) = case "left" `lookup` as of
Just a -> Left <$> readJSON a
Nothing -> case "right" `lookup` as of
Just b -> Right <$> readJSON b
Nothing -> mkError "Unable to read Either"
where as = fromJSObject o
readJSON _ = mkError "Unable to read Either"
showJSON (Left a) = JSObject $ toJSObject [("left", showJSON a)]
showJSON (Right b) = JSObject $ toJSObject [("right", showJSON b)]
instance JSON () where
showJSON _ = JSArray []
readJSON (JSArray []) = return ()
readJSON _ = mkError "Unable to read ()"
instance (JSON a, JSON b) => JSON (a,b) where
showJSON (a,b) = JSArray [ showJSON a, showJSON b ]
readJSON (JSArray [a,b]) = (,) `fmap` readJSON a `ap` readJSON b
readJSON _ = mkError "Unable to read Pair"
instance (JSON a, JSON b, JSON c) => JSON (a,b,c) where
showJSON (a,b,c) = JSArray [ showJSON a, showJSON b, showJSON c ]
readJSON (JSArray [a,b,c]) = (,,) `fmap`
readJSON a `ap`
readJSON b `ap`
readJSON c
readJSON _ = mkError "Unable to read Triple"
instance (JSON a, JSON b, JSON c, JSON d) => JSON (a,b,c,d) where
showJSON (a,b,c,d) = JSArray [showJSON a, showJSON b, showJSON c, showJSON d]
readJSON (JSArray [a,b,c,d]) = (,,,) `fmap`
readJSON a `ap`
readJSON b `ap`
readJSON c `ap`
readJSON d
readJSON _ = mkError "Unable to read 4 tuple"
instance JSON a => JSON [a] where
showJSON = showJSONs
readJSON = readJSONs
instance (Ord a, JSON a, JSON b) => JSON (M.Map a b) where
showJSON m = JSObject $ toJSObject $
map (\ (x,y) -> (showJSValue (showJSON x) "", showJSON y)) (M.toList m)
readJSON (JSObject o) =
mapM rd (fromJSObject o) >>= return . M.fromList
where
rd (a,b) = do
f <- decode a
g <- readJSON b
return (f,g)
readJSON a@(JSArray _) = M.fromList <$> readJSON a
readJSON _ = mkError "Unable to read Map"
instance JSON I.IntSet where
showJSON = showJSON . I.toList
readJSON a@(JSArray _) = I.fromList <$> readJSON a
readJSON _ = mkError "Unable to read IntSet"
instance JSON S.ByteString where
showJSON = JSString . toJSString . S.unpack
readJSON (JSString s) = return $ S.pack $ fromJSString s
readJSON _ = mkError "Unable to read ByteString"
instance JSON L.ByteString where
showJSON = JSString . toJSString . L.unpack
readJSON (JSString s) = return $ L.pack $ fromJSString s
readJSON _ = mkError "Unable to read ByteString"
makeObj :: [(String, JSValue)] -> JSValue
makeObj = JSObject . toJSObject
valFromObj :: JSON a => String -> JSObject JSValue -> Result a
valFromObj k o = maybe (Error $ "valFromObj: Could not find key: " ++ show k)
readJSON
(lookup k (fromJSObject o))