module Haste.JSON (JSON (..), encodeJSON, decodeJSON, toObject, (!), (~>)) where
import Prelude hiding (null)
import Haste
import Haste.Prim
import Data.String as S
#ifndef __HASTE__
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
#endif
import Haste.Parsing
#endif
import Haste.Foreign hiding (toObject)
toObject :: JSON -> JSAny
toObject = jsJSONParse . encodeJSON
jsJSONParse :: JSString -> JSAny
jsJSONParse = veryUnsafePerformIO . _jsJSONParse
_jsJSONParse :: JSString -> IO JSAny
_jsJSONParse = ffi "JSON.parse"
data JSON
= Num !Double
| Str !JSString
| Bool !Bool
| Arr ![JSON]
| Dict ![(JSString, JSON)]
| Null
instance IsString JSON where
fromString = Str . S.fromString
instance JSType JSON where
toJSString = encodeJSON
fromJSString x =
case decodeJSON x of
Right x' -> Just x'
_ -> Nothing
numFail :: a
numFail = error "Num JSON: not a numeric JSON node!"
instance Num JSON where
(Num a) + (Num b) = Num (a+b)
_ + _ = numFail
(Num a) * (Num b) = Num (a*b)
_ * _ = numFail
(Num a) (Num b) = Num (ab)
_ _ = numFail
negate (Num a) = Num (negate a)
negate _ = numFail
abs (Num a) = Num (abs a)
abs _ = numFail
signum (Num a) = signum (Num a)
signum _ = numFail
fromInteger n = Num (fromInteger n)
#ifdef __HASTE__
foreign import ccall "jsShow" jsShowD :: Double -> JSString
foreign import ccall "jsParseJSON" jsParseJSON :: JSString -> Ptr (Maybe JSON)
jsStringify :: JSString -> IO JSString
jsStringify = ffi "JSON.stringify"
#else
jsShowD :: Double -> JSString
jsShowD = toJSStr . show
jsStringify :: JSString -> IO JSString
jsStringify = return . toJSStr . ('"' :) . unq . fromJSStr
where
unq ('"' : cs) = "\\\"" ++ unq cs
unq (c : cs)
| c == '\\' = "\\\\" ++ unq cs
| otherwise = c : unq cs
unq _ = ['"']
#endif
(!) :: JSON -> JSString -> JSON
dict ! k =
case dict ~> k of
Just x -> x
_ -> error $ "Haste.JSON.!: unable to look up key " ++ fromJSStr k
infixl 5 !
class JSONLookup a where
(~>) :: a -> JSString -> Maybe JSON
infixl 5 ~>
instance JSONLookup JSON where
(Dict m) ~> key = lookup key m
_ ~> _ = Nothing
instance JSONLookup (Maybe JSON) where
(Just (Dict m)) ~> key = lookup key m
_ ~> _ = Nothing
encodeJSON :: JSON -> JSString
encodeJSON = catJSStr "" . enc []
where
comma = ","
openbr = "["
closebr = "]"
opencu = "{"
closecu = "}"
colon = ":"
quote = "\""
true = "true"
false = "false"
null = "null"
enc acc Null = null : acc
enc acc (Str s) = veryUnsafePerformIO (jsStringify s) : acc
enc acc (Num d) = jsShowD d : acc
enc acc (Bool True) = true : acc
enc acc (Bool False) = false : acc
enc acc (Arr elems)
| (x:xs) <- elems =
openbr : enc (foldr (\s a -> comma:enc a s) (closebr:acc) xs) x
| otherwise =
openbr : closebr : acc
enc acc (Dict elems)
| ((key,val):xs) <- elems =
let encElem (k, v) a = comma : quote : k : quote : colon : enc a v
encAll =
opencu : veryUnsafePerformIO (jsStringify key) : colon : encRest
encRest = enc (foldr encElem (closecu:acc) xs) val
in encAll
| otherwise =
opencu : closecu : acc
decodeJSON :: JSString -> Either String JSON
#ifdef __HASTE__
decodeJSON = liftMaybe . fromPtr . jsParseJSON
where
liftMaybe (Just x) = Right x
liftMaybe _ = Left "Invalid JSON!"
#else
decodeJSON = liftMaybe . runParser json . fromJSStr
where
liftMaybe (Just x) = Right x
liftMaybe _ = Left "Invalid JSON!"
json = oneOf [Num <$> double,
Bool <$> boolean,
Str <$> jsstring,
Arr <$> array,
Dict <$> object,
null]
jsstring = toJSStr <$> oneOf [quotedString '\'', quotedString '"']
boolean = oneOf [string "true" >> pure True, string "false" >> pure False]
null = string "null" >> pure Null
array = do
_ <- char '[' >> possibly whitespace
elements <- commaSeparated json
_ <- possibly whitespace >> char ']'
return elements
commaSeparated p =
oneOf [do x <- p
_ <- possibly whitespace >> char ',' >> possibly whitespace
xs <- commaSeparated p
return (x:xs),
do x <- p
return [x],
do return []]
object = do
_ <- char '{' >> possibly whitespace
pairs <- commaSeparated kvPair
_ <- possibly whitespace >> char '}'
return pairs
kvPair = do
k <- jsstring
_ <- possibly whitespace >> char ':' >> possibly whitespace
v <- json
return (k, v)
#endif
instance Show JSON where
show = fromJSStr . encodeJSON