0e5a353 · jsaddle · git.iko.soy

jsaddle-clib/cbits/include/jsaddle.h+13

@@ -4,8 +4,21 @@

44typedef struct native_callbacks {

55 void (* jsaddleStart) ();

66 void (* jsaddleResult) (char *);

7+ char * (* jsaddleSyncResult) (char *);

78 char * jsaddleJsData;

89 char * jsaddleHtmlData;

910} native_callbacks;

1011

12+typedef struct app_callbacks {

13+ void (* mainActivity_onCreate) ();

14+ void (* mainActivity_onStart) ();

15+ void (* mainActivity_onResume) ();

16+ void (* mainActivity_onPause) ();

17+ void (* mainActivity_onStop) ();

18+ void (* mainActivity_onDestroy) ();

19+ void (* mainActivity_onRestart) ();

20+ void (* mainActivity_onNewIntent) (char *, char *);

21+ void (* firebaseInstanceIdService_sendRegistrationToServer) (char *);

22+} app_callbacks;

23+

1124#endif

jsaddle-clib/default.nix+3−3

@@ -1,9 +1,9 @@

1−{ mkDerivation, aeson, base, bytestring, jsaddle, stdenv }:

1+{ mkDerivation, aeson, base, bytestring, data-default, jsaddle, stdenv, text }:

22mkDerivation {

33 pname = "jsaddle-clib";

4− version = "0.8.2.0";

4+ version = "0.9.0.0";

55 src = builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [ ".git" "dist" ])) ./.;

6− libraryHaskellDepends = [ aeson base bytestring jsaddle ];

6+ libraryHaskellDepends = [ aeson base bytestring data-default jsaddle text ];

77 description = "Interface for JavaScript that works with GHCJS and GHC";

88 license = stdenv.lib.licenses.mit;

99}

jsaddle-clib/jsaddle-clib.cabal+4−2

@@ -1,5 +1,5 @@

11name: jsaddle-clib

2−version: 0.8.3.0

2+version: 0.9.0.0

33cabal-version: >=1.10

44build-type: Simple

55license: MIT

@@ -24,7 +24,9 @@ library

2424 aeson >=0.8.0.2 && <1.3,

2525 base <5,

2626 bytestring >=0.10.6.0 && <0.11,

27− jsaddle >= 0.8.0.0 && <0.9

27+ jsaddle >= 0.9.0.0 && <0.10,

28+ data-default,

29+ text

2830 default-language: Haskell2010

2931 hs-source-dirs: src

3032 Include-dirs: cbits/include

jsaddle-clib/src-ghc/Language/Javascript/JSaddle/CLib.hs+88−8

@@ -2,19 +2,27 @@

22module Language.Javascript.JSaddle.CLib

33 ( jsaddleInit

44 , NativeCallbacks (..)

5+ , AppCallbacks (..)

6+ , AppConfig (..)

7+ , pokeAppConfig

8+ , appConfigToAppCallbacks

59 ) where

610

711import Control.Monad (void)

812import Control.Concurrent (forkIO)

913

10−import Data.Monoid ((<>))

14+import Data.Aeson (encode, decode)

1115import Data.ByteString (useAsCString, packCString)

12−import Data.ByteString.Lazy (ByteString, toStrict, fromStrict)

1316import Data.ByteString.Char8 (unpack)

14−import Data.Aeson (encode, decode)

17+import Data.ByteString.Lazy (ByteString, toStrict, fromStrict)

18+import Data.Default (def, Default)

19+import Data.Monoid ((<>))

20+import Data.Text (Text)

21+import qualified Data.Text.Encoding as T

1522

1623import Foreign.C.String (CString, newCString)

1724import Foreign.Ptr (FunPtr, Ptr)

25+import Foreign.Storable (poke)

1826import Foreign.Marshal.Utils (new)

1927

2028import Language.Javascript.JSaddle (JSM)

@@ -32,33 +40,105 @@ foreign import ccall safe "wrapper"

3240foreign import ccall safe "wrapper"

3341 wrapMessageCallback :: (CString -> IO ()) -> IO (FunPtr (CString -> IO ()))

3442

43+foreign import ccall safe "wrapper"

44+ wrapMessageCallback2 :: (CString -> CString -> IO ()) -> IO (FunPtr (CString -> CString -> IO ()))

45+

46+foreign import ccall safe "wrapper"

47+ wrapSyncCallback :: (CString -> IO CString) -> IO (FunPtr (CString -> IO CString))

48+

3549jsaddleInit :: JSM () -> FunPtr (CString -> IO ()) -> IO (Ptr NativeCallbacks)

3650jsaddleInit jsm evaluateJavascriptAsyncPtr = do

3751 let evaluateJavascriptAsync = mkCallback evaluateJavascriptAsyncPtr

