content: {-# LANGUAGE CPP                      #-}
  {-# LANGUAGE FlexibleInstances        #-}
  {-# LANGUAGE ForeignFunctionInterface #-}
  {-# LANGUAGE OverloadedStrings        #-}
  {-# LANGUAGE PatternGuards            #-}
  -- | Haste-specific JSON library. JSON is common enough that it's a good idea
  --   to create as fast and small an implementation as possible. To that end,
  --   the parser is implemented entirely in Javascript, and works with any
  --   browser that supports JSON.parse; IE does this from version 8 and up, and
  --   everyone else has done it since just about forever.
  module Haste.JSON (JSON (..), encodeJSON, decodeJSON, toObject, (!), (~>)) where
  import Prelude hiding (null)
  import Haste
  import Haste.Prim
  import Data.String as S
  #ifndef __HASTE__
  import Haste.Parsing
  import Numeric
  #endif
  import Haste.Prim.Foreign hiding (toObject)
  
  -- | Create a JavaScript object from a JSON object. Only makes sense in a
  --   browser context, obviously.
  toObject :: JSON -> JSAny
  toObject = jsJSONParse . encodeJSON
  jsJSONParse :: JSString -> JSAny
  jsJSONParse = veryUnsafePerformIO . _jsJSONParse
  
  _jsJSONParse :: JSString -> IO JSAny
  _jsJSONParse = ffi "JSON.parse"
  
  -- Remember to update jsParseJSON if this data type changes!
  data JSON
    = Num  {-# UNPACK #-} !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!"
  
  -- | This instance may be a bad idea, but it's nice to be able to create JSON
  --   objects using plain numeric literals.
  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 (a-b)
    _ - _             = numFail
    negate (Num a)    = Num (negate a)
    negate _          = numFail
    abs (Num a)       = Num (abs a)
    abs _             = numFail
    signum (Num a)    = Num (signum 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 . flip (showFFloat Nothing) ""
  
  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
  
  -- | Look up a JSON object from a JSON dictionary. Panics if the dictionary
  --   isn't a dictionary, or if it doesn't contain the given key.
  (!) :: 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
    -- | Look up a key in a JSON dictionary. Return Nothing if the key can't be
    --   found for some reason.
    (~>) :: 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 JSString 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
  