543547b · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

Add Monad*Exception instances, add inspector support, and make local files work

commit543547b19ddc3c3c3f21e238a494ab19f469ff1d authorRyan Trinkle <ryan.trinkle@gmail.com> dateSun 7 Jun 2015, 22:36 (11 years ago) parente9c9e12

6 files changed+40−23

compare with develop

unifiedsplit

default.nix+3−2 reflex-dom.cabal+3−1 src-ghc/Reflex/Dom/Internal/Foreign.hs+18−3 src-ghc/Reflex/Dom/Xhr/Foreign.hs+8−11 src/Reflex/Dom/Class.hs+3−2 src/Reflex/Dom/Internal.hs+5−4

default.nix+3−2

@@ -1,7 +1,7 @@

1−{ mkDerivation, dependent-map, ghcjs-dom, lens

1+{ mkDerivation, pkgs, dependent-map, ghcjs-dom, lens

22, mtl, ref-tf, reflex, safe, text, these

33, transformers, data-default, semigroups, aeson

4−, ghc, webkitgtk3-javascriptcore

4+, ghc, webkitgtk3-javascriptcore, exception-transformers

55}:

77mkDerivation {

@@ -22,6 +22,7 @@ mkDerivation {

2222 semigroups

2323 ref-tf

2424 aeson

25+ exception-transformers

2526 ] ++ (if (ghc.pname or null) == "ghcjs" then [ ] else [ webkitgtk3-javascriptcore ]);

2627 license = null;

2728}

reflex-dom.cabal+3−1

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

3636 bytestring == 0.10.*,

3737 data-default == 0.5.*,

3838 aeson == 0.8.*,

39− time == 1.5.*

39+ time == 1.5.*,

40+ exception-transformers == 0.4.*,

41+ directory == 1.2.*

4042

4143 if impl(ghcjs)

4244 hs-source-dirs: src-ghcjs

src-ghc/Reflex/Dom/Internal/Foreign.hs+18−3

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

1+{-# LANGUAGE ForeignFunctionInterface #-}

12module Reflex.Dom.Internal.Foreign where

34import GHCJS.DOM hiding (runWebGUI)

@@ -10,7 +11,10 @@ import Graphics.UI.Gtk.WebKit.WebView

1011import Graphics.UI.Gtk.WebKit.Types hiding (Event, Widget, unWidget)

1112import Graphics.UI.Gtk.WebKit.WebSettings

1213import Graphics.UI.Gtk.WebKit.WebFrame

14+import Graphics.UI.Gtk.WebKit.WebInspector

1315import Data.List

16+import Data.String

17+import System.Directory

1418

1519makeDefaultWebView :: String -> (WebView -> IO ()) -> IO ()

1620makeDefaultWebView userAgentKey main = do

@@ -25,6 +29,7 @@ makeDefaultWebView userAgentKey main = do

2529 userAgent <- settings `get` webSettingsUserAgent

2630 settings `set` [ webSettingsUserAgent := userAgent ++ " " ++ userAgentKey

2731 , webSettingsEnableUniversalAccessFromFileUris := True

32+ , webSettingsEnableDeveloperExtras := True

2833 ]

2934 webViewSetWebSettings webView settings

3035 window `containerAdd` scrollWin

@@ -32,9 +37,20 @@ makeDefaultWebView userAgentKey main = do

3237 _ <- on window objectDestroy . liftIO $ mainQuit

3338 widgetShowAll window

3439 _ <- webView `on` loadFinished $ \_ -> do

35− main webView

40+ main webView --TODO: Should probably only do this once

41+ inspector <- webViewGetInspector webView

42+ _ <- inspector `on` inspectWebView $ \wv -> do

43+ inspectorWindow <- windowNew

44+ windowSetDefaultSize inspectorWindow 900 600

45+ inspectorScrollWin <- scrolledWindowNew Nothing Nothing

46+ inspectorWebView <- webViewNew

47+ inspectorWindow `containerAdd` inspectorScrollWin

48+ inspectorScrollWin `containerAdd` inspectorWebView

49+ widgetShowAll inspectorWindow

50+ return inspectorWebView

3651 wf <- webViewGetMainFrame webView

37− webFrameLoadString wf "" Nothing "file:///"

52+ pwd <- getCurrentDirectory

53+ webFrameLoadString wf "" Nothing $ "file://" ++ pwd ++ "/"

3854 mainGUI

3955

4056runWebGUI :: (WebView -> IO ()) -> IO ()

@@ -52,4 +68,3 @@ runWebGUI' userAgentKey main = do

5268 unless ((" " ++ userAgentKey) `isSuffixOf` agent) $ main (castToWebView window)

5369 Nothing -> do

5470 makeDefaultWebView userAgentKey main

55−

src-ghc/Reflex/Dom/Xhr/Foreign.hs+8−11

@@ -12,13 +12,11 @@ import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef

1212import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef

1313import Graphics.UI.Gtk.WebKit.JavaScriptCore.WebFrame

1414

15−data XMLHttpRequest = XMLHttpRequest JSValueRef JSContextRef deriving (Eq, Ord)

16−

17−xhrContext :: XMLHttpRequest -> JSContextRef

18−xhrContext (XMLHttpRequest _ c) = c

19−

20−xhrValue :: XMLHttpRequest -> JSValueRef

21−xhrValue (XMLHttpRequest v _) = v

15+data XMLHttpRequest

16+ = XMLHttpRequest { xhrValue :: JSValueRef

17+ , xhrContext :: JSContextRef

18+ }

19+ deriving (Eq, Ord)

2220

2321toJSObject :: JSContextRef -> [Ptr OpaqueJSValue] -> IO JSObjectRef

2422toJSObject ctx args = do

@@ -28,18 +26,17 @@ toJSObject ctx args = do

2826 jsobjectsetproperty ctx o prop a 1 nullPtr

2927 return o

3028

31−toResponseType :: a -> a

32−toResponseType = id

33−

3429responseTextToText :: Maybe String -> Maybe Text

3530responseTextToText = fmap T.pack

3631

3732stringToJSValue :: JSContextRef -> String -> IO JSValueRef

3833stringToJSValue ctx s = jsvaluemakestring ctx =<< jsstringcreatewithutf8cstring s

3934

35+toResponseType :: a -> a

36+toResponseType = id

37+

4038xmlHttpRequestNew :: WebView -> IO XMLHttpRequest

4139xmlHttpRequestNew wv = do

42− --wv <- readIORef globalWebViewRef

4340 wf <- webViewGetMainFrame wv

4441 jsContext <- webFrameGetGlobalContext wf

4542 xhrScript <- jsstringcreatewithutf8cstring "new XMLHttpRequest()"

src/Reflex/Dom/Class.hs+3−2

@@ -16,6 +16,7 @@ import Control.Monad.State hiding (mapM, mapM_, forM, forM_, sequence)

1616import Data.Dependent.Sum (DSum (..))

1717import GHCJS.DOM.Types hiding (Event)

1818import GHCJS.DOM (WebView)

19+import Control.Monad.Exception

1920

2021-- | Alias for Data.Map.singleton

2122(=:) :: k -> a -> Map k a

@@ -27,9 +28,9 @@ keycodeEnter = 13

2728keycodeEscape :: Int

2829keycodeEscape = 27

2930

30−class ( Reflex t, MonadHold t m, MonadIO m, Functor m, MonadReflexCreateTrigger t m

31+class ( Reflex t, MonadHold t m, MonadIO m, MonadAsyncException m, Functor m, MonadReflexCreateTrigger t m

3132 , HasDocument m, HasWebView m, HasWebView (WidgetHost m), HasWebView (GuiAction m)

32− , MonadIO (WidgetHost m), MonadIO (GuiAction m), Functor (WidgetHost m), MonadSample t (WidgetHost m)

33+ , MonadIO (WidgetHost m), MonadAsyncException (WidgetHost m), MonadIO (GuiAction m), MonadAsyncException (GuiAction m), Functor (WidgetHost m), MonadSample t (WidgetHost m)

3334 , HasPostGui t (GuiAction m) (WidgetHost m), HasPostGui t (GuiAction m) m, HasPostGui t (GuiAction m) (GuiAction m)

3435 , MonadRef m, MonadRef (WidgetHost m)

3536 , Ref m ~ Ref IO, Ref (WidgetHost m) ~ Ref IO --TODO: Eliminate this reliance on IO

src/Reflex/Dom/Internal.hs+5−4

@@ -19,6 +19,7 @@ import Control.Monad hiding (mapM, mapM_, forM, forM_, sequence, sequence_)

1919import Control.Monad.Reader hiding (mapM, mapM_, forM, forM_, sequence, sequence_)

2020import Control.Monad.Ref

2121import Control.Monad.State.Strict hiding (mapM, mapM_, forM, forM_, sequence, sequence_, get)

22+import Control.Monad.Exception

2223import Control.Concurrent

2324import Control.Applicative

2425import Data.ByteString (ByteString)

@@ -37,7 +38,7 @@ data GuiEnv t h

3738 }

3839

3940--TODO: Poorly named

40−newtype Gui t h m a = Gui { unGui :: ReaderT (GuiEnv t h) m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

41+newtype Gui t h m a = Gui { unGui :: ReaderT (GuiEnv t h) m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadException, MonadAsyncException)

4142

4243runGui :: Gui t h m a -> GuiEnv t h -> m a

4344runGui (Gui g) env = runReaderT g env

@@ -108,7 +109,7 @@ type WidgetInternal t m a = ReaderT WidgetEnv (StateT (WidgetState t m) m) a

108109instance MonadTrans (Widget t) where

109110 lift = Widget . lift . lift

110111

111−newtype Widget t m a = Widget { unWidget :: WidgetInternal t m a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO)

112+newtype Widget t m a = Widget { unWidget :: WidgetInternal t m a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)

112113

113114instance MonadSample t m => MonadSample t (Widget t m) where

114115 sample b = lift $ sample b

@@ -133,7 +134,7 @@ instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (Widget t m)

133134 newEventWithTrigger = lift . newEventWithTrigger

134135

135136instance ( MonadRef m, Ref m ~ Ref IO, MonadRef h, Ref h ~ Ref IO --TODO: Shouldn't need to be IO

136− , MonadIO m, MonadIO h, Functor m

137+ , MonadIO m, MonadAsyncException m, MonadIO h, MonadAsyncException h, Functor m

137138 , ReflexHost t, MonadReflexCreateTrigger t m, MonadSample t m, MonadHold t m

138139 , MonadFix m, HasWebView h, HasPostGui t h h

139140 ) => MonadWidget t (Widget t (Gui t h m)) where

@@ -195,7 +196,7 @@ mainWidgetWithCss css w = runWebGUI $ \webView -> do

195196 Just body <- documentGetBody doc

196197 attachWidget body webView w

197198

198−newtype WithWebView m a = WithWebView { unWithWebView :: ReaderT WebView m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

199+newtype WithWebView m a = WithWebView { unWithWebView :: ReaderT WebView m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadException, MonadAsyncException)

199200

200201instance (Monad m) => HasWebView (WithWebView m) where

201202 askWebView = WithWebView ask