38− (processResult, _, start) <- runJavaScript (\batch ->

39− useAsCString (toStrict $ "runJSaddleBatch(" <> encode batch <> ");") $

52+ (processResult, processSyncResult, start) <- runJavaScript (\batch ->

53+ useAsCString (toStrict $ "runJSaddleBatch(" <> encode batch <> ");")

4054 evaluateJavascriptAsync) jsm

41− jsaddleStartPtr <- wrapStartCallback $ void $ forkIO $ start

55+ jsaddleStartPtr <- wrapStartCallback $ void $ forkIO start

4256 jsaddleResultPtr <- wrapMessageCallback $ \s -> do

4357 result <- decode . fromStrict <$> packCString s

4458 case result of

4559 Nothing -> error $ "jsaddle message decode failed: " <> show result

4660 Just r -> processResult r

61+ jsaddleSyncResultPtr <- wrapSyncCallback $ \s -> do

62+ result <- decode . fromStrict <$> packCString s

63+ case result of

64+ Nothing -> error $ "jsaddle message decode failed: " <> show result

65+ Just r -> newCString =<< unpack . toStrict . encode <$> processSyncResult r

4766 jsaddleJsPtr <- newCString $ unpack $ toStrict jsaddleJs

4867 jsaddleHtmlPtr <- newCString $ unpack $ toStrict indexHtml

49− new $ NativeCallbacks

68+ new NativeCallbacks

5069 { _nativeCallbacks_jsaddleStart = jsaddleStartPtr

5170 , _nativeCallbacks_jsaddleResult = jsaddleResultPtr

71+ , _nativeCallbacks_jsaddleSyncResult = jsaddleSyncResultPtr

5272 , _nativeCallbacks_jsaddleJsData = jsaddleJsPtr

5373 , _nativeCallbacks_jsaddleHtmlData = jsaddleHtmlPtr

5474 }

5575

76+data AppConfig = AppConfig

77+ { _appConfig_mainActivityOnCreate :: IO ()

78+ , _appConfig_mainActivityOnStart :: IO ()

79+ , _appConfig_mainActivityOnResume :: IO ()

80+ , _appConfig_mainActivityOnPause :: IO ()

81+ , _appConfig_mainActivityOnStop :: IO ()

82+ , _appConfig_mainActivityOnDestroy :: IO ()

83+ , _appConfig_mainActivityOnRestart :: IO ()

84+ , _appConfig_mainActivityOnNewIntent :: (Text -> Text -> IO ())

85+ , _appConfig_firebaseInstanceIdServiceSendRegistrationToServer :: Text -> IO ()

86+ }

87+

88+instance Default AppConfig where

89+ def = AppConfig

90+ { _appConfig_mainActivityOnCreate = return ()

91+ , _appConfig_mainActivityOnStart = return ()

92+ , _appConfig_mainActivityOnResume = return ()

93+ , _appConfig_mainActivityOnPause = return ()

94+ , _appConfig_mainActivityOnStop = return ()

95+ , _appConfig_mainActivityOnDestroy = return ()

96+ , _appConfig_mainActivityOnRestart = return ()

97+ , _appConfig_mainActivityOnNewIntent = \_ _ -> return ()

98+ , _appConfig_firebaseInstanceIdServiceSendRegistrationToServer = \_ -> return ()

99+ }

100+

101+appConfigToAppCallbacks :: AppConfig -> IO AppCallbacks

102+appConfigToAppCallbacks c = do

103+ create <- wrapStartCallback $ _appConfig_mainActivityOnCreate c

104+ start <- wrapStartCallback $ _appConfig_mainActivityOnStart c

105+ resume <- wrapStartCallback $ _appConfig_mainActivityOnResume c

106+ pause <- wrapStartCallback $ _appConfig_mainActivityOnPause c

107+ stop <- wrapStartCallback $ _appConfig_mainActivityOnStop c

108+ destroy <- wrapStartCallback $ _appConfig_mainActivityOnDestroy c

109+ restart <- wrapStartCallback $ _appConfig_mainActivityOnRestart c

110+ newIntent <- wrapMessageCallback2 $ \intentAction intentData -> do

111+ intentAction' <- fromUtf8CString intentAction

112+ intentData' <- fromUtf8CString intentData

113+ _appConfig_mainActivityOnNewIntent c intentAction' intentData'

114+ firebaseRegPtr <- wrapMessageCallback $ \token -> do

115+ token' <- fromUtf8CString token

116+ _appConfig_firebaseInstanceIdServiceSendRegistrationToServer c token'

117+ return $ AppCallbacks

118+ { _appCallbacks_mainActivity_onCreate = create

119+ , _appCallbacks_mainActivity_onStart = start

120+ , _appCallbacks_mainActivity_onResume = resume

121+ , _appCallbacks_mainActivity_onPause = pause

122+ , _appCallbacks_mainActivity_onStop = stop

123+ , _appCallbacks_mainActivity_onDestroy = destroy

124+ , _appCallbacks_mainActivity_onRestart = restart

125+ , _appCallbacks_mainActivity_onNewIntent = newIntent

126+ , _appCallbacks_firebaseInstanceIdService_sendRegistrationToServer = firebaseRegPtr

127+ }

128+

129+fromUtf8CString :: CString -> IO Text

130+fromUtf8CString = fmap T.decodeUtf8 . packCString

131+

132+pokeAppConfig :: Ptr AppCallbacks -> AppConfig -> IO ()

133+pokeAppConfig ptr cfg = poke ptr =<< appConfigToAppCallbacks cfg

134+

56135jsaddleJs :: ByteString

57136jsaddleJs = ghcjsHelpers <> "\

58137 \runJSaddleBatch = (function() {\n\

59138 \ " <> initState <> "\n\

60139 \ return function(batch) {\n\

61− \ " <> runBatch (\a -> "jsaddle.postMessage(JSON.stringify(" <> a <> "));") Nothing <> "\

140+ \ " <> runBatch (\a -> "jsaddle.postMessage(JSON.stringify(" <> a <> "));")

141+ (Just (\a -> "JSON.parse(jsaddle.syncMessage(JSON.stringify(" <> a <> ")))")) <> "\

62142 \ };\n\

63143 \})();\n\

64144 \jsaddle.postReady();\n"

jsaddle-clib/src/Language/Javascript/JSaddle/CLib/Internal.hsc+39

@@ -9,6 +9,7 @@ import Foreign.C

99data NativeCallbacks = NativeCallbacks

1010 { _nativeCallbacks_jsaddleStart :: !(FunPtr (IO ())) -- void (jsaddleStart *)()

1111 , _nativeCallbacks_jsaddleResult :: !(FunPtr (CString -> IO ())) -- void (jsaddleResult *)(char *)

12+ , _nativeCallbacks_jsaddleSyncResult :: !(FunPtr (CString -> IO CString)) -- char * (jsaddleSyncResult *)(char *)

1213 , _nativeCallbacks_jsaddleJsData :: !CString -- char * jsaddleJsData

1314 , _nativeCallbacks_jsaddleHtmlData :: !CString -- char * jsaddleHtmlData

1415 }

@@ -19,10 +20,48 @@ instance Storable NativeCallbacks where

1920 poke p nc = do

2021 #{poke native_callbacks, jsaddleStart} p $ _nativeCallbacks_jsaddleStart nc

2122 #{poke native_callbacks, jsaddleResult} p $ _nativeCallbacks_jsaddleResult nc

23+ #{poke native_callbacks, jsaddleSyncResult} p $ _nativeCallbacks_jsaddleSyncResult nc

2224 #{poke native_callbacks, jsaddleJsData} p $ _nativeCallbacks_jsaddleJsData nc

2325 #{poke native_callbacks, jsaddleHtmlData} p $ _nativeCallbacks_jsaddleHtmlData nc

2426 peek p = NativeCallbacks

2527 <$> #{peek native_callbacks, jsaddleStart} p

2628 <*> #{peek native_callbacks, jsaddleResult} p

29+ <*> #{peek native_callbacks, jsaddleSyncResult} p

2730 <*> #{peek native_callbacks, jsaddleJsData} p

2831 <*> #{peek native_callbacks, jsaddleHtmlData} p

32+

33+data AppCallbacks = AppCallbacks

34+ { _appCallbacks_mainActivity_onCreate :: !(FunPtr (IO ()))

35+ , _appCallbacks_mainActivity_onStart :: !(FunPtr (IO ()))

36+ , _appCallbacks_mainActivity_onResume :: !(FunPtr (IO ()))

37+ , _appCallbacks_mainActivity_onPause :: !(FunPtr (IO ()))

38+ , _appCallbacks_mainActivity_onStop :: !(FunPtr (IO ()))

39+ , _appCallbacks_mainActivity_onDestroy :: !(FunPtr (IO ()))

40+ , _appCallbacks_mainActivity_onRestart :: !(FunPtr (IO ()))

41+ , _appCallbacks_mainActivity_onNewIntent :: !(FunPtr (CString -> CString -> IO ()))

42+ , _appCallbacks_firebaseInstanceIdService_sendRegistrationToServer :: !(FunPtr (CString -> IO ()))

43+ }

44+

45+instance Storable AppCallbacks where

46+ sizeOf _ = #{size app_callbacks}

47+ alignment _ = #{alignment app_callbacks}

48+ poke p nc = do

49+ #{poke app_callbacks, mainActivity_onCreate} p $ _appCallbacks_mainActivity_onCreate nc

50+ #{poke app_callbacks, mainActivity_onStart} p $ _appCallbacks_mainActivity_onStart nc

51+ #{poke app_callbacks, mainActivity_onResume} p $ _appCallbacks_mainActivity_onResume nc

52+ #{poke app_callbacks, mainActivity_onPause} p $ _appCallbacks_mainActivity_onPause nc

53+ #{poke app_callbacks, mainActivity_onStop} p $ _appCallbacks_mainActivity_onStop nc

54+ #{poke app_callbacks, mainActivity_onDestroy} p $ _appCallbacks_mainActivity_onDestroy nc

55+ #{poke app_callbacks, mainActivity_onRestart} p $ _appCallbacks_mainActivity_onRestart nc

56+ #{poke app_callbacks, mainActivity_onNewIntent} p $ _appCallbacks_mainActivity_onNewIntent nc

57+ #{poke app_callbacks, firebaseInstanceIdService_sendRegistrationToServer} p $ _appCallbacks_firebaseInstanceIdService_sendRegistrationToServer nc

58+ peek p = AppCallbacks

59+ <$> #{peek app_callbacks, mainActivity_onCreate} p

60+ <*> #{peek app_callbacks, mainActivity_onStart} p

61+ <*> #{peek app_callbacks, mainActivity_onResume} p

62+ <*> #{peek app_callbacks, mainActivity_onPause} p

63+ <*> #{peek app_callbacks, mainActivity_onStop} p

64+ <*> #{peek app_callbacks, mainActivity_onDestroy} p

65+ <*> #{peek app_callbacks, mainActivity_onRestart} p

66+ <*> #{peek app_callbacks, mainActivity_onNewIntent} p

67+ <*> #{peek app_callbacks, firebaseInstanceIdService_sendRegistrationToServer} p

jsaddle-warp/default.nix+12−14

@@ -1,24 +1,22 @@

11{ mkDerivation, aeson, base, bytestring, containers, deepseq

2−, doctest, filepath, ghc-prim, http-types, jsaddle, lens, primitive

3−, process, QuickCheck, ref-tf, stdenv, stm, text, time

4−, transformers, wai, wai-websockets, warp, websockets, osx_sdk

5−, darwin, webdriver, phantomjs, ghc

2+, doctest, filepath, ghc-prim, http-types, jsaddle, lens, network

3+, primitive, process, QuickCheck, ref-tf, stdenv, stm, text, time

4+, transformers, uuid, uuid-types, wai, wai-websockets, warp

5+, webdriver, websockets

66}:

77mkDerivation {

88 pname = "jsaddle-warp";

9− version = "0.8.2.0";

9+ version = "0.9.1.0";

1010 src = builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [ ".git" "dist" ])) ./.;

1111 libraryHaskellDepends = [

12− aeson base containers http-types jsaddle stm text time transformers

13− wai wai-websockets warp websockets

14− ] ++ (if ghc.isGhcjs or false then [

15− ] else if stdenv.isDarwin then [

16−# osx_sdk darwin.libobjc darwin.apple_sdk.libs.xpc

17− ] else [

18− ]);

12+ aeson base bytestring containers http-types jsaddle stm text time

13+ transformers uuid uuid-types wai wai-websockets warp websockets

14+ ];

1915 testHaskellDepends = [

20− base bytestring deepseq doctest filepath ghc-prim jsaddle lens

21− primitive process QuickCheck ref-tf webdriver phantomjs

16+ aeson base bytestring containers deepseq doctest filepath ghc-prim

17+ http-types jsaddle lens network primitive process QuickCheck ref-tf

18+ stm text time transformers wai wai-websockets warp webdriver

19+ websockets

2220 ];

2321 testTarget = "--test-option=${jsaddle.src}";

2422 description = "Interface for JavaScript that works with GHCJS and GHC";

jsaddle-warp/jsaddle-warp.cabal+5−2

@@ -1,5 +1,5 @@

11name: jsaddle-warp

2−version: 0.8.3.1

2+version: 0.9.1.0

33cabal-version: >=1.10

44build-type: Simple

55license: MIT

@@ -26,13 +26,16 @@ library

2626 Language.Javascript.JSaddle.WebSockets

2727 build-depends:

2828 aeson >=0.8.0.2 && <1.3,

29+ bytestring >=0.10.6.0 && <0.11,

2930 containers >=0.5.6.2 && <0.6,

3031 http-types >=0.8.6 && <0.10,

31− jsaddle >=0.8.0.0 && <0.9,

32+ jsaddle >=0.9.0.0 && <0.10,

3233 stm >=2.4.4 && <2.5,

3334 text >=1.2.1.3 && <1.3,

3435 time >=1.5.0.1 && <1.8,

3536 transformers >=0.4.2.0 && <0.6,

37+ uuid >=1.3.13 && <1.4,

38+ uuid-types >=1.0.3 && <1.1,

3639 wai >=3.0.3.0 && <3.3,

3740 wai-websockets >=3.0.0.6 && <3.1,

3841 warp >=3.1.2 && <3.3,

jsaddle-warp/src/Language/Javascript/JSaddle/Warp.hs+3−4

@@ -17,8 +17,7 @@ module Language.Javascript.JSaddle.Warp (

1717 -- * Running JSM over WebSockets

1818 run

1919#ifndef ghcjs_HOST_OS

20− , jsaddleOr

21− , jsaddleApp

20+ , module Language.Javascript.JSaddle.WebSockets

2221#endif

2322) where

2423

@@ -29,7 +28,7 @@ import Network.WebSockets (defaultConnectionOptions)

2928

3029import Language.Javascript.JSaddle.Types (JSM)

3130import Language.Javascript.JSaddle.Run (syncPoint)

32−import Language.Javascript.JSaddle.WebSockets (jsaddleOr, jsaddleApp)

31+import Language.Javascript.JSaddle.WebSockets

3332#endif

3433

3534-- | Run the given 'JSM' action as the main entry point. Either directly

@@ -40,6 +39,6 @@ run _port = id

