@@ -41,11 +41,24 @@ import Servant.API.BasicAuth
4141
4242#ifdef ghcjs_HOST_OS
4343import Control.Exception
44+import Control.Monad (liftM)
45+import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
46+import qualified Data.Aeson as A
47+import qualified Data.HashMap.Strict as H
48+import qualified Data.Text.Internal as T
49+import qualified Data.Vector as V
4450import System.IO.Unsafe (unsafePerformIO)
4551import GHCJS.Buffer (create, fromByteString, getArrayBuffer)
4652import GHCJS.Types (JSVal, jsval)
4753import GHCJS.Marshal (FromJSVal(..), fromJSVal)
4854import GHCJS.Marshal.Pure (pToJSVal)
55+import qualified JavaScript.Object.Internal as OI
56+import Data.Scientific (Scientific, scientific, fromFloatDigits)
57+import GHCJS.Types
58+import GHCJS.Marshal
59+import GHCJS.Marshal.Pure
60+import GHCJS.Foreign.Internal
61+import GHCJS.Marshal.Internal
4962#endif
5063
5164
@@ -398,15 +411,15 @@ foreign import javascript unsafe "JSON['parse']($1)" js_jsonParse :: JSVal -> JS
398411rawDecode :: (FromJSON a) => BS.ByteString -> Maybe a
399412rawDecode bs = do
400413 -- Below copied from Reflex.Dom.WebSocket.Foreign
401− -- let (b, off, len) = fromByteString bs
402− -- -- x = return $ js_dataView off len $ jsval $ getArrayBuffer b :: _
403− -- jsv :: JSVal <- if BS.length bs == 0
404− -- then undefined -- jsval . getArrayBuffer <$> create 0
405− -- else undefined -- return $ js_dataView off len $ jsval $ getArrayBuffer b
414+ let (b, off, len) = fromByteString bs
415+ -- x = return $ js_dataView off len $ jsval $ getArrayBuffer b :: _
416+ let jsv = if BS.length bs == 0
417+ then unsafePerformIO $ jsval . getArrayBuffer <$> create 0
418+ else js_dataView off len $ jsval $ getArrayBuffer b
406419
407− let jsv = _ bs
420+ -- let jsv = _ bs
408421 -- TODO pFromJSVal to avoid unsafePerformIO
409− let res = unsafePerformIO $ try $ fromJSVal $ js_jsonParse jsv
422+ let res = unsafePerformIO $ try $ aesonFromJSVal $ js_jsonParse jsv
410423 case res of
411424 Left (_e :: SomeException) -> Nothing
412425 Right (v :: (Maybe Aeson.Value)) -> maybe Nothing go v
@@ -414,6 +427,32 @@ rawDecode bs = do
414427 go v = case Aeson.fromJSON v of
415428 Aeson.Success a -> Just a
416429 _ -> Nothing
430+
431+
432+-- copied from http://lpaste.net/raw/353535 Thanks ncl28!
433+aesonFromJSVal :: JSVal -> IO (Maybe A.Value)
434+aesonFromJSVal r = case jsonTypeOf r of
435+ JSONNull -> return (Just A.Null)
436+ JSONInteger -> liftM (A.Number . flip scientific 0 . (toInteger :: Int -> Integer))
437+ <$> fromJSVal r
438+ JSONFloat -> liftM (A.Number . (fromFloatDigits :: Double -> Scientific))
439+ <$> fromJSVal r
440+ JSONBool -> liftM A.Bool <$> fromJSVal r
441+ JSONString -> liftM A.String <$> fromJSVal r
442+ -- JSONArray -> liftM (A.Array . V.fromList) <$> (fromJSVal r :: _)
443+ JSONArray -> liftM (A.Array . V.fromList) <$>
444+ runMaybeT (traverse (MaybeT . aesonFromJSVal) =<<
445+ (MaybeT (fromJSVal r)))
446+ JSONObject -> do
447+ props <- OI.listProps (OI.Object r)
448+ runMaybeT $ do
449+ propVals <- forM props $ \p -> do
450+ v <- MaybeT (aesonFromJSVal =<< OI.getProp p (OI.Object r))
451+ -- return (JSS.textFromJSString p, v)
452+ return (T.Text p, v)
453+ return (A.Object (H.fromList propVals))
454+{-# INLINE aesonFromJSVal #-}
455+
417456#else
418457rawDecode :: FromJSON a => BS.ByteString -> Maybe a
419458rawDecode = decode . BL.fromStrict