Merge pull request #320 from dmjio/dwaldhalm-mount_to_existing_dom_el…

…ement

addresses issue # 223

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

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)

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) =

examples/file-reader/Main.hs

@@ -35,6 +35,7 @@ main = do
                , ..
                }
     where
+      mountPoint = Nothing
       update = updateModel
       events = defaultEvents
       subs   = []

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 ]

examples/mario/Main.hs

@@ -36,6 +36,7 @@ main = do
     subs   = [ arrowsSub GetArrows
              , windowSub WindowCoords
              ]
+    mountPoint = Nothing
 
 data Model = Model
     { x :: !Double

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

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

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)

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"

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

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

examples/xhr/Main.hs

@@ -34,6 +34,7 @@ main :: IO ()
 main = do
   startApp App { model = Model Nothing
                , initialAction = NoOp
+               , mountPoint = Nothing
                , ..
                }
     where

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

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

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
 

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

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 ()
 

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.

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;
     }

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