4039#else

4140run :: Int -> JSM () -> IO ()

4241run port f =

43− runSettings (setPort port (setTimeout 3600 defaultSettings)) $

42+ runSettings (setPort port (setTimeout 3600 defaultSettings)) =<<

4443 jsaddleOr defaultConnectionOptions (f >> syncPoint) jsaddleApp

4544#endif

jsaddle-warp/src/Language/Javascript/JSaddle/WebSockets.hs+122−44

@@ -16,6 +16,8 @@ module Language.Javascript.JSaddle.WebSockets (

1616 -- * Running JSM over WebSockets

1717 jsaddleOr

1818 , jsaddleApp

19+ , jsaddleWithAppOr

20+ , jsaddleAppPartial

1921) where

2022

2123import Control.Monad (forever)

@@ -25,7 +27,8 @@ import Control.Exception (handle, AsyncException, throwIO, fromException)

2527import Data.Monoid ((<>))

2628import Data.Aeson (encode, decode)

2729

28−import Network.Wai (Application)

30+import Network.Wai

31+ (lazyRequestBody, Application, Request, Response, ResponseReceived)

2932import Network.WebSockets

3033 (ConnectionOptions(..), sendTextData, receiveDataMessage,

3134 acceptRequest, ServerApp, sendPing)

@@ -34,55 +37,130 @@ import Network.Wai.Handler.WebSockets (websocketsOr)

3437

3538import Language.Javascript.JSaddle.Types (JSM(..))

3639import qualified Network.Wai as W

37− (responseLBS, requestMethod, Application, pathInfo)

38−import Data.Text (Text)

40+ (responseLBS, requestMethod, pathInfo)

3941import qualified Data.Text as T (pack)

4042import qualified Network.HTTP.Types as H

41− (status403, status200, status405)

43+ (status403, status200)

4244import Language.Javascript.JSaddle.Run (runJavaScript)

43−import Language.Javascript.JSaddle.Run.Files (indexHtml, jsaddleJs)

45+import Language.Javascript.JSaddle.Run.Files (indexHtml, runBatch, ghcjsHelpers, initState)

46+import Data.Maybe (fromMaybe)

47+import qualified Data.Map as M (empty, insert, lookup)

48+import Data.IORef (readIORef, newIORef, atomicModifyIORef')

49+import Data.ByteString.Lazy (fromStrict, ByteString)

50+import Data.Text (Text)

51+import Data.UUID.Types (toText)

52+import Data.UUID.V4 (nextRandom)

53+

54+jsaddleOr :: ConnectionOptions -> JSM () -> Application -> IO Application

55+jsaddleOr opts entryPoint otherApp = do

56+ syncHandlers <- newIORef M.empty

57+ let wsApp :: ServerApp

58+ wsApp pending_conn = do

59+ conn <- acceptRequest pending_conn

60+ (processResult, processSyncResult, start) <- runJavaScript (sendTextData conn . encode) entryPoint

61+ _ <- forkIO . forever $

62+ receiveDataMessage conn >>= \case

63+ (WS.Text t) ->

64+ case decode t of

65+ Nothing -> error $ "jsaddle Results decode failed : " <> show t

66+ Just r -> processResult r

67+ _ -> error "jsaddle WebSocket unexpected binary data"

68+ syncKey <- toText <$> nextRandom

69+ atomicModifyIORef' syncHandlers (\m -> (M.insert syncKey processSyncResult m, ()))

70+ sendTextData conn (encode syncKey)

71+ start

72+ waitTillClosed conn

73+

74+ -- Based on Network.WebSocket.forkPingThread

75+ waitTillClosed conn = ignore `handle` go 1

76+ where

77+ go :: Int -> IO ()

78+ go i = do

79+ threadDelay (1 * 1000 * 1000)

80+ sendPing conn (T.pack $ show i)

81+ go (i + 1)

4482

45−jsaddleOr :: ConnectionOptions -> JSM () -> Application -> Application

46−jsaddleOr opts entryPoint = websocketsOr opts wsApp

47− where

48− wsApp :: ServerApp

49− wsApp pending_conn = do

50− conn <- acceptRequest pending_conn

51− (processResult, _, start) <- runJavaScript (sendTextData conn . encode) entryPoint

52− _ <- forkIO . forever $

53− receiveDataMessage conn >>= \case

54− (WS.Text t) ->

55− case decode t of

56− Nothing -> error $ "jsaddle WebSocket decode failed : " <> show t

57− Just r -> processResult r

58− _ -> error "jsaddle WebSocket unexpected binary data"

59− start

60− waitTillClosed conn

83+ ignore e = case fromException e of

84+ Just async -> throwIO (async :: AsyncException)

85+ Nothing -> return ()

6186

62− -- Based on Network.WebSocket.forkPingThread

63− waitTillClosed conn = ignore `handle` go 1

64− where

65− go :: Int -> IO ()

66− go i = do

67− threadDelay (1 * 1000 * 1000)

68− sendPing conn (T.pack $ show i)

69− go (i + 1)

87+ syncHandler :: Application

88+ syncHandler req sendResponse = case (W.requestMethod req, W.pathInfo req) of

89+ ("POST", ["sync", syncKey]) -> do

90+ body <- lazyRequestBody req

91+ case decode body of

92+ Nothing -> error $ "jsaddle sync message decode failed : " <> show body

93+ Just result ->

94+ M.lookup syncKey <$> readIORef syncHandlers >>= \case

95+ Nothing -> error "jsaddle missing sync message handler"

96+ Just handler -> do

97+ next <- encode <$> handler result

98+ sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/json")] next

99+ _ -> otherApp req sendResponse

100+ return $ websocketsOr opts wsApp syncHandler

70101

71− ignore e = case fromException e of

72− Just async -> throwIO (async :: AsyncException)

73− Nothing -> return ()

74102

75103jsaddleApp :: Application

76−jsaddleApp req = jsaddleAppPieces (W.pathInfo req) req

104+jsaddleApp req sendResponse =

105+ fromMaybe

106+ (sendResponse $ W.responseLBS H.status403 [("Content-Type", "text/plain")] "Forbidden")

107+ (jsaddleAppPartial req sendResponse)

108+

109+jsaddleWithAppOr :: ConnectionOptions -> JSM () -> Application -> IO Application

110+jsaddleWithAppOr opts entryPoint otherApp = jsaddleOr opts entryPoint $ \req sendResponse ->

111+ (fromMaybe (otherApp req sendResponse)

112+ (jsaddleAppPartial req sendResponse))

113+

114+jsaddleAppPartial :: Request -> (Response -> IO ResponseReceived) -> Maybe (IO ResponseReceived)

115+jsaddleAppPartial req sendResponse = case (W.requestMethod req, W.pathInfo req) of

116+ ("GET", []) -> Just $ sendResponse $ W.responseLBS H.status200 [("Content-Type", "text/html")] indexHtml

117+ ("GET", ["jsaddle.js"]) -> Just $ sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/javascript")] jsaddleJs

118+ _ -> Nothing

119+

120+-- Use this to generate this string for embedding

121+-- sed -e 's|\\|\\\\|g' -e 's|^| \\|' -e 's|$|\\n\\|' -e 's|"|\\"|g' data/jsaddle.js | pbcopy

122+jsaddleJs :: ByteString

123+jsaddleJs = "\

124+ \if(typeof global !== \"undefined\") {\n\

125+ \ global.window = global;\n\

126+ \ global.WebSocket = require('ws');\n\

127+ \}\n\

128+ \\n\

129+ \var connect = function() {\n\

130+ \ var wsaddress = window.location.protocol.replace('http', 'ws')+\"//\"+window.location.hostname+(window.location.port?(\":\"+window.location.port):\"\");\n\

131+ \\n\

132+ \ var ws = new WebSocket(wsaddress);\n\

133+ \ var syncKey = \"\";\n\

134+ \\n\

135+ \ ws.onopen = function(e) {\n\

136+ \ " <> initState <> "\n\

137+ \ var inXhrSend = false;\n\

138+ \\n\

139+ \ ws.onmessage = function(e) {\n\

140+ \ if(inXhrSend) return;\n\

141+ \ var batch = JSON.parse(e.data);\n\

142+ \ if(typeof batch === \"string\") {\n\

143+ \ syncKey = batch;\n\

144+ \ return;\n\

145+ \ }\n\

146+ \\n\

147+ \ " <> runBatch (\a -> "ws.send(JSON.stringify(" <> a <> "));")

148+ (Just (\a -> "(function(){\n\

149+ \ inXhrSend = true;\n\

150+ \ var xhr = new XMLHttpRequest();\n\

151+ \ xhr.open('POST', '/sync/'+syncKey, false);\n\

152+ \ xhr.setRequestHeader(\"Content-type\", \"application/json\");\n\

153+ \ xhr.send(JSON.stringify(" <> a <> "));\n\

154+ \ inXhrSend = false;\n\

155+ \ return JSON.parse(xhr.response);})()")) <> "\

156+ \ };\n\

157+ \ };\n\

158+ \ ws.onerror = function() {\n\

159+ \ setTimeout(connect, 1000);\n\

160+ \ };\n\

161+ \}\n\

162+ \\n\

163+ \ " <> ghcjsHelpers <> "\

164+ \connect();\n\

165+ \"

77166

78−jsaddleAppPieces :: [Text] -> W.Application

79−jsaddleAppPieces _ req sendResponse

80− | W.requestMethod req `notElem` ["GET", "HEAD"] = sendResponse $ W.responseLBS

81− H.status405

82− [("Content-Type", "text/plain")]

83− "Only GET or HEAD is supported"

84−jsaddleAppPieces [] _req sendResponse = sendResponse $ W.responseLBS H.status200 [("Content-Type", "text/html")] indexHtml

85−jsaddleAppPieces ["jsaddle.js"] _req sendResponse = sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/javascript")] jsaddleJs

86−jsaddleAppPieces _rawPieces _req sendResponse = sendResponse $ W.responseLBS H.status403

87− [ ("Content-Type", "text/plain")

88− ] "Forbidden"

jsaddle-webkit2gtk/default.nix+1−1

@@ -4,7 +4,7 @@

44}:

55mkDerivation {

66 pname = "jsaddle-webkit2gtk";

7− version = "0.8.2.2";

7+ version = "0.9.0.0";

88 src = builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [ ".git" "dist" ])) ./.;

