diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -33,7 +33,7 @@

-**Miso** is a small "[isomorphic](http://nerds.airbnb.com/isomorphic-javascript-future-web-apps/)" [Haskell](https://www.haskell.org/) front-end framework featuring a virtual-dom, diffing / patching algorithm, attribute and property normalization, event delegation, event batching, SVG, Server-sent events, Websockets, type-safe [servant](https://haskell-servant.github.io/)-style routing and an extensible Subscription-based subsystem. Inspired by [Elm](http://elm-lang.org/), [Redux](http://redux.js.org/) and [Bobril](http://github.com/bobris/bobril). **Miso** is pure by default, but side effects (like `XHR`) can be introduced into the system via the `Effect` data type. **Miso** makes heavy use of the [GHCJS](https://github.com/ghcjs/ghcjs) FFI and therefore has minimal dependencies. +**Miso** is a small "[isomorphic](http://nerds.airbnb.com/isomorphic-javascript-future-web-apps/)" [Haskell](https://www.haskell.org/) front-end framework for quickly building highly interactive single-page web applications. It features a virtual-dom, diffing / patching algorithm, attribute and property normalization, event delegation, event batching, SVG, Server-sent events, Websockets, type-safe [servant](https://haskell-servant.github.io/)-style routing and an extensible Subscription-based subsystem. Inspired by [Elm](http://elm-lang.org/), [Redux](http://redux.js.org/) and [Bobril](http://github.com/bobris/bobril). **Miso** is pure by default, but side effects (like `XHR`) can be introduced into the system via the `Effect` data type. **Miso** makes heavy use of the [GHCJS](https://github.com/ghcjs/ghcjs) FFI and therefore has minimal dependencies. ## Table of Contents - [Quick Start](#quick-start) @@ -225,8 +225,8 @@ result = import (pkgs.fetchFromGitHub { owner = "dmjio"; repo = "miso"; - sha256 = "13ckz11gbfs047hl3phj7h6fm59wsg9zw2fiqjaqkxmxv17zj5yj"; - rev = "0834d5c0b309de24d836cbdcc25fd257de10be17"; + sha256 = "13wfxxplnqajqnykyxdy7477kdfxshpv800b2shr1iib8m01lygn"; + rev = "91b7194c6e0baab3d367073449a8ada7ba8dc346"; }) {}; in pkgs.haskell.packages.ghcjs.callPackage ./app.nix { miso = result.miso-ghcjs; @@ -373,6 +373,7 @@ 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 --- a/examples/canvas2d/Main.hs +++ b/examples/canvas2d/Main.hs @@ -34,6 +34,7 @@ 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 --- a/examples/compose-update/Main.hs +++ b/examples/compose-update/Main.hs @@ -96,6 +96,7 @@ 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 --- a/examples/file-reader/Main.hs +++ b/examples/file-reader/Main.hs @@ -35,6 +35,7 @@ , .. } where + mountPoint = Nothing update = updateModel events = defaultEvents subs = [] diff --git a/examples/mario/Main.hs b/examples/mario/Main.hs --- a/examples/mario/Main.hs +++ b/examples/mario/Main.hs @@ -36,6 +36,7 @@ subs = [ arrowsSub GetArrows , windowSub WindowCoords ] + mountPoint = Nothing data Model = Model { x :: !Double diff --git a/examples/router/Main.hs b/examples/router/Main.hs --- a/examples/router/Main.hs +++ b/examples/router/Main.hs @@ -46,6 +46,7 @@ events = defaultEvents subs = [ uriSub HandleURI ] view = viewModel + mountPoint = Nothing -- | Update your model updateModel :: Action -> Model -> Effect Action Model diff --git a/examples/svg/Main.hs b/examples/svg/Main.hs --- a/examples/svg/Main.hs +++ b/examples/svg/Main.hs @@ -19,6 +19,7 @@ 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 --- 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 @@ startApp App { model = m , initialAction = Init , update = updateModel ref + , mountPoint = Nothing , .. } where @@ -68,7 +69,7 @@ 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 --- a/examples/todo-mvc/Main.hs +++ b/examples/todo-mvc/Main.hs @@ -80,11 +80,12 @@ 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 --- a/examples/websocket/Main.hs +++ b/examples/websocket/Main.hs @@ -30,6 +30,7 @@ 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 --- a/examples/xhr/Main.hs +++ b/examples/xhr/Main.hs @@ -34,6 +34,7 @@ main = do startApp App { model = Model Nothing , initialAction = NoOp + , mountPoint = Nothing , .. } where diff --git a/exe/Main.hs b/exe/Main.hs --- a/exe/Main.hs +++ b/exe/Main.hs @@ -14,6 +14,7 @@ update = updateModel view = viewModel events = defaultEvents + mountPoint = Nothing subs = [] updateModel :: Action -> Model -> Effect Action Model diff --git a/ghc-src/Miso.hs b/ghc-src/Miso.hs --- a/ghc-src/Miso.hs +++ b/ghc-src/Miso.hs @@ -15,9 +15,11 @@ module Miso ( module Miso.Event , module Miso.Html + , module Miso.Router , module Miso.TypeLevel ) where import Miso.Event import Miso.Html +import Miso.Router import Miso.TypeLevel diff --git a/ghcjs-src/Miso.hs b/ghcjs-src/Miso.hs --- a/ghcjs-src/Miso.hs +++ b/ghcjs-src/Miso.hs @@ -70,8 +70,10 @@ 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 @@ =<< 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 @@ 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 --- a/ghcjs-src/Miso/Delegate.hs +++ b/ghcjs-src/Miso/Delegate.hs @@ -17,16 +17,18 @@ 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 --- 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,20 +18,40 @@ 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' diff --git a/ghcjs-src/Miso/FFI.hs b/ghcjs-src/Miso/FFI.hs --- a/ghcjs-src/Miso/FFI.hs +++ b/ghcjs-src/Miso/FFI.hs @@ -130,9 +130,10 @@ -- | 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/Subscription/History.hs b/ghcjs-src/Miso/Subscription/History.hs --- a/ghcjs-src/Miso/Subscription/History.hs +++ b/ghcjs-src/Miso/Subscription/History.hs @@ -50,7 +50,7 @@ -- | Pushes a new URI onto the History stack pushURI :: URI -> IO () {-# INLINE pushURI #-} -pushURI uri = pushStateNoModel uri { uriPath = path } >> notify chan +pushURI uri = pushStateNoModel uri { uriPath = path } where path | uriPath uri == mempty = "/" | otherwise = uriPath uri @@ -58,7 +58,7 @@ -- | Replaces current URI on stack replaceURI :: URI -> IO () {-# INLINE replaceURI #-} -replaceURI uri = replaceTo' uri { uriPath = path } >> notify chan +replaceURI uri = replaceTo' uri { uriPath = path } where path | uriPath uri == mempty = "/" | otherwise = uriPath uri diff --git a/ghcjs-src/Miso/Types.hs b/ghcjs-src/Miso/Types.hs --- a/ghcjs-src/Miso/Types.hs +++ b/ghcjs-src/Miso/Types.hs @@ -40,6 +40,8 @@ -- ^ 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 --- 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 buildTargetToBody (body, target) { +function buildTargetToElement (element, target) { var stack = []; - while (body !== target) { + while (element !== target) { stack.unshift (target); target = target.parentNode; } diff --git a/jsbits/diff.js b/jsbits/diff.js --- a/jsbits/diff.js +++ b/jsbits/diff.js @@ -76,8 +76,6 @@ if (isSvg) { if (c === "href") node.setAttributeNS("http://www.w3.org/1999/xlink", "href", newProp); - else if (c === "className" || c === "class") - node.setAttributeNS("http://www.w3.org/1999/xlink", "class", newProp); else node.setAttribute(c, newProp); } else if (c in node && !(c === "list" || c === "form")) { @@ -95,8 +93,6 @@ if (isSvg) { if (n === "href") node.setAttributeNS("http://www.w3.org/1999/xlink", "href", newProp); - else if (n === "className" || n === "class") - node.setAttributeNS("http://www.w3.org/1999/xlink", "class", newProp); else node.setAttribute(n, newProp); } else if (n in node && !(n === "list" || n === "form")) { diff --git a/miso.cabal b/miso.cabal --- a/miso.cabal +++ b/miso.cabal @@ -1,5 +1,5 @@ name: miso -version: 0.9.0.0 +version: 0.10.0.0 category: Web, Miso, Data Structures license: BSD3 license-file: LICENSE diff --git a/src/Miso/Router.hs b/src/Miso/Router.hs --- a/src/Miso/Router.hs +++ b/src/Miso/Router.hs @@ -58,12 +58,7 @@ } deriving (Show, Eq, Ord) -- | When routing, the router may fail to match a location. --- Either this is an unrecoverable failure, --- such as failing to parse a query parameter, --- or it is recoverable by trying another path. -data RoutingError - = Fail - | FailFatal +data RoutingError = Fail deriving (Show, Eq, Ord) -- | A 'Router' contains the information necessary to execute a handler. @@ -163,28 +158,27 @@ RChoice a b -> do case routeLoc loc a m of Left Fail -> routeLoc loc b m - Left FailFatal -> Left FailFatal Right x -> Right x RCapture f -> case locPath loc of [] -> Left Fail capture:paths -> case parseUrlPieceMaybe capture of - Nothing -> Left FailFatal + Nothing -> Left Fail Just x -> routeLoc loc { locPath = paths } (f x) m RQueryParam sym f -> case lookup (BS.pack $ symbolVal sym) (locQuery loc) of Nothing -> routeLoc loc (f Nothing) m - Just Nothing -> Left FailFatal + Just Nothing -> Left Fail Just (Just text) -> case parseQueryParamMaybe (decodeUtf8 text) of - Nothing -> Left FailFatal + Nothing -> Left Fail Just x -> routeLoc loc (f (Just x)) m - RQueryParams sym f -> maybe (Left FailFatal) (\x -> routeLoc loc (f x) m) $ do + RQueryParams sym f -> maybe (Left Fail) (\x -> routeLoc loc (f x) m) $ do ps <- sequence $ snd <$> Prelude.filter (\(k, _) -> k == BS.pack (symbolVal sym)) (locQuery loc) sequence $ (parseQueryParamMaybe . decodeUtf8) <$> ps RQueryFlag sym f -> case lookup (BS.pack $ symbolVal sym) (locQuery loc) of Nothing -> routeLoc loc (f False) m Just Nothing -> routeLoc loc (f True) m - Just (Just _) -> Left FailFatal + Just (Just _) -> Left Fail RPath sym a -> case locPath loc of [] -> Left Fail p:paths -> if p == T.pack (symbolVal sym)