a028487 · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

on develop help sign in

Avoid CPP

a028487Luigy Leon9 years ago

reflex-dom-core/reflex-dom-core.cabal+3

compare with develop

unifiedsplit

@@ -13,6 +13,8 @@ Cabal-version: >=1.9.2

13-- Deal with https://github.com/haskell/cabal/issues/2544 / https://github.com/haskell/cabal/issues/367

14extra-source-files: src-ghc/Foreign/JavaScript/Internal/Utils.hs

15 src-ghcjs/Foreign/JavaScript/Internal/Utils.hs

16+ src-ghc/Reflex/Dom/WebSocket/Internal.hs

17+ src-ghcjs/Reflex/Dom/WebSocket/Internal.hs

16 src/Reflex/Dom/Xhr/Foreign.hs

18 src/Reflex/Dom/Xhr/Foreign.hs

17 src/Reflex/Dom/WebSocket/Foreign.hs

19 src/Reflex/Dom/WebSocket/Foreign.hs

18 src/Reflex/Dom/Xhr/ResponseType.hs

20 src/Reflex/Dom/Xhr/ResponseType.hs

@@ -122,6 +124,7 @@ library

122 other-modules:

124 other-modules:

123 Foreign.JavaScript.Internal.Utils

125 Foreign.JavaScript.Internal.Utils

124 Reflex.Dom.WebSocket.Foreign

126 Reflex.Dom.WebSocket.Foreign

127+ Reflex.Dom.WebSocket.Internal

125 Reflex.Dom.Xhr.Foreign

128 Reflex.Dom.Xhr.Foreign

126 Reflex.Dom.Xhr.ResponseType

129 Reflex.Dom.Xhr.ResponseType

127 Reflex.Dom.Xhr.Exception

130 Reflex.Dom.Xhr.Exception

reflex-dom-core/src-ghc/Reflex/Dom/WebSocket/Internal.hsnew file+10

@@ -0,0 +1,10 @@

1+module Reflex.Dom.WebSocket.Internal where

3+import Data.Aeson

4+import qualified Data.ByteString.Lazy as LBS

5+import Data.JSString (JSString)

6+import Data.JSString.Text

7+import Data.Text.Encoding

9+jsonDecode :: FromJSON a => JSString -> Maybe a

10+jsonDecode = decode . LBS.fromStrict . encodeUtf8 . textFromJSString

reflex-dom-core/src-ghcjs/Reflex/Dom/WebSocket/Internal.hsnew file+30

@@ -0,0 +1,30 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE LambdaCase #-}

