module Haste.Serialize (
Serialize (..), Parser, fromJSON, (.:), (.:?)
) where
import GHC.Float
import GHC.Int
import Haste.JSON
import Haste.Prim (JSString, toJSStr, fromJSStr)
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
#endif
import Control.Monad (ap)
class Serialize a where
toJSON :: a -> JSON
listToJSON :: [a] -> JSON
listToJSON = Arr . map toJSON
parseJSON :: JSON -> Parser a
parseJSONList :: JSON -> Parser [a]
parseJSONList (Arr xs) = mapM parseJSON xs
parseJSONList _ = fail "Tried to deserialie a non-array to a list!"
instance Serialize JSON where
toJSON = id
parseJSON = return
instance Serialize Float where
toJSON = Num . float2Double
parseJSON (Num x) = return (double2Float x)
parseJSON _ = fail "Tried to deserialize a non-Number to a Float"
instance Serialize Double where
toJSON = Num
parseJSON (Num x) = return x
parseJSON _ = fail "Tried to deserialize a non-Number to a Double"
instance Serialize Int where
toJSON = Num . fromIntegral
parseJSON (Num x) =
case truncate x of
x' | fromIntegral x' == x ->
return x'
_ ->
fail "The given Number can't be represented as an Int"
parseJSON _ =
fail "Tried to deserialize a non-Number to an Int"
instance Serialize Int8 where
toJSON = Num . fromIntegral
parseJSON (Num x) =
case truncate x of
x' | x <= 0xff && fromIntegral x' == x ->
return x'
_ ->
fail "The given Number can't be represented as an Int8"
parseJSON _ =
fail "Tried to deserialize a non-Number to an Int8"
instance Serialize Int16 where
toJSON = Num . fromIntegral
parseJSON (Num x) =
case truncate x of
x' | x <= 0xffff && fromIntegral x' == x ->
return x'
_ ->
fail "The given Number can't be represented as an Int16"
parseJSON _ =
fail "Tried to deserialize a non-Number to an Int16"
instance Serialize Int32 where
toJSON = Num . fromIntegral
parseJSON (Num x) =
case truncate x of
x' | x < 0xffffffff && fromIntegral x' == x ->
return x'
_ ->
fail "The given Number can't be represented as an Int32"
parseJSON _ =
fail "Tried to deserialize a non-Number to an Int32"
instance Serialize Bool where
toJSON = Bool
parseJSON (Bool x) = return x
parseJSON _ = fail "Tried to deserialize a non-Bool to a Bool"
instance Serialize () where
toJSON _ = Dict []
parseJSON _ = return ()
instance Serialize Char where
toJSON c = Str $ toJSStr [c]
parseJSON (Str s) =
case fromJSStr s of
[c] -> return c
_ -> fail "Tried to deserialize long string to a Char"
parseJSON _ =
fail "Tried to deserialize a non-string to a Char"
listToJSON = toJSON . toJSStr
parseJSONList s = fmap fromJSStr (parseJSON s)
instance Serialize JSString where
toJSON = Str
parseJSON (Str s) = return s
parseJSON _ = fail "Tried to deserialize a non-JSString to a JSString"
instance (Serialize a, Serialize b) => Serialize (a, b) where
toJSON (a, b) = Arr [toJSON a, toJSON b]
parseJSON (Arr [a, b]) = do
a' <- parseJSON a
b' <- parseJSON b
return (a', b')
parseJSON _ =
fail "Tried to deserialize a non-array into a pair!"
instance Serialize a => Serialize (Maybe a) where
toJSON (Just x) = Dict [("hasValue", toJSON True), ("value", toJSON x)]
toJSON (Nothing) = Dict [("hasValue", toJSON False)]
parseJSON d = do
hasVal <- d .: "hasValue"
case hasVal of
False -> return Nothing
_ -> Just `fmap` (d .: "value")
instance Serialize a => Serialize [a] where
toJSON = listToJSON
parseJSON = parseJSONList
instance (Serialize a, Serialize b) => Serialize (Either a b) where
toJSON (Right x) = Dict [("success", toJSON True), ("value", toJSON x)]
toJSON (Left e) = Dict [("success", toJSON False), ("error", toJSON e)]
parseJSON d = do
success <- d .: "success"
case success of
False -> Left `fmap` (d .: "error")
_ -> Right `fmap` (d .: "value")
fromJSON :: Serialize a => JSON -> Either String a
fromJSON = runParser parseJSON
newtype Parser a = Parser (Either String a)
runParser :: (a -> Parser b) -> a -> Either String b
runParser p x = case p x of Parser y -> y
instance Monad Parser where
return = Parser . return
(Parser (Right x)) >>= f = f x
(Parser (Left e)) >>= _ = Parser (Left e)
fail = Parser . Left
instance Functor Parser where
fmap f m = m >>= return . f
instance Applicative Parser where
(<*>) = ap
pure = return
(.:) :: Serialize a => JSON -> JSString -> Parser a
Dict o .: key =
case lookup key o of
Just x -> parseJSON x
_ -> Parser . Left $ "Key not found: " ++ fromJSStr key
_ .: _ =
Parser $ Left "Tried to do lookup on non-object!"
(.:?) :: Serialize a => JSON -> JSString -> Parser (Maybe a)
o .:? key =
case o .: key of
Parser (Right x) -> return (Just x)
_ -> return Nothing