module Language.Scheme.Plugins.JSON where
import Control.Monad.Error
import Data.Array
import Data.Ratio
import Text.JSON
import Text.JSON.Generic
import qualified Language.Scheme.Numerical
import Language.Scheme.Types
instance JSON LispVal where
showJSON (List []) = JSNull
showJSON (String s) = JSString $ toJSString s
showJSON (Atom s) = JSString $ toJSString s
showJSON (Bool b) = JSBool b
showJSON (Number n) = JSRational False $ fromIntegral n
showJSON (Float n) = JSRational False $ toRational n
showJSON (List l) = showJSONs l
showJSON (Vector v) = do
let ls = elems v
f (List [Atom x, y]) = do
(x, showJSON y)
JSObject $ toJSObject $ map f ls
showJSON a = JSNull
readJSON (JSNull) = return $ List []
readJSON (JSString str) = return $ String $ fromJSString str
readJSON (JSBool b) = return $ Bool b
readJSON (JSRational _ num) = do
let numer = abs $ numerator num
let denom = abs $ denominator num
case (numer >= denom) && ((mod numer denom) == 0) of
True -> return $ Number $ round num
_ -> return $ Float $ fromRational num
readJSON (JSArray a) = do
result <- mapM readJSON a
return $ List $ result
readJSON (JSObject o) = do
let f (x,y) = do
y' <- readJSON y
return $ List [Atom x, y']
ls <- mapM f (fromJSObject o)
return $ Vector $ (listArray (0, length ls 1)) ls
jsDecode :: [LispVal] -> IOThrowsError LispVal
jsDecode [String json] = do
let r = decode json :: Result LispVal
case r of
Ok result -> return result
Error msg -> throwError $ Default msg
jsDecode invalid = throwError $ TypeMismatch "string" $ List invalid
jsDecodeStrict :: [LispVal] -> IOThrowsError LispVal
jsDecodeStrict [String json] = do
let r = decodeStrict json :: Result LispVal
case r of
Ok result -> return result
Error msg -> throwError $ Default msg
jsDecodeStrict invalid = jsDecode invalid
jsEncode :: [LispVal] -> IOThrowsError LispVal
jsEncode [val] = return $ String $ encode val
jsEncodeStrict :: [LispVal] -> IOThrowsError LispVal
jsEncodeStrict [val] = return $ String $ encodeStrict val
_test :: IO ()
_test = do
_testDecodeEncode "\"test\""
_testDecodeEncode "true"
_testDecodeEncode "null"
_testDecodeEncode "1"
_testDecodeEncode "1.5"
_testDecodeEncode "[1.1, 2, 3, 1.5]"
_testDecodeEncode "[1.1, 2, {\"a\": 3}, 1.5]"
_testDecodeEncode :: String -> IO ()
_testDecodeEncode str = do
let x = decode str :: Result LispVal
case x of
Ok x -> putStrLn $ encode x
Error msg -> putStrLn $ "An error occurred: " ++ msg