3+{-# LANGUAGE ScopedTypeVariables #-}

4+module Reflex.Dom.WebSocket.Internal where

6+import Control.Exception

7+import Data.Aeson

8+import Data.JSString (JSString)

9+import Foreign.JavaScript.Utils

10+import Language.Javascript.JSaddle

11+import System.IO.Unsafe

12+-- When on ghcjs and using packages with jsstring patches it removes the FromJSVal

13+-- instance for Value from ghcjs-base. This makes it so that if the patches

14+-- are used then the instance comes from ghcjs-json

15+#if defined(ghcjs_HOST_OS) && defined(USE_TEXT_JSSTRING)

16+import JavaScript.JSON.Types.FromJSVal ()

17+#endif

18+#if defined(ghcjs_HOST_OS) && !defined(USE_TEXT_JSSTRING)

19+import GHCJS.Marshal ()

20+#endif

21+

22+jsonDecode :: FromJSON a => JSString -> Maybe a

23+jsonDecode t = do

24+ result <- unsafePerformIO $ handle (\(_ :: SomeException) -> pure Nothing) $ do

25+ safeJsonParse t >>= \case

26+ Nothing -> pure Nothing

27+ Just a -> fromJSVal a

28+ case fromJSON result of

29+ Success a -> pure a

30+ Error _ -> Nothing

reflex-dom-core/src/Foreign/JavaScript/Utils.hs+13−1

@@ -1,15 +1,21 @@

1+{-# LANGUAGE ScopedTypeVariables #-}

1module Foreign.JavaScript.Utils

2module Foreign.JavaScript.Utils

2 ( bsFromMutableArrayBuffer

3 ( bsFromMutableArrayBuffer

3 , bsToArrayBuffer

4 , bsToArrayBuffer

5+ , jsonParse

6+ , safeJsonParse

4 ) where

7 ) where

9+import Control.Exception

10+import Control.Lens

6import Data.ByteString (ByteString)

11import Data.ByteString (ByteString)

7import qualified Data.ByteString as BS

12import qualified Data.ByteString as BS

8import Foreign.JavaScript.Internal.Utils (js_dataView)

13import Foreign.JavaScript.Internal.Utils (js_dataView)

9import qualified GHCJS.Buffer as JS

14import qualified GHCJS.Buffer as JS

10import GHCJS.DOM.Types (ArrayBuffer (..))

15import GHCJS.DOM.Types (ArrayBuffer (..))

16+import qualified Language.Javascript.JSaddle as JS (catch, jsg, js1)

11import qualified JavaScript.TypedArray.ArrayBuffer as JS

17import qualified JavaScript.TypedArray.ArrayBuffer as JS

12−import Language.Javascript.JSaddle.Types (MonadJSM, ghcjsPure, jsval, liftJSM)

18+import Language.Javascript.JSaddle.Types (JSString, JSM, JSVal, MonadJSM, ghcjsPure, jsval, liftJSM)

14{-# INLINABLE bsFromMutableArrayBuffer #-}

20{-# INLINABLE bsFromMutableArrayBuffer #-}

15bsFromMutableArrayBuffer :: MonadJSM m => JS.MutableArrayBuffer -> m ByteString

21bsFromMutableArrayBuffer :: MonadJSM m => JS.MutableArrayBuffer -> m ByteString

@@ -25,3 +31,9 @@ bsToArrayBuffer bs = liftJSM $ do

25 else do

31 else do

26 ref <- ghcjsPure (JS.getArrayBuffer b) >>= ghcjsPure . jsval

32 ref <- ghcjsPure (JS.getArrayBuffer b) >>= ghcjsPure . jsval

27 js_dataView off len ref

33 js_dataView off len ref

34+

35+safeJsonParse :: JSString -> JSM (Maybe JSVal)

36+safeJsonParse a = (Just <$> jsonParse a) `JS.catch` \(_ :: SomeException) -> return Nothing

37+

38+jsonParse :: JSString -> JSM JSVal

39+jsonParse a = JS.jsg "JSON" ^. JS.js1 "parse" a

reflex-dom-core/src/Reflex/Dom/WebSocket.hs−40

@@ -41,33 +41,16 @@ import Control.Lens

41import Control.Monad hiding (forM, forM_, mapM, mapM_, sequence)

42import Control.Monad.IO.Class

43import Control.Monad.State

44−import Data.Aeson hiding (json)

45import Data.ByteString (ByteString)

44import Data.ByteString (ByteString)

46import Data.Default

45import Data.Default

47import Data.IORef

46import Data.IORef

48−import Data.JSString (JSString)

49import Data.Maybe (isJust)

47import Data.Maybe (isJust)

50import Data.Text

48import Data.Text

51import Data.Text.Encoding

49import Data.Text.Encoding

52import GHCJS.DOM.Types (runJSM, askJSM, MonadJSM, liftJSM, JSM)

50import GHCJS.DOM.Types (runJSM, askJSM, MonadJSM, liftJSM, JSM)

53import GHCJS.Marshal

51import GHCJS.Marshal

54−import qualified Language.Javascript.JSaddle as JS (jsg, js1)

55import qualified Language.Javascript.JSaddle.Monad as JS (catch)

52import qualified Language.Javascript.JSaddle.Monad as JS (catch)

57−#ifdef ghcjs_HOST_OS

58−import GHCJS.DOM.Types ()

59−import System.IO.Unsafe

60−#else

61−import Data.JSString.Text

62−import qualified Data.ByteString.Lazy as LBS

63−#endif

64−-- When on ghcjs and using packages with jsstring patches it removes the FromJSVal

65−-- instance for Value from ghcjs-base. This makes it so that if the patches

66−-- are used then the instance comes from ghcjs-json

67−#if defined(ghcjs_HOST_OS) && defined(USE_TEXT_JSSTRING)

68−import JavaScript.JSON.Types.FromJSVal ()

69−#endif

70−

71data WebSocketConfig t a

54data WebSocketConfig t a

72 = WebSocketConfig { _webSocketConfig_send :: Event t [a]

55 = WebSocketConfig { _webSocketConfig_send :: Event t [a]

73 , _webSocketConfig_close :: Event t (Word, Text)

56 , _webSocketConfig_close :: Event t (Word, Text)

@@ -145,29 +128,6 @@ webSocket' url config onRawMessage = do

145textWebSocket :: (MonadJSM m, MonadJSM (Performable m), HasJSContext m, PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, Reflex t) => Text -> WebSocketConfig t Text -> m (RawWebSocket t Text)

128textWebSocket :: (MonadJSM m, MonadJSM (Performable m), HasJSContext m, PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, Reflex t) => Text -> WebSocketConfig t Text -> m (RawWebSocket t Text)

146textWebSocket url cfg = webSocket' url cfg (either (return . decodeUtf8) fromJSValUnchecked)

129textWebSocket url cfg = webSocket' url cfg (either (return . decodeUtf8) fromJSValUnchecked)

147

130

148−-- | Deserialize a JSON value from a JSString.

149−-- When on ghcjs it uses JSON.parse which is usually faster than using aeson's decode to get a Value

150−-- When on ghc the JSString is converted to Text and then to ByteString in order to use aeson's decode

151−jsonDecode :: FromJSON a => JSString -> Maybe a

152−jsonDecode t = do

153−#ifdef ghcjs_HOST_OS

154− result <- unsafePerformIO $ handle (\(_ :: SomeException) -> pure Nothing) $ do

155− safeJsonParse t >>= \case

156− Nothing -> pure Nothing

157− Just a -> fromJSVal a

158− case fromJSON result of

159− Success a -> pure a

160− Error _ -> Nothing

161−#else

162− decode $ LBS.fromStrict $ encodeUtf8 $ textFromJSString t

163−#endif

164−

165−safeJsonParse :: JSString -> JSM (Maybe JSVal)

166−safeJsonParse a = (Just <$> jsonParse a) `JS.catch` \(_ :: SomeException) -> return Nothing

167−

168−jsonParse :: JSString -> JSM JSVal

169−jsonParse a = JS.jsg "JSON" ^. JS.js1 "parse" a

170−

171#ifdef USE_TEMPLATE_HASKELL

131#ifdef USE_TEMPLATE_HASKELL

172makeLensesWith (lensRules & simpleLenses .~ True) ''WebSocketConfig

132makeLensesWith (lensRules & simpleLenses .~ True) ''WebSocketConfig

173makeLensesWith (lensRules & simpleLenses .~ True) ''RawWebSocket

133makeLensesWith (lensRules & simpleLenses .~ True) ''RawWebSocket