99 libraryHaskellDepends = [

1010 aeson base bytestring directory gi-gio gi-glib gi-gtk

jsaddle-webkit2gtk/jsaddle-webkit2gtk.cabal+2−2

@@ -1,5 +1,5 @@

11name: jsaddle-webkit2gtk

2−version: 0.8.3.1

2+version: 0.9.0.0

33cabal-version: >=1.10

44build-type: Simple

55license: MIT

@@ -36,7 +36,7 @@ library

3636 gi-webkit2 >=4.0.6 && <4.1,

3737 gi-javascriptcore >=4.0.6 && <4.1,

3838 haskell-gi-base >=0.20 && <0.21,

39− jsaddle >=0.8.0.0 && <0.9,

39+ jsaddle >=0.9.0.0 && <0.10,

4040 text >=1.2.1.3 && <1.3,

4141 webkit2gtk3-javascriptcore >=0.14.0.0 && <0.15

4242 if !os(windows)

jsaddle-webkitgtk/default.nix+1−1

@@ -4,7 +4,7 @@

44}:

55mkDerivation {

66 pname = "jsaddle-webkitgtk";

7− version = "0.8.2.2";

7+ version = "0.9.0.0";

88 src = builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [ ".git" "dist" ])) ./.;

99 libraryHaskellDepends = [

1010 aeson base bytestring directory gi-glib gi-gtk gi-javascriptcore

jsaddle-webkitgtk/jsaddle-webkitgtk.cabal+2−2

@@ -1,5 +1,5 @@

11name: jsaddle-webkitgtk

2−version: 0.8.3.1

2+version: 0.9.0.0

33cabal-version: >=1.10

44build-type: Simple

55license: MIT

@@ -32,7 +32,7 @@ library

3232 gi-webkit >=3.0.6 && <3.1,

3333 gi-javascriptcore >=3.0.6 && <3.1,

3434 haskell-gi-base >=0.20 && <0.21,

35− jsaddle >=0.8.0.0 && <0.9,

35+ jsaddle >=0.9.0.0 && <0.10,

3636 text >=1.2.1.3 && <1.3,

3737 webkitgtk3-javascriptcore >=0.14.0.0 && <0.15

3838 if !os(windows)

jsaddle-wkwebview/cbits-cocoa/AppDelegate.m+2−2

@@ -2,7 +2,7 @@

22#import <Cocoa/Cocoa.h>

33#import <WebKit/WebKit.h>

44

5−extern void withWebView(WKWebView *, HsStablePtr);

5+extern void callWithWebView(WKWebView *, HsStablePtr);

66

77@interface AppDelegate : NSObject <NSApplicationDelegate>

88@property (nonatomic, assign) IBOutlet NSWindow *window;

@@ -36,7 +36,7 @@ extern void withWebView(WKWebView *, HsStablePtr);

3636 [theConfiguration.preferences setValue:@YES forKey:@"developerExtrasEnabled"];

3737 WKWebView *webView = [[WKWebView alloc] initWithFrame: [_window.contentView frame] configuration:theConfiguration];

3838 [_window setContentView:webView];

39− withWebView(webView, _handler);

39+ callWithWebView(webView, _handler);

4040}

4141

