From 4c7ce8fd84da90d112591d8035258f7e8ff63603 Mon Sep 17 00:00:00 2001 From: Don Waldhalm Date: Tue, 21 Nov 2017 08:54:22 -0500 Subject: [PATCH] addresses issue # 223 --- README.md | 1 + examples/canvas2d/Main.hs | 1 + examples/compose-update/Main.hs | 1 + examples/file-reader/Main.hs | 1 + examples/haskell-miso.org/client/Main.hs | 1 + examples/mario/Main.hs | 1 + examples/router/Main.hs | 1 + examples/sse/client/Main.hs | 1 + examples/svg/Main.hs | 1 + examples/three/Main.hs | 15 +++++----- examples/todo-mvc/Main.hs | 11 ++++---- examples/websocket/Main.hs | 1 + examples/xhr/Main.hs | 1 + exe/Main.hs | 1 + ghcjs-src/Miso.hs | 8 ++++-- ghcjs-src/Miso/Delegate.hs | 8 ++++-- ghcjs-src/Miso/Diff.hs | 36 +++++++++++++++++++----- ghcjs-src/Miso/FFI.hs | 5 ++-- ghcjs-src/Miso/Types.hs | 2 ++ jsbits/delegate.js | 10 +++---- sample-app/Main.hs | 1 + 21 files changed, 76 insertions(+), 32 deletions(-) diff --git a/README.md b/README.md index a9f56c14..bf61c38d 100644 --- a/README.md +++ b/README.md @@ -373,6 +373,7 @@ main = startApp App {..} update = updateModel -- update function view = viewModel -- view function events = defaultEvents -- default delegated events + mountPoint = Nothing -- mount point for miso on DOM, defaults to body subs = [] -- empty subscription list -- | Updates model, optionally introduces side effects diff --git a/examples/canvas2d/Main.hs b/examples/canvas2d/Main.hs index 2b46346d..3dcaadc2 100644 --- a/examples/canvas2d/Main.hs +++ b/examples/canvas2d/Main.hs @@ -34,6 +34,7 @@ main = do model = (0.0, 0.0) subs = [] events = defaultEvents + mountPoint = Nothing -- default to body updateModel :: (Image,Image,Image) diff --git a/examples/compose-update/Main.hs b/examples/compose-update/Main.hs index 27981cfa..58610b8c 100644 --- a/examples/compose-update/Main.hs +++ b/examples/compose-update/Main.hs @@ -96,6 +96,7 @@ main = startApp App { initialAction = NoOp, ..} view = viewModel events = defaultEvents subs = [] + mountPoint = Nothing viewModel :: Model -> View Action viewModel (x, y) = diff --git a/examples/file-reader/Main.hs b/examples/file-reader/Main.hs index 8b227853..f6f6365b 100644 --- a/examples/file-reader/Main.hs +++ b/examples/file-reader/Main.hs @@ -35,6 +35,7 @@ main = do , .. } where + mountPoint = Nothing update = updateModel events = defaultEvents subs = [] diff --git a/examples/haskell-miso.org/client/Main.hs b/examples/haskell-miso.org/client/Main.hs index 31671059..cd4575aa 100644 --- a/examples/haskell-miso.org/client/Main.hs +++ b/examples/haskell-miso.org/client/Main.hs @@ -19,6 +19,7 @@ main = do miso App { model = Model currentURI False, ..} where initialAction = NoOp + mountPoint = Nothing update = updateModel events = defaultEvents subs = [ uriSub HandleURI ] diff --git a/examples/mario/Main.hs b/examples/mario/Main.hs index 83692783..a2696315 100644 --- a/examples/mario/Main.hs +++ b/examples/mario/Main.hs @@ -36,6 +36,7 @@ main = do subs = [ arrowsSub GetArrows , windowSub WindowCoords ] + mountPoint = Nothing data Model = Model { x :: !Double diff --git a/examples/router/Main.hs b/examples/router/Main.hs index 266215b6..fd020eaa 100644 --- a/examples/router/Main.hs +++ b/examples/router/Main.hs @@ -46,6 +46,7 @@ main = do events = defaultEvents subs = [ uriSub HandleURI ] view = viewModel + mountPoint = Nothing -- | Update your model updateModel :: Action -> Model -> Effect Action Model diff --git a/examples/sse/client/Main.hs b/examples/sse/client/Main.hs index c202861c..d0142cf2 100644 --- a/examples/sse/client/Main.hs +++ b/examples/sse/client/Main.hs @@ -27,6 +27,7 @@ main = do either (const the404) id . runRoute (Proxy :: Proxy ClientRoutes) handlers events = defaultEvents subs = [sseSub "/sse" handleSseMsg, uriSub HandleURI] + mountPoint = Nothing handleSseMsg :: SSE String -> Action handleSseMsg (SSEMessage msg) = ServerMsg msg diff --git a/examples/svg/Main.hs b/examples/svg/Main.hs index 63fc67df..967b99bc 100644 --- a/examples/svg/Main.hs +++ b/examples/svg/Main.hs @@ -19,6 +19,7 @@ main = startApp App {..} view = viewModel events = defaultEvents subs = [ mouseSub HandleMouse ] + mountPoint = Nothing emptyModel :: Model emptyModel = Model (0,0) diff --git a/examples/three/Main.hs b/examples/three/Main.hs index c4feb91c..1ad432b7 100644 --- a/examples/three/Main.hs +++ b/examples/three/Main.hs @@ -1,14 +1,14 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE RecordWildCards #-} module Main where -import Control.Monad -import Data.IORef -import GHCJS.Types +import Control.Monad +import Data.IORef +import qualified Data.Map as M +import GHCJS.Types -import Miso -import Miso.String +import Miso +import Miso.String data Action = GetTime @@ -58,6 +58,7 @@ main = do startApp App { model = m , initialAction = Init , update = updateModel ref + , mountPoint = Nothing , .. } where @@ -68,7 +69,7 @@ main = do viewModel :: Double -> View action viewModel _ = div_ [] [ div_ [ id_ "stats" - , style_ [("position", "absolute")] + , style_ $ M.singleton "position" "absolute" ] [] , canvas_ [ id_ "canvas" , width_ "400" diff --git a/examples/todo-mvc/Main.hs b/examples/todo-mvc/Main.hs index 0da0a1c8..b6b9cefb 100644 --- a/examples/todo-mvc/Main.hs +++ b/examples/todo-mvc/Main.hs @@ -80,11 +80,12 @@ data Msg main :: IO () main = startApp App { initialAction = NoOp, ..} where - model = emptyModel - update = updateModel - view = viewModel - events = defaultEvents - subs = [] + model = emptyModel + update = updateModel + view = viewModel + events = defaultEvents + mountPoint = Nothing + subs = [] updateModel :: Msg -> Model -> Effect Msg Model updateModel NoOp m = noEff m diff --git a/examples/websocket/Main.hs b/examples/websocket/Main.hs index ca160555..9c36f9c8 100644 --- a/examples/websocket/Main.hs +++ b/examples/websocket/Main.hs @@ -30,6 +30,7 @@ main = startApp App { initialAction = Id, ..} view = appView uri = URL "wss://echo.websocket.org" protocols = Protocols [ ] + mountPoint = Nothing updateModel :: Action -> Model -> Effect Action Model updateModel (HandleWebSocket (WebSocketMessage (Message m))) model diff --git a/examples/xhr/Main.hs b/examples/xhr/Main.hs index 7127c71b..de053e35 100644 --- a/examples/xhr/Main.hs +++ b/examples/xhr/Main.hs @@ -34,6 +34,7 @@ main :: IO () main = do startApp App { model = Model Nothing , initialAction = NoOp + , mountPoint = Nothing , .. } where diff --git a/exe/Main.hs b/exe/Main.hs index 5dac8e4b..8385ba87 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -14,6 +14,7 @@ main = startApp App { initialAction = SayHelloWorld, ..} update = updateModel view = viewModel events = defaultEvents + mountPoint = Nothing subs = [] updateModel :: Action -> Model -> Effect Action Model diff --git a/ghcjs-src/Miso.hs b/ghcjs-src/Miso.hs index ddf4ca6e..9fd361b1 100644 --- a/ghcjs-src/Miso.hs +++ b/ghcjs-src/Miso.hs @@ -70,8 +70,10 @@ common App {..} m getView = do void . forkIO . forever $ threadDelay (1000000 * 86400) >> notify -- Retrieves reference view viewRef <- getView writeEvent + -- know thy mountElement + mountEl <- mountElement mountPoint -- Begin listening for events in the virtual dom - delegator viewRef events + delegator mountEl viewRef events -- Process initial action of application writeEvent initialAction -- Program loop, blocking on SkipChan @@ -90,7 +92,7 @@ common App {..} m getView = do =<< view <$> readIORef modelRef oldVTree <- readIORef viewRef void $ waitForAnimationFrame - Just oldVTree `diff` Just newVTree + (diff mountPoint) (Just oldVTree) (Just newVTree) atomicWriteIORef viewRef newVTree -- | Runs an isomorphic miso application @@ -114,7 +116,7 @@ startApp app@App {..} = common app model $ \writeEvent -> do let initialView = view model initialVTree <- flip runView writeEvent initialView - Nothing `diff` (Just initialVTree) + (diff mountPoint) Nothing (Just initialVTree) newIORef initialVTree -- | Helper diff --git a/ghcjs-src/Miso/Delegate.hs b/ghcjs-src/Miso/Delegate.hs index 33f083b4..22375b85 100644 --- a/ghcjs-src/Miso/Delegate.hs +++ b/ghcjs-src/Miso/Delegate.hs @@ -17,16 +17,18 @@ import Miso.FFI import qualified JavaScript.Object.Internal as OI import GHCJS.Foreign.Callback import GHCJS.Marshal +import GHCJS.Types (JSVal) -- | Entry point for event delegation delegator - :: IORef VTree + :: JSVal + -> IORef VTree -> M.Map MisoString Bool -> IO () -delegator vtreeRef es = do +delegator mountPointElement vtreeRef es = do evts <- toJSVal (M.toList es) getVTreeFromRef <- syncCallback' $ do VTree (OI.Object val) <- readIORef vtreeRef pure val - delegateEvent evts getVTreeFromRef + delegateEvent mountPointElement evts getVTreeFromRef diff --git a/ghcjs-src/Miso/Diff.hs b/ghcjs-src/Miso/Diff.hs index d157bdc1..34fb7042 100644 --- a/ghcjs-src/Miso/Diff.hs +++ b/ghcjs-src/Miso/Diff.hs @@ -7,7 +7,9 @@ -- Stability : experimental -- Portability : non-portable ---------------------------------------------------------------------------- -module Miso.Diff ( diff ) where +module Miso.Diff ( diff + , mountElement + ) where import GHCJS.Foreign.Internal hiding (Object) import GHCJS.Types @@ -16,21 +18,41 @@ import JavaScript.Object.Internal import Miso.Html.Internal -- | Entry point for diffing / patching algorithm -diff :: Maybe VTree -> Maybe VTree -> IO () -diff current new = do - body <- getBody +diff :: Maybe JSString -> Maybe VTree -> Maybe VTree -> IO () +diff mayElem current new = + case mayElem of + Nothing -> do + body <- getBody + diffElement body current new + Just elemId -> do + e <- getElementById elemId + diffElement e current new + +-- | diffing / patching a given element +diffElement :: JSVal -> Maybe VTree -> Maybe VTree -> IO () +diffElement mountEl current new = do case (current, new) of (Nothing, Nothing) -> pure () (Just (VTree current'), Just (VTree new')) -> do - diff' current' new' body + diff' current' new' mountEl (Nothing, Just (VTree new')) -> do - diff' (Object jsNull) new' body + diff' (Object jsNull) new' mountEl (Just (VTree current'), Nothing) -> do - diff' current' (Object jsNull) body + diff' current' (Object jsNull) mountEl + +-- | return the configured mountPoint element or the body +mountElement :: Maybe JSString -> IO JSVal +mountElement mayMp = + case mayMp of + Nothing -> getBody + Just eid -> getElementById eid foreign import javascript unsafe "$r = document.body;" getBody :: IO JSVal +foreign import javascript unsafe "$r = document.getElementById($1);" + getElementById :: JSString -> IO JSVal + foreign import javascript unsafe "diff($1, $2, $3);" diff' :: Object -- ^ current object diff --git a/ghcjs-src/Miso/FFI.hs b/ghcjs-src/Miso/FFI.hs index 056e1fb6..f391e4a6 100644 --- a/ghcjs-src/Miso/FFI.hs +++ b/ghcjs-src/Miso/FFI.hs @@ -130,9 +130,10 @@ foreign import javascript unsafe "copyDOMIntoVTree($1);" -- | Event delegation FFI, routes events received on body through the virtual dom -- Invokes event handler when found -foreign import javascript unsafe "delegate($1, $2);" +foreign import javascript unsafe "delegate($1, $2, $3);" delegateEvent - :: JSVal -- ^ Events + :: JSVal -- ^ mountPoint element + -> JSVal -- ^ Events -> Callback (IO JSVal) -- ^ Virtual DOM callback -> IO () diff --git a/ghcjs-src/Miso/Types.hs b/ghcjs-src/Miso/Types.hs index 28e2feea..4ecc4ea1 100644 --- a/ghcjs-src/Miso/Types.hs +++ b/ghcjs-src/Miso/Types.hs @@ -40,6 +40,8 @@ data App model action = App -- ^ List of delegated events that the body element will listen for , initialAction :: action -- ^ Initial action that is run after the application has loaded + , mountPoint :: Maybe MisoString + -- ^ root element for DOM diff } -- | A monad for succinctly expressing model transitions in the 'update' function. diff --git a/jsbits/delegate.js b/jsbits/delegate.js index 21b47120..ea99cf4f 100644 --- a/jsbits/delegate.js +++ b/jsbits/delegate.js @@ -1,10 +1,10 @@ /* event delegation algorithm */ -function delegate(events, getVTree) { +function delegate(mountPointElement, events, getVTree) { for (var event in events) { - document.body.addEventListener(events[event][0], function(e) { + mountPointElement.addEventListener(events[event][0], function(e) { delegateEvent ( e , getVTree() - , buildTargetToBody(document.body, e.target) + , buildTargetToElement(mountPointElement, e.target) , [] ); }, events[event][1]); @@ -49,9 +49,9 @@ function delegateEvent (event, obj, stack, parentStack) { } } -function buildTargetToBody (body, target) { +function buildTargetToElement (element, target) { var stack = []; - while (body !== target) { + while (element !== target) { stack.unshift (target); target = target.parentNode; } diff --git a/sample-app/Main.hs b/sample-app/Main.hs index a2d4964f..db1d1159 100644 --- a/sample-app/Main.hs +++ b/sample-app/Main.hs @@ -30,6 +30,7 @@ main = startApp App {..} view = viewModel -- view function events = defaultEvents -- default delegated events subs = [] -- empty subscription list + mountPoint = Nothing -- mount point for application (Nothing defaults to 'body') -- | Updates model, optionally introduces side effects updateModel :: Action -> Model -> Effect Action Model