content: {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, OverloadedStrings #-}
  -- | JSON serialization and de-serialization for Haste.
  module Haste.Serialize (
      Serialize (..), Parser, fromJSON, (.:), (.:?)
    ) where
  import GHC.Float
  import GHC.Int
  import Haste.JSON
  import Haste.JSString (JSString)
  import qualified Haste.JSString as JS
  import Control.Monad (ap, when)
  
  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 $ JS.pack [c]
    parseJSON (Str s) = do
      when (JS.length s > 1) $ fail "Tried to deserialize long string to a Char"
      return $ JS.head s
    parseJSON _ =
      fail "Tried to deserialize a non-string to a Char"
    listToJSON = toJSON . JS.pack
    parseJSONList s = fmap JS.unpack (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 JSString a
  fromJSON = runParser parseJSON
  
  -- | Type for JSON parser.
  newtype Parser a = Parser (Either JSString a)
  
  runParser :: (a -> Parser b) -> a -> Either JSString 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 . JS.pack
  
  instance Functor Parser where
    fmap f m = m >>= return . f
  
  instance Applicative Parser where
    (<*>) = ap
    pure  = return
  
  -- | Look up a key in a JSON object.
  (.:) :: Serialize a => JSON -> JSString -> Parser a
  Dict o .: key =
    case lookup key o of
      Just x -> parseJSON x
      _      -> Parser . Left $ JS.concat ["Key not found: ", 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
  