4242-(void)applicationDidFinishLaunching:(NSNotification *)notification {

jsaddle-wkwebview/cbits-uikit/AppDelegate.m+122−2

@@ -1,55 +1,175 @@

11#import "AppDelegate.h"

22#import "ViewController.h"

3+#import <UserNotifications/UserNotifications.h>

4+#import <stdint.h>

35

4−@interface AppDelegate ()

6+extern void callIO(HsStablePtr);

7+extern void callWithCString(const char * _Nonnull, HsStablePtr);

58

9+@interface AppDelegate ()

610

711@end

812

913HsStablePtr globalHandler = 0;

14+HsStablePtr global_willFinishLaunchingWithOptions = 0;

15+HsStablePtr global_didFinishLaunchingWithOptions = 0;

16+HsStablePtr global_applicationDidBecomeActive = 0;

17+HsStablePtr global_applicationWillResignActive = 0;

18+HsStablePtr global_applicationDidEnterBackground = 0;

19+HsStablePtr global_applicationWillEnterForeground = 0;

20+HsStablePtr global_applicationWillTerminate = 0;

21+HsStablePtr global_applicationSignificantTimeChange = 0;

22+HsStablePtr global_applicationUniversalLink = 0;

23+uint64_t global_requestAuthorizationWithOptions = 0;

24+uint64_t global_requestAuthorizationOptionBadge = 0;

25+uint64_t global_requestAuthorizationOptionSound = 0;

26+uint64_t global_requestAuthorizationOptionAlert = 0;

27+uint64_t global_requestAuthorizationOptionCarPlay = 0;

28+uint64_t global_registerForRemoteNotifications = 0;

29+HsStablePtr global_didRegisterForRemoteNotificationsWithDeviceToken = 0;

30+HsStablePtr global_didFailToRegisterForRemoteNotificationsWithError = 0;

1031

1132@implementation AppDelegate

1233

34+- (BOOL)application:(UIApplication *)application willFinishLaunchingWithOptions:(NSDictionary *)launchOptions {

35+ // Tells the delegate that the launch process has begun but that state restoration has not yet occurred.

36+ callIO(global_willFinishLaunchingWithOptions);

37+ return YES;

38+}

39+

1340- (BOOL)application:(UIApplication *)application didFinishLaunchingWithOptions:(NSDictionary *)launchOptions {

41+ // Tells the delegate that the launch process is almost done and the app is almost ready to run.

1442 self.window = [[UIWindow alloc] initWithFrame:[[UIScreen mainScreen] bounds]];

1543 // Override point for customization after application launch.

1644 self.window.rootViewController = [[ViewController alloc] initWithHandler:globalHandler];

1745 self.window.backgroundColor = [UIColor whiteColor];

1846 [self.window makeKeyAndVisible];

47+ UNUserNotificationCenter* center = [UNUserNotificationCenter currentNotificationCenter];

48+ center.delegate = self;

49+ if (global_requestAuthorizationWithOptions) {

50+ UNAuthorizationOptions options = (UNAuthorizationOptions)0;

51+ if (global_requestAuthorizationOptionBadge) {

52+ options = options | UNAuthorizationOptionBadge;

53+ }

54+ if (global_requestAuthorizationOptionSound) {

55+ options = options | UNAuthorizationOptionSound;

56+ }

57+ if (global_requestAuthorizationOptionAlert) {

58+ options = options | UNAuthorizationOptionAlert;

59+ }

60+ if (global_requestAuthorizationOptionCarPlay) {

61+ options = options | UNAuthorizationOptionCarPlay;

62+ }

63+ [center requestAuthorizationWithOptions:(options)

64+ completionHandler:^(BOOL granted, NSError * _Nullable error) {

65+ // Handler used to alter application behavior based on types of notifications authorized

66+ }];

67+ if (global_registerForRemoteNotifications) {

68+ [application registerForRemoteNotifications];

69+ }

70+ }

71+ callIO(global_didFinishLaunchingWithOptions);

1972 return YES;

2073}

2174

2275- (void)applicationWillResignActive:(UIApplication *)application {

2376 // Sent when the application is about to move from active to inactive state. This can occur for certain types of temporary interruptions (such as an incoming phone call or SMS message) or when the user quits the application and it begins the transition to the background state.

2477 // Use this method to pause ongoing tasks, disable timers, and invalidate graphics rendering callbacks. Games should use this method to pause the game.

78+ callIO(global_applicationWillResignActive);

2579}

2680

2781

2882- (void)applicationDidEnterBackground:(UIApplication *)application {

2983 // Use this method to release shared resources, save user data, invalidate timers, and store enough application state information to restore your application to its current state in case it is terminated later.

3084 // If your application supports background execution, this method is called instead of applicationWillTerminate: when the user quits.

85+ callIO(global_applicationDidEnterBackground);

3186}

3287

3388

3489- (void)applicationWillEnterForeground:(UIApplication *)application {

3590 // Called as part of the transition from the background to the active state; here you can undo many of the changes made on entering the background.

91+ callIO(global_applicationWillEnterForeground);

3692}

3793

3894

3995- (void)applicationDidBecomeActive:(UIApplication *)application {

4096 // Restart any tasks that were paused (or not yet started) while the application was inactive. If the application was previously in the background, optionally refresh the user interface.

97+ callIO(global_applicationDidBecomeActive);

4198}

4299

43100

44101- (void)applicationWillTerminate:(UIApplication *)application {

45102 // Called when the application is about to terminate. Save data if appropriate. See also applicationDidEnterBackground:.

103+ callIO(global_applicationWillTerminate);

104+}

105+

106+- (void)application:(UIApplication *)application didRegisterForRemoteNotificationsWithDeviceToken:(NSData *)deviceToken {

107+ // Tells the delegate that the app successfully registered with Apple Push Notification service (APNs).

108+ NSString *deviceTokenString = [deviceToken base64EncodedStringWithOptions: 0];

109+ callWithCString([deviceTokenString UTF8String], global_didRegisterForRemoteNotificationsWithDeviceToken);

110+}

111+

112+- (void)application:(UIApplication *)application didFailToRegisterForRemoteNotificationsWithError:(NSError *)error {

113+ // Sent to the delegate when Apple Push Notification service cannot successfully complete the registration process.

114+ NSString *errorString = [error localizedDescription];

115+ callWithCString([errorString UTF8String], global_didFailToRegisterForRemoteNotificationsWithError);

116+}

117+

118+- (void)applicationSignificantTimeChange:(UIApplication *)application {

119+ // Tells the delegate when there is a significant change in the time.

120+ callIO(global_applicationSignificantTimeChange);

121+}

122+

123+- (BOOL)application:(UIApplication *)application continueUserActivity:(NSUserActivity *)userActivity restorationHandler:(void (^)(NSArray *restorableObjects))restorationHandler {

124+ // TODO: Reroute universal links when they're clicked in-app.

125+ // https://developer.apple.com/reference/webkit/wknavigationdelegate/1455643-webview?language=objc

126+ if ([userActivity.activityType isEqualToString:NSUserActivityTypeBrowsingWeb] && userActivity.webpageURL) {

127+ callWithCString([userActivity.webpageURL.absoluteString UTF8String], global_applicationUniversalLink);

128+ return YES;

129+ }

130+ return NO;

46131}

47132

48133@end

49134

50−void runInWKWebView(HsStablePtr handler, const char * _Nonnull progName) {

135+void runInWKWebView(HsStablePtr handler,

136+ const char * _Nonnull progName,

137+ HsStablePtr hs_willFinishLaunchingWithOptions,

138+ HsStablePtr hs_didFinishLaunchingWithOptions,

139+ HsStablePtr hs_applicationDidBecomeActive,

140+ HsStablePtr hs_applicationWillResignActive,

141+ HsStablePtr hs_applicationDidEnterBackground,

142+ HsStablePtr hs_applicationWillEnterForeground,

143+ HsStablePtr hs_applicationWillTerminate,

144+ HsStablePtr hs_applicationSignificantTimeChange,

145+ HsStablePtr hs_applicationUniversalLink,

146+ const uint64_t hs_requestAuthorizationWithOptions,

147+ const uint64_t hs_requestAuthorizationOptionBadge,

148+ const uint64_t hs_requestAuthorizationOptionSound,

149+ const uint64_t hs_requestAuthorizationOptionAlert,

150+ const uint64_t hs_requestAuthorizationOptionCarPlay,

151+ const uint64_t hs_registerForRemoteNotifications,

152+ HsStablePtr hs_didRegisterForRemoteNotificationsWithDeviceToken,

153+ HsStablePtr hs_didFailToRegisterForRemoteNotificationsWithError) {

51154 @autoreleasepool {

52155 globalHandler = handler;

156+ global_willFinishLaunchingWithOptions = hs_willFinishLaunchingWithOptions;

157+ global_didFinishLaunchingWithOptions = hs_didFinishLaunchingWithOptions;

158+ global_applicationDidBecomeActive = hs_applicationDidBecomeActive;

159+ global_applicationWillResignActive = hs_applicationWillResignActive;

160+ global_applicationDidEnterBackground = hs_applicationDidEnterBackground;

161+ global_applicationWillEnterForeground = hs_applicationWillEnterForeground;

162+ global_applicationWillTerminate = hs_applicationWillTerminate;

163+ global_applicationSignificantTimeChange = hs_applicationSignificantTimeChange;

164+ global_applicationUniversalLink = hs_applicationUniversalLink;

165+ global_requestAuthorizationWithOptions = hs_requestAuthorizationWithOptions;

166+ global_requestAuthorizationOptionBadge = hs_requestAuthorizationOptionBadge;

167+ global_requestAuthorizationOptionSound = hs_requestAuthorizationOptionSound;

168+ global_requestAuthorizationOptionAlert = hs_requestAuthorizationOptionAlert;

169+ global_requestAuthorizationOptionCarPlay = hs_requestAuthorizationOptionCarPlay;

170+ global_registerForRemoteNotifications = hs_registerForRemoteNotifications;

171+ global_didRegisterForRemoteNotificationsWithDeviceToken = hs_didRegisterForRemoteNotificationsWithDeviceToken;

172+ global_didFailToRegisterForRemoteNotificationsWithError = hs_didFailToRegisterForRemoteNotificationsWithError;

53173 const char * _Nonnull argv [] = {"", 0};

54174 UIApplicationMain(0, argv, nil, NSStringFromClass([AppDelegate class]));

55175 }

jsaddle-wkwebview/cbits-uikit/ViewController.m+2−2

@@ -1,6 +1,6 @@

11#import "ViewController.h"

22

3−extern void withWebView(WKWebView *, HsStablePtr);

3+extern void callWithWebView(WKWebView *, HsStablePtr);

44

55@interface ViewController ()

66

@@ -27,7 +27,7 @@ extern void withWebView(WKWebView *, HsStablePtr);

2727

2828- (void)viewDidLoad {

2929 [super viewDidLoad];

30− withWebView(_webView, _handler);

30+ callWithWebView(_webView, _handler);

3131}

3232

3333

jsaddle-wkwebview/default.nix+3−3

@@ -1,12 +1,12 @@

1−{ mkDerivation, stdenv, aeson, base, bytestring, jsaddle

1+{ mkDerivation, stdenv, aeson, base, bytestring, jsaddle, data-default

22, buildPackages

33}:

44

55mkDerivation {

66 pname = "jsaddle-wkwebview";

7− version = "0.8.3.2";

7+ version = "0.9.0.0";

88 src = ./.;

9− libraryHaskellDepends = [ aeson base bytestring jsaddle ]

9+ libraryHaskellDepends = [ aeson base bytestring jsaddle data-default ]

1010 # should use `librarySystemDepends` but it is not propagated

1111 ++ (with buildPackages; [

1212 darwin.libobjc

jsaddle-wkwebview/jsaddle-wkwebview.cabal+16−8

@@ -1,5 +1,5 @@

11name: jsaddle-wkwebview

2−version: 0.8.3.2

2+version: 0.9.0.0

33cabal-version: >=1.10

44build-type: Simple

55license: MIT

@@ -14,6 +14,10 @@ description:

1414category: Web, Javascript

1515author: Hamish Mackenzie

1616

17+flag include-app-delegate

18+ description: Include default AppDelegate C sources.

19+ default: True

20+

1721source-repository head

1822 type: git

1923 location: https://github.com/ghcjs/jsaddle

@@ -26,7 +30,9 @@ library

2630 aeson >=0.8.0.2 && <1.3,

2731 base <5,

2832 bytestring >=0.10.6.0 && <0.11,

29− jsaddle >= 0.8.0.0 && <0.9

33+ jsaddle >= 0.9.0.0 && <0.10,

34+ data-default,

35+ containers

3036 default-language: Haskell2010

3137 hs-source-dirs: src

3238 frameworks: Foundation, WebKit

@@ -38,11 +44,13 @@ library

3844 else

3945 hs-source-dirs: src-ghc

4046 if os(ios)

41− frameworks: UIKit

42− c-sources:

43− cbits-uikit/AppDelegate.m

44− cbits-uikit/ViewController.m

47+ frameworks: UIKit, UserNotifications

48+ if flag(include-app-delegate)

49+ c-sources:

50+ cbits-uikit/AppDelegate.m

51+ cbits-uikit/ViewController.m

4552 else

4653 frameworks: Cocoa

47− c-sources:

48− cbits-cocoa/AppDelegate.m

54+ if flag(include-app-delegate)

55+ c-sources:

56+ cbits-cocoa/AppDelegate.m

jsaddle-wkwebview/src-ghc/Language/Javascript/JSaddle/WKWebView.hs+138−9

@@ -3,32 +3,161 @@ module Language.Javascript.JSaddle.WKWebView

33 , jsaddleMainFile

44 , WKWebView(..)

55 , run

6+ , runWithAppConfig

67 , runFile

78 , mainBundleResourcePath

9+ , AppDelegateConfig (..)

10+ , AppDelegateNotificationConfig (..)

11+ , AuthorizationOption (..)

812 ) where

913

1014import Data.ByteString (ByteString)

15+import Data.Default (Default, def)

16+import Data.Set (Set)

17+import qualified Data.Set as Set

18+import Data.Word

19+import Foreign.Marshal.Utils (fromBool)

1120import Language.Javascript.JSaddle.WKWebView.Internal (jsaddleMain, jsaddleMainFile, WKWebView(..), mainBundleResourcePath)

1221import System.Environment (getProgName)

1322import Foreign.C.String (CString, withCString)

1423import Foreign.StablePtr (StablePtr, newStablePtr)

1524import Language.Javascript.JSaddle (JSM)

1625

17−foreign import ccall runInWKWebView :: StablePtr (WKWebView -> IO ()) -> CString -> IO ()

26+foreign import ccall runInWKWebView

27+ :: StablePtr (WKWebView -> IO ())

28+ -> CString

29+ -> StablePtr (IO ()) -- willFinishLaunchingWithOptions

30+ -> StablePtr (IO ()) -- didFinishLaunchingWithOptions

31+ -> StablePtr (IO ()) -- applicationDidBecomeActive

32+ -> StablePtr (IO ()) -- applicationWillResignActive

33+ -> StablePtr (IO ()) -- applicationDidEnterBackground

34+ -> StablePtr (IO ()) -- applicationWillEnterForeground

35+ -> StablePtr (IO ()) -- applicationWillTerminate

36+ -> StablePtr (IO ()) -- applicationSignificantTimeChange

37+ -> StablePtr (CString -> IO ()) -- applicationUniversalLink

38+ -> Word64 -- whether to run requestAuthorizationWithOptions

39+ -> Word64 -- Ask for Badge authorization

40+ -> Word64 -- Ask for Sound authorization

41+ -> Word64 -- Ask for Alert authorization

42+ -> Word64 -- Ask for CarPlay authorization

43+ -> Word64 -- registerForRemoteNotifications

44+ -> StablePtr (CString -> IO ()) -- didRegisterForRemoteNotificationsWithDeviceToken

45+ -> StablePtr (CString -> IO ()) -- didFailToRegisterForRemoteNotificationsWithError

46+ -> IO ()

47+

48+data AppDelegateConfig = AppDelegateConfig

49+ { _appDelegateConfig_willFinishLaunchingWithOptions :: IO ()

50+ , _appDelegateConfig_didFinishLaunchingWithOptions :: IO ()

51+ , _appDelegateConfig_applicationDidBecomeActive :: IO ()

52+ , _appDelegateConfig_applicationWillResignActive :: IO ()

53+ , _appDelegateConfig_applicationDidEnterBackground :: IO ()

54+ , _appDelegateConfig_applicationWillEnterForeground :: IO ()

55+ , _appDelegateConfig_applicationWillTerminate :: IO ()

56+ , _appDelegateConfig_applicationSignificantTimeChange :: IO ()

57+ , _appDelegateConfig_applicationUniversalLink :: CString -> IO ()

58+ , _appDelegateConfig_appDelegateNotificationConfig :: AppDelegateNotificationConfig

59+ }

60+

61+instance Default AppDelegateConfig where

62+ def = AppDelegateConfig

63+ { _appDelegateConfig_willFinishLaunchingWithOptions = return ()

64+ , _appDelegateConfig_didFinishLaunchingWithOptions = return ()

65+ , _appDelegateConfig_applicationDidBecomeActive = return ()

66+ , _appDelegateConfig_applicationWillResignActive = return ()

67+ , _appDelegateConfig_applicationDidEnterBackground = return ()

68+ , _appDelegateConfig_applicationWillEnterForeground = return ()

69+ , _appDelegateConfig_applicationWillTerminate = return ()

70+ , _appDelegateConfig_applicationSignificantTimeChange = return ()

71+ , _appDelegateConfig_applicationUniversalLink = \_ -> return ()

72+ , _appDelegateConfig_appDelegateNotificationConfig = def

73+ }

74+

75+data AuthorizationOption = AuthorizationOption_Badge

76+ | AuthorizationOption_Sound

77+ | AuthorizationOption_Alert

78+ | AuthorizationOption_CarPlay

79+ deriving (Show, Read, Eq, Ord)

80+

81+data AppDelegateNotificationConfig = AppDelegateNotificationConfig

82+ { _appDelegateNotificationConfig_requestAuthorizationWithOptions :: Maybe (Set AuthorizationOption)

83+ , _appDelegateNotificationConfig_registerForRemoteNotifications :: Bool

84+ , _appDelegateNotificationConfig_didRegisterForRemoteNotificationsWithDeviceToken :: CString -> IO ()

85+ , _appDelegateNotificationConfig_didFailToRegisterForRemoteNotificationsWithError :: CString -> IO ()

86+ }

87+

88+instance Default AppDelegateNotificationConfig where

89+ def = AppDelegateNotificationConfig

90+ { _appDelegateNotificationConfig_requestAuthorizationWithOptions = Nothing

91+ , _appDelegateNotificationConfig_registerForRemoteNotifications = False

92+ , _appDelegateNotificationConfig_didRegisterForRemoteNotificationsWithDeviceToken = \_ -> return ()

93+ , _appDelegateNotificationConfig_didFailToRegisterForRemoteNotificationsWithError = \_ -> return ()

94+ }

95+

1896

1997-- | Run JSaddle in a WKWebView

2098run :: JSM () -> IO ()

21−run f = do

22− handler <- newStablePtr (jsaddleMain f)

23− progName <- getProgName

24− withCString progName $ runInWKWebView handler

99+run = run' Nothing def

100+

101+-- | Run JSaddle in a WKWebView

102+runWithAppConfig :: AppDelegateConfig -> JSM () -> IO ()

103+runWithAppConfig = run' Nothing

25104

26105-- | Run JSaddle in a WKWebView first loading the specified file

27106-- from the mainBundle (relative to the resourcePath).

28107runFile :: ByteString -- ^ The file to navigate to.

29108 -> ByteString -- ^ The path to allow read access to.

30− -> JSM () -> IO ()

31−runFile url allowing f = do

32− handler <- newStablePtr (jsaddleMainFile url allowing f)

109+ -> AppDelegateConfig

110+ -> JSM ()

111+ -> IO ()

112+runFile url allowing = run' $ Just (url, allowing)

113+

114+run' :: Maybe (ByteString, ByteString)

115+ -> AppDelegateConfig

116+ -> JSM ()

117+ -> IO ()

118+run' mUrl cfg f = do

119+ handler <- case mUrl of

120+ Just (url, allowing) -> newStablePtr (jsaddleMainFile url allowing f)

121+ Nothing -> newStablePtr (jsaddleMain f)

33122 progName <- getProgName

34− withCString progName $ runInWKWebView handler

123+

124+ -- AppDelegate callbacks

125+ willFinishLaunchingWithOptions <- newStablePtr $ _appDelegateConfig_willFinishLaunchingWithOptions cfg

126+ didFinishLaunchingWithOptions <- newStablePtr $ _appDelegateConfig_didFinishLaunchingWithOptions cfg

127+ applicationDidBecomeActive <- newStablePtr $ _appDelegateConfig_applicationDidBecomeActive cfg

128+ applicationWillResignActive <- newStablePtr $ _appDelegateConfig_applicationWillResignActive cfg

129+ applicationDidEnterBackground <- newStablePtr $ _appDelegateConfig_applicationDidEnterBackground cfg

130+ applicationWillEnterForeground <- newStablePtr $ _appDelegateConfig_applicationWillEnterForeground cfg

131+ applicationWillTerminate <- newStablePtr $ _appDelegateConfig_applicationWillTerminate cfg

132+ applicationSignificantTimeChange <- newStablePtr $ _appDelegateConfig_applicationSignificantTimeChange cfg

133+ applicationUniversalLink <- newStablePtr $ _appDelegateConfig_applicationUniversalLink cfg

134+

135+ -- AppDelegate notification configuration

136+ let ncfg = _appDelegateConfig_appDelegateNotificationConfig cfg

137+ (requestAuthorizationWithOptions, authorizationOptions) =

138+ case _appDelegateNotificationConfig_requestAuthorizationWithOptions ncfg of

139+ Nothing -> (False, Set.empty)

140+ Just opts -> (True, opts)

141+ registerForRemoteNotifications = _appDelegateNotificationConfig_registerForRemoteNotifications ncfg

142+ didRegisterForRemoteNotificationsWithDeviceToken <- newStablePtr $ _appDelegateNotificationConfig_didRegisterForRemoteNotificationsWithDeviceToken ncfg

143+ didFailToRegisterForRemoteNotificationsWithError <- newStablePtr $ _appDelegateNotificationConfig_didFailToRegisterForRemoteNotificationsWithError ncfg

144+ withCString progName $ \pn -> runInWKWebView

145+ handler

146+ pn

147+ willFinishLaunchingWithOptions

148+ didFinishLaunchingWithOptions

149+ applicationDidBecomeActive

150+ applicationWillResignActive

151+ applicationDidEnterBackground

152+ applicationWillEnterForeground

153+ applicationWillTerminate

154+ applicationSignificantTimeChange

155+ applicationUniversalLink

156+ (fromBool requestAuthorizationWithOptions)

157+ (fromBool $ Set.member AuthorizationOption_Badge authorizationOptions)

158+ (fromBool $ Set.member AuthorizationOption_Sound authorizationOptions)

159+ (fromBool $ Set.member AuthorizationOption_Alert authorizationOptions)

160+ (fromBool $ Set.member AuthorizationOption_CarPlay authorizationOptions)

161+ (fromBool registerForRemoteNotifications)

162+ didRegisterForRemoteNotificationsWithDeviceToken

163+ didFailToRegisterForRemoteNotificationsWithError

jsaddle-wkwebview/src/Language/Javascript/JSaddle/WKWebView/Internal.hs+18−5

@@ -30,7 +30,9 @@ newtype JSaddleHandler = JSaddleHandler (Ptr JSaddleHandler)

3030foreign export ccall jsaddleStart :: StablePtr (IO ()) -> IO ()

3131foreign export ccall jsaddleResult :: StablePtr (Results -> IO ()) -> CString -> IO ()

3232foreign export ccall jsaddleSyncResult :: StablePtr (Results -> IO Batch) -> JSaddleHandler -> CString -> IO ()

33−foreign export ccall withWebView :: WKWebView -> StablePtr (WKWebView -> IO ()) -> IO ()

33+foreign export ccall callWithWebView :: WKWebView -> StablePtr (WKWebView -> IO ()) -> IO ()

34+foreign export ccall callWithCString :: CString -> StablePtr (CString -> IO ()) -> IO ()

35+foreign export ccall callIO :: StablePtr (IO ()) -> IO ()

3436foreign import ccall addJSaddleHandler :: WKWebView -> StablePtr (IO ()) -> StablePtr (Results -> IO ()) -> StablePtr (Results -> IO Batch) -> IO ()

3537foreign import ccall loadHTMLString :: WKWebView -> CString -> IO ()

3638foreign import ccall loadBundleFile :: WKWebView -> CString -> CString -> IO ()

@@ -81,7 +83,7 @@ jsaddleResult ptrHandler s = do

8183 processResult <- deRefStablePtr ptrHandler

8284 result <- packCString s

8385 case decode (fromStrict result) of

84− Nothing -> error $ "jsaddle WebSocket decode failed : " <> show result

86+ Nothing -> error $ "jsaddle Results decode failed : " <> show result

8587 Just r -> processResult r

8688

8789jsaddleSyncResult :: StablePtr (Results -> IO Batch) -> JSaddleHandler -> CString -> IO ()

@@ -89,17 +91,27 @@ jsaddleSyncResult ptrHandler jsaddleHandler s = do

8991 syncProcessResult <- deRefStablePtr ptrHandler

9092 result <- packCString s

9193 case decode (fromStrict result) of

92− Nothing -> error $ "jsaddle WebSocket decode failed : " <> show result

94+ Nothing -> error $ "jsaddle Results decode failed : " <> show result

9395 Just r -> do -- void . forkIO $ do

9496 batch <- syncProcessResult r

9597 useAsCString (toStrict $ encode batch) $

9698 completeSync jsaddleHandler

9799

98−withWebView :: WKWebView -> StablePtr (WKWebView -> IO ()) -> IO ()

99−withWebView webView ptrF = do

100+callWithWebView :: WKWebView -> StablePtr (WKWebView -> IO ()) -> IO ()

101+callWithWebView webView ptrF = do

100102 f <- deRefStablePtr ptrF

101103 f webView

102104

105+callWithCString :: CString -> StablePtr (CString -> IO ()) -> IO ()

106+callWithCString c fptr = do

107+ f <- deRefStablePtr fptr

108+ f c

109+

110+callIO :: StablePtr (IO ()) -> IO ()

111+callIO ptr = do

112+ f <- deRefStablePtr ptr

113+ f

114+

103115jsaddleJs :: ByteString

104116jsaddleJs = ghcjsHelpers <> "\

105117 \runJSaddleBatch = (function() {\n\

@@ -128,3 +140,4 @@ mainBundleResourcePath = do

128140 if bs == nullPtr

129141 then return Nothing

130142 else Just <$> packCString bs

143+

jsaddle/default.nix+1−1

@@ -5,7 +5,7 @@

55}:

66mkDerivation {

77 pname = "jsaddle";

8− version = "0.8.0.1";

8+ version = "0.9.0.0";

99 src = builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [ ".git" "dist" ])) ./.;

1010 libraryHaskellDepends = [

1111 aeson attoparsec base base64-bytestring bytestring containers

jsaddle/jsaddle.cabal+1−1

@@ -1,5 +1,5 @@

11name: jsaddle

2−version: 0.8.3.2

2+version: 0.9.0.0

33cabal-version: >=1.10

44build-type: Simple

55license: MIT

jsaddle/src/Language/Javascript/JSaddle/Run.hs+32−34

@@ -1,3 +1,4 @@

1+{-# LANGUAGE BangPatterns #-}

12{-# LANGUAGE CPP #-}

23{-# LANGUAGE LambdaCase #-}

34{-# LANGUAGE OverloadedStrings #-}

@@ -49,7 +50,7 @@ import Control.Concurrent.STM.TChan

4950import Control.Concurrent.STM.TVar

5051 (writeTVar, readTVar, readTVarIO, modifyTVar', newTVarIO)

5152import Control.Concurrent.MVar

52− (tryTakeMVar, MVar, putMVar, takeMVar, newEmptyMVar)

53+ (tryTakeMVar, MVar, putMVar, takeMVar, newEmptyMVar, readMVar)

5354

5455import System.IO.Unsafe (unsafeInterleaveIO)

5556import System.Mem.Weak (addFinalizer)

@@ -61,7 +62,7 @@ import Data.Time.Clock (getCurrentTime,diffUTCTime)

6162import Data.IORef (newIORef, atomicWriteIORef, readIORef)

6263

6364import Language.Javascript.JSaddle.Types

64− (Command(..), AsyncCommand(..), Result(..), Results(..), JSContextRef(..), JSVal(..),

65+ (Command(..), AsyncCommand(..), Result(..), BatchResults(..), Results(..), JSContextRef(..), JSVal(..),

6566 Object(..), JSValueReceived(..), JSM(..), Batch(..), JSValueForSend(..))

6667import Language.Javascript.JSaddle.Exception (JSException(..))

6768-- import Language.Javascript.JSaddle.Native.Internal (wrapJSVal)

@@ -152,7 +153,6 @@ runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), Results ->

152153runJavaScript sendBatch entryPoint = do

153154 startTime' <- getCurrentTime

154155 recvMVar <- newEmptyMVar

155− syncSendBatch <- newEmptyMVar

156156 lastAsyncBatch <- newEmptyMVar

157157 commandChan <- newTChanIO

158158 callbacks <- newTVarIO M.empty

@@ -176,7 +176,8 @@ runJavaScript sendBatch entryPoint = do

176176 let processResults :: Bool -> Results -> IO ()

177177 processResults syncCallbacks = \case

178178 (ProtocolError err) -> error $ "Protocol error : " <> T.unpack err

179− (Callback f this a) -> do

179+ (Callback n br f this a) -> do

180+ putMVar recvMVar (n, br)

180181 f'@(JSVal fNumber) <- runReaderT (unJSM $ wrapJSVal f) ctx

181182 this' <- runReaderT (unJSM $ wrapJSVal this) ctx

182183 args <- runReaderT (unJSM $ mapM wrapJSVal a) ctx

@@ -185,27 +186,20 @@ runJavaScript sendBatch entryPoint = do

185186 Nothing -> liftIO $ putStrLn "Callback called after it was freed"

186187 Just cb -> void . forkIO $ do

187188 runReaderT (unJSM $ cb f' this' args) ctx

188− when syncCallbacks $ do

189+ when syncCallbacks $

189190 doSendAsyncCommand ctx EndSyncBlock

190− void $ doSendCommand ctx Sync

191− Duplicate -> error "Error : Unexpected Duplicate"

192− m -> putMVar recvMVar m

191+ Duplicate nBatch nExpected -> do

192+ putStrLn $ "Error : Unexpected Duplicate. syncCallbacks=" <> show syncCallbacks <>

193+ " nBatch=" <> show nBatch <> " nExpected=" <> show nExpected

194+ void $ doSendCommand ctx Sync

195+ BatchResults n br -> putMVar recvMVar (n, br)

193196 asyncResults :: Results -> IO ()

194− asyncResults = processResults False

197+ asyncResults results =

198+ void . forkIO $ processResults False results

195199 syncResults :: Results -> IO Batch

196200 syncResults results = do

197− existing <- tryTakeMVar syncSendBatch

198− when (isJust existing) $ error "Error : Unexpected Sync Results"

199− tryTakeMVar lastAsyncBatch >>= \case

200− Just lastAsync -> processResults True results >> return lastAsync

201− Nothing -> do

202− nextBatch <- newEmptyMVar

203− putMVar syncSendBatch (\batch -> do

204− existing <- tryTakeMVar nextBatch

205− when (isJust existing) $ error "Error : Unexpected Sync Results"

206− putMVar nextBatch batch)

207− processResults True results

208− takeMVar nextBatch

201+ void . forkIO $ processResults True results

202+ readMVar lastAsyncBatch

209203 logInfo s =

210204 readIORef loggingEnabled >>= \case

211205 True -> do

@@ -215,28 +209,32 @@ runJavaScript sendBatch entryPoint = do

215209 cbCount <- M.size <$> readTVarIO callbacks

216210 putStrLn . s $ "M " <> currentBytesUsedStr <> "CB " <> show cbCount

217211 False -> return ()

218− _ <- forkIO . forM_ [1..] $ \nBatch ->

212+ _ <- forkIO . numberForeverFromM_ 1 $ \nBatch ->

219213 readBatch nBatch commandChan >>= \case

220214 (batch@(Batch cmds _ _), resultMVars) -> do

221215 logInfo (\x -> "Sync " <> x <> show (length cmds, last cmds))

222− tryTakeMVar syncSendBatch >>= \case

223− Just send -> send batch

224− Nothing -> do

225− putMVar lastAsyncBatch batch

226− sendBatch batch

227− takeMVar recvMVar >>= \r -> do

228− _ <- tryTakeMVar lastAsyncBatch

229− case r of

230− Success results | length results /= length resultMVars -> error "Unexpected number of jsaddle results"

231− | otherwise -> zipWithM_ putMVar resultMVars results

232− Failure results exception -> do

216+ _ <- tryTakeMVar lastAsyncBatch

217+ putMVar lastAsyncBatch batch

218+ sendBatch batch

219+ takeResult recvMVar nBatch >>= \case

220+ (n, _) | n /= nBatch -> error $ "Unexpected jsaddle results (expected batch " <> show nBatch <> ", got batch " <> show n <> ")"

221+ (_, Success results) | length results /= length resultMVars -> error "Unexpected number of jsaddle results"

222+ | otherwise -> zipWithM_ putMVar resultMVars results

223+ (_, Failure results exception) -> do

233224 -- The exception will only be rethrown in Haskell if/when one of the

234225 -- missing results (if any) is evaluated.

235226 putStrLn "A JavaScript exception was thrown! (may not reach Haskell code)"

236227 zipWithM_ putMVar resultMVars $ results <> repeat (ThrowJSValue exception)

237− _ -> error "Unexpected jsaddle results"

238228 return (asyncResults, syncResults, runReaderT (unJSM entryPoint) ctx)

239229 where

230+ numberForeverFromM_ :: (Monad m, Enum n) => n -> (n -> m a) -> m ()

231+ numberForeverFromM_ !n f = do

232+ f n

233+ numberForeverFromM_ (succ n) f

234+ takeResult recvMVar nBatch =

235+ takeMVar recvMVar >>= \case

236+ (n, _) | n < nBatch -> takeResult recvMVar nBatch

237+ r -> return r

240238 readBatch :: Int -> TChan (Either AsyncCommand (Command, MVar Result)) -> IO (Batch, [MVar Result])

241239 readBatch nBatch chan = do

242240 first <- atomically $ readTChan chan -- We want at least one command to send

jsaddle/src/Language/Javascript/JSaddle/Run/Files.hs+25−11

@@ -44,6 +44,8 @@ initState = "\

4444 \ jsaddle_values.set(4, window);\n\

4545 \ var jsaddle_index = 100;\n\

4646 \ var expectedBatch = 1;\n\

47+ \ var lastResults = [0, {}];\n\

48+ \ var inCallback = 0;\n\

4749 \"

4850

4951runBatch :: (ByteString -> ByteString) -> Maybe (ByteString -> ByteString) -> ByteString

@@ -52,6 +54,7 @@ runBatch send sendSync = "\

5254 \ var processBatch = function(timestamp) {\n\

5355 \ var batch = firstBatch;\n\

5456 \ var results = [];\n\

57+ \ inCallback++;\n\

5558 \ try {\n\

5659 \ syncDepth = initialSyncDepth || 0;\n\

5760 \ for(;;){\n\

@@ -108,7 +111,7 @@ runBatch send sendSync = "\

108111 \ jsaddle_values.set(nArg, arguments[i]);\n\

109112 \ args[i] = nArg;\n\

110113 \ }\n\

111− \ " <> send "{\"tag\": \"Callback\", \"contents\": [nFunction, nThis, args]}" <> "\n\

114+ \ " <> send "{\"tag\": \"Callback\", \"contents\": [lastResults[0], lastResults[1], nFunction, nThis, args]}" <> "\n\

112115 \ })})();\n\

113116 \ break;\n\

114117 \ case \"NewSyncCallback\":\n\

@@ -125,9 +128,13 @@ runBatch send sendSync = "\

125128 \ }\n" <> (

126129 case sendSync of

127130 Just s ->

128− " runBatch(" <> s "{\"tag\": \"Callback\", \"contents\": [nFunction, nThis, args]}" <> ", 1);\n"

131+ " if(inCallback > 0) {\n\

132+ \ " <> send "{\"tag\": \"Callback\", \"contents\": [lastResults[0], lastResults[1], nFunction, nThis, args]}" <> "\n\

133+ \ } else {\n\

134+ \ runBatch(" <> s "{\"tag\": \"Callback\", \"contents\": [lastResults[0], lastResults[1], nFunction, nThis, args]}" <> ", 1);\n\

135+ \ }\n"

129136 Nothing ->

130− " " <> send "{\"tag\": \"Callback\", \"contents\": [nFunction, nThis, args]}" <> "\n"

137+ " " <> send "{\"tag\": \"Callback\", \"contents\": [lastResults[0], lastResults[1], nFunction, nThis, args]}" <> "\n"

131138 ) <>

132139 " })})();\n\

133140 \ break;\n\

@@ -243,29 +250,35 @@ runBatch send sendSync = "\

243250 \ }\n\

244251 \ }\n\

245252 \ }\n\

246− \ if(syncDepth === 0) {\n\

247− \ " <> send "{\"tag\": \"Success\", \"contents\": results}" <> "\n\

253+ \ if(syncDepth <= 0) {\n\

254+ \ lastResults = [batch[2], {\"tag\": \"Success\", \"contents\": results}];\n\

255+ \ " <> send "{\"tag\": \"BatchResults\", \"contents\": [lastResults[0], lastResults[1]]}" <> "\n\

248256 \ break;\n\

249257 \ } else {\n" <> (

250258 case sendSync of

251259 Just s ->

252− " batch = " <> s "{\"tag\": \"Success\", \"contents\": results}" <> "\n\

260+ " lastResults = [batch[2], {\"tag\": \"Success\", \"contents\": results}];\n\

261+ \ batch = " <> s "{\"tag\": \"BatchResults\", \"contents\": [lastResults[0], lastResults[1]]}" <> ";\n\

253262 \ results = [];\n"

254263 Nothing ->

255− " " <> send "{\"tag\": \"Success\", \"contents\": results}" <> "\n\

264+ " " <> send "{\"tag\": \"BatchResults\", \"contents\": [batch[2], {\"tag\": \"Success\", \"contents\": results}]}" <> "\n\

256265 \ break;\n"

257266 ) <>

258267 " }\n\

259268 \ } else {\n\

260− \ if(syncDepth === 0) {\n\

269+ \ if(syncDepth <= 0) {\n\

261270 \ break;\n\

262271 \ } else {\n" <> (

263272 case sendSync of

264273 Just s ->

265− " batch = " <> s "{\"tag\": \"Duplicate\"}" <> "\n\

274+ " if(batch[2] === expectedBatch - 1) {\n\

275+ \ batch = " <> s "{\"tag\": \"BatchResults\", \"contents\": [lastResults[0], lastResults[1]]}" <> ";\n\

276+ \ } else {\n\

277+ \ batch = " <> s "{\"tag\": \"Duplicate\", \"contents\": [batch[2], expectedBatch]}" <> ";\n\

278+ \ }\n\

266279 \ results = [];\n"

267280 Nothing ->

268− " " <> send "{\"tag\": \"Duplicate\"}" <> "\n\

281+ " " <> send "{\"tag\": \"Duplicate\", \"contents\": [batch[2], expectedBatch]}" <> "\n\

269282 \ break;\n"

270283 ) <>

271284 " }\n\

@@ -275,8 +288,9 @@ runBatch send sendSync = "\

275288 \ catch (err) {\n\

276289 \ var n = ++jsaddle_index;\n\

277290 \ jsaddle_values.set(n, err);\n\

278− \ " <> send "{\"tag\": \"Failure\", \"contents\": [results,n]}" <> "\n\

291+ \ " <> send "{\"tag\": \"BatchResults\", \"contents\": [batch[2], {\"tag\": \"Failure\", \"contents\": [results, n]}]}" <> "\n\

279292 \ }\n\

293+ \ inCallback--;\n\

280294 \ };\n\

281295 \ if(batch[1] && (initialSyncDepth || 0) === 0) {\n\

282296 \ window.requestAnimationFrame(processBatch);\n\

jsaddle/src/Language/Javascript/JSaddle/Types.hs+43−19

@@ -14,6 +14,7 @@

1414#endif

1515{-# LANGUAGE ConstraintKinds #-}

1616{-# LANGUAGE KindSignatures #-}

17+{-# LANGUAGE AllowAmbiguousTypes #-}

1718-----------------------------------------------------------------------------

1819--

1920-- Module : Language.Javascript.JSaddle.Types

@@ -73,6 +74,7 @@ module Language.Javascript.JSaddle.Types (

7374 , Command(..)

7475 , Batch(..)

7576 , Result(..)

77+ , BatchResults(..)

7678 , Results(..)

7779#endif

7880) where

@@ -87,10 +89,19 @@ import GHCJS.Nullable (Nullable(..))

8789import GHCJS.Prim.Internal (JSVal(..), JSValueRef)

8890import Data.JSString.Internal.Type (JSString(..))

8991import Control.DeepSeq (NFData(..))

92+import Control.Monad.Trans.Cont (ContT(..))

93+import Control.Monad.Trans.Error (Error(..), ErrorT(..))

94+import Control.Monad.Trans.Except (ExceptT(..))

95+import Control.Monad.Trans.Identity (IdentityT(..))

96+import Control.Monad.Trans.List (ListT(..))

97+import Control.Monad.Trans.Maybe (MaybeT(..))

9098import Control.Monad.Trans.Reader (ReaderT(..))

91−import Control.Monad.Trans.State.Lazy (StateT(..))

92−import qualified Control.Monad.Trans.State.Strict as Strict

93− (StateT(..))

99+import Control.Monad.Trans.RWS.Lazy as Lazy (RWST(..))

100+import Control.Monad.Trans.RWS.Strict as Strict (RWST(..))

101+import Control.Monad.Trans.State.Lazy as Lazy (StateT(..))

102+import Control.Monad.Trans.State.Strict as Strict (StateT(..))

103+import Control.Monad.Trans.Writer.Lazy as Lazy (WriterT(..))

104+import Control.Monad.Trans.Writer.Strict as Strict (WriterT(..))

94105import Control.Monad.Trans.Class (MonadTrans(..))

95106import Control.Monad.Fix (MonadFix)

96107import Control.Monad.Ref (MonadAtomicRef(..), MonadRef(..))

@@ -191,23 +202,28 @@ type MonadJSM = MonadIO

191202#else

192203class (Applicative m, MonadIO m) => MonadJSM m where

193204 liftJSM' :: JSM a -> m a

194− {-# MINIMAL liftJSM' #-}

195205

196−instance MonadJSM JSM where

197− liftJSM' = id

198− {-# INLINE liftJSM' #-}

199−

200−instance MonadJSM m => MonadJSM (ReaderT e m) where

201− liftJSM' = lift . liftJSM'

206+ default liftJSM' :: (MonadJSM m', MonadTrans t) => JSM a' -> t m' a'

207+ liftJSM' = lift . (liftJSM' :: MonadJSM m' => JSM a -> m' a)

202208 {-# INLINE liftJSM' #-}

203209

204−instance MonadJSM m => MonadJSM (StateT r m) where

205− liftJSM' = lift . liftJSM'

210+instance MonadJSM JSM where

211+ liftJSM' = id

206212 {-# INLINE liftJSM' #-}

207213

208−instance MonadJSM m => MonadJSM (Strict.StateT r m) where

209− liftJSM' = lift . liftJSM'

210− {-# INLINE liftJSM' #-}

214+instance (MonadJSM m) => MonadJSM (ContT r m)

215+instance (Error e, MonadJSM m) => MonadJSM (ErrorT e m)

216+instance (MonadJSM m) => MonadJSM (ExceptT e m)

217+instance (MonadJSM m) => MonadJSM (IdentityT m)

218+instance (MonadJSM m) => MonadJSM (ListT m)

219+instance (MonadJSM m) => MonadJSM (MaybeT m)

220+instance (MonadJSM m) => MonadJSM (ReaderT r m)

221+instance (Monoid w, MonadJSM m) => MonadJSM (Lazy.RWST r w s m)

222+instance (Monoid w, MonadJSM m) => MonadJSM (Strict.RWST r w s m)

223+instance (MonadJSM m) => MonadJSM (Lazy.StateT s m)

224+instance (MonadJSM m) => MonadJSM (Strict.StateT s m)

225+instance (Monoid w, MonadJSM m) => MonadJSM (Lazy.WriterT w m)

226+instance (Monoid w, MonadJSM m) => MonadJSM (Strict.WriterT w m)

211227

212228instance MonadRef JSM where

213229 type Ref JSM = Ref IO

@@ -385,10 +401,18 @@ instance ToJSON Result where

385401

386402instance FromJSON Result

387403

388−data Results = Success [Result]

389− | Failure [Result] JSValueReceived

390− | Duplicate

391− | Callback JSValueReceived JSValueReceived [JSValueReceived]

404+data BatchResults = Success [Result]

405+ | Failure [Result] JSValueReceived

406+ deriving (Show, Generic)

407+

408+instance ToJSON BatchResults where

409+ toEncoding = genericToEncoding defaultOptions

410+

411+instance FromJSON BatchResults

412+

413+data Results = BatchResults Int BatchResults

414+ | Duplicate Int Int

415+ | Callback Int BatchResults JSValueReceived JSValueReceived [JSValueReceived]

392416 | ProtocolError Text

393417 deriving (Show, Generic)

394418