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 @@ -66,7 +66,7 @@ , input_ [ id_ "fileReader" , type_ "file" , onChange (const ReadFile) - ] [] + ] , div_ [] [ text info ] ] 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 @@ -175,7 +175,7 @@ , name_ "toggle" , checked_ allCompleted , onClick $ CheckAll (not allCompleted) - ] [] + ] , label_ [ for_ "toggle-all" ] [ text $ S.pack "Mark all as complete" ] @@ -207,7 +207,7 @@ , type_ "checkbox" , checked_ completed , onClick $ Check eid (not completed) - ] [] + ] , label_ [ onDoubleClick $ EditingEntry eid True ] [ text description ] @@ -225,7 +225,6 @@ , onBlur $ EditingEntry eid False , onEnter $ EditingEntry eid False ] - [] ] viewControls :: Model -> MisoString -> [ Entry ] -> View Msg @@ -291,7 +290,7 @@ , name_ "newTodo" , onInput UpdateField , onEnter Add - ] [] + ] ] onEnter :: Msg -> Attribute Msg diff --git a/examples/websocket/Main.hs b/examples/websocket/Main.hs --- a/examples/websocket/Main.hs +++ b/examples/websocket/Main.hs @@ -63,7 +63,7 @@ , input_ [ type_ "text" , onInput UpdateMessage , onEnter (SendMessage msg) - ] [] + ] , button_ [ onClick (SendMessage msg) ] [ text (S.pack "Send to echo server") ] , div_ [ ] [ p_ [ ] [ text received | not . S.null $ received ] ] diff --git a/ghcjs-src/Miso.hs b/ghcjs-src/Miso.hs --- a/ghcjs-src/Miso.hs +++ b/ghcjs-src/Miso.hs @@ -51,13 +51,11 @@ :: Eq model => App model action -> model - -> ((action -> IO ()) -> IO (IORef VTree)) + -> (Sink action -> IO (IORef VTree)) -> IO b common App {..} m getView = do -- init Notifier Notify {..} <- newNotify - -- init empty Model - modelRef <- newIORef m -- init empty actions actionsRef <- newIORef S.empty let writeEvent a = void . forkIO $ do @@ -65,7 +63,7 @@ notify -- init Subs forM_ subs $ \sub -> - sub (readIORef modelRef) writeEvent + sub writeEvent -- Hack to get around `BlockedIndefinitelyOnMVar` exception -- that occurs when no event handlers are present on a template -- and `notify` is no longer in scope @@ -79,24 +77,22 @@ -- Process initial action of application writeEvent initialAction -- Program loop, blocking on SkipChan - forever $ wait >> do - -- Apply actions to model - actions <- atomicModifyIORef' actionsRef $ \actions -> (S.empty, actions) - (shouldDraw, effects) <- atomicModifyIORef' modelRef $! \oldModel -> - let (newModel, effects) = - foldl' (foldEffects writeEvent update) - (oldModel, pure ()) actions - in (newModel, (oldModel /= newModel, effects)) - effects - when shouldDraw $ do - newVTree <- - flip runView writeEvent - =<< view <$> readIORef modelRef - oldVTree <- readIORef viewRef - void $ waitForAnimationFrame - (diff mountPoint) (Just oldVTree) (Just newVTree) - atomicWriteIORef viewRef newVTree + let loop !oldModel = wait >> do + -- Apply actions to model + actions <- atomicModifyIORef' actionsRef $ \actions -> (S.empty, actions) + let (Acc newModel effects) = foldl' (foldEffects writeEvent update) + (Acc oldModel (pure ())) actions + effects + when (oldModel /= newModel) $ do + newVTree <- runView (view newModel) writeEvent + oldVTree <- readIORef viewRef + void $ waitForAnimationFrame + (diff mountPoint) (Just oldVTree) (Just newVTree) + atomicWriteIORef viewRef newVTree + loop newModel + loop m + -- | Runs an isomorphic miso application -- Assumes the pre-rendered DOM is already present miso :: (HasURI model, Eq model) => App model action -> IO () @@ -123,13 +119,15 @@ -- | Helper foldEffects - :: (action -> IO ()) + :: Sink action -> (action -> model -> Effect action model) - -> (model, IO ()) -> action -> (model, IO ()) -foldEffects sink update = \(!model, !as) action -> + -> Acc model -> action -> Acc model +foldEffects sink update = \(Acc model as) action -> case update action model of - Effect newModel effs -> (newModel, newAs) + Effect newModel effs -> Acc newModel newAs where newAs = as >> do forM_ effs $ \eff -> - void $ forkIO (sink =<< eff) + void $ forkIO (eff sink) + +data Acc model = Acc !model !(IO ()) diff --git a/ghcjs-src/Miso/Effect.hs b/ghcjs-src/Miso/Effect.hs --- a/ghcjs-src/Miso/Effect.hs +++ b/ghcjs-src/Miso/Effect.hs @@ -11,10 +11,11 @@ module Miso.Effect.Storage , module Miso.Effect.XHR , module Miso.Effect.DOM -, Effect (..) +, Effect (..), Sub, Sink , noEff , (<#) , (#>) +, effectSub ) where import Data.Bifunctor @@ -25,12 +26,20 @@ -- | An effect represents the results of an update action. -- --- It consists of the updated model and a list of actions. Each action --- is run in a new thread so there is no risk of accidentally --- blocking the application. -data Effect action model - = Effect model [IO action] +-- It consists of the updated model and a list of subscriptions. Each 'Sub' is +-- run in a new thread so there is no risk of accidentally blocking the +-- application. +data Effect action model = Effect model [Sub action] +-- | Type synonym for constructing event subscriptions. +-- +-- The 'Sink' callback is used to dispatch actions which are then fed +-- back to the 'update' function. +type Sub action = Sink action -> IO () + +-- | Function to asynchronously dispatch actions to the 'update' function. +type Sink action = action -> IO () + instance Functor (Effect action) where fmap f (Effect m acts) = Effect (f m) acts @@ -45,7 +54,7 @@ Effect m' acts' -> Effect m' (acts ++ acts') instance Bifunctor Effect where - bimap f g (Effect m acts) = Effect (g m) (map (fmap f) acts) + bimap f g (Effect m acts) = Effect (g m) (map (\act -> \sink -> act (sink . f)) acts) -- | Smart constructor for an 'Effect' with no actions. noEff :: model -> Effect action model @@ -53,8 +62,19 @@ -- | Smart constructor for an 'Effect' with exactly one action. (<#) :: model -> IO action -> Effect action model -(<#) m a = Effect m [a] +(<#) m a = effectSub m $ \sink -> a >>= sink -- | `Effect` smart constructor, flipped (#>) :: IO action -> model -> Effect action model (#>) = flip (<#) + +-- | Like '<#' but schedules a subscription which is an IO computation which has +-- access to a 'Sink' which can be used to asynchronously dispatch actions to +-- the 'update' function. +-- +-- A use-case is scheduling an IO computation which creates a 3rd-party JS +-- widget which has an associated callback. The callback can then call the sink +-- to turn events into actions. To do this without accessing a sink requires +-- going via a @'Sub'scription@ which introduces a leaky-abstraction. +effectSub :: model -> Sub action -> Effect action model +effectSub model sub = Effect model [sub] diff --git a/ghcjs-src/Miso/Html/Internal.hs b/ghcjs-src/Miso/Html/Internal.hs --- a/ghcjs-src/Miso/Html/Internal.hs +++ b/ghcjs-src/Miso/Html/Internal.hs @@ -69,22 +69,15 @@ import JavaScript.Object import JavaScript.Object.Internal (Object (Object)) import qualified JavaScript.Array as JSArray -import JavaScript.Array.Internal (SomeJSArray(..)) import Servant.API +import Miso.Effect (Sub) import Miso.Event.Decoder import Miso.Event.Types import Miso.String +import Miso.Effect (Sink) import Miso.FFI --- | Type synonym for constructing event subscriptions. --- --- The first argument passed to a subscription provides a way to --- access the current value of the model (without blocking). The --- callback is used to dispatch actions which are then fed back to the --- @update@ function. -type Sub action model = IO model -> (action -> IO ()) -> IO () - -- | Virtual DOM implemented as a JavaScript `Object`. -- Used for diffing, patching and event delegation. -- Not meant to be constructed directly, see `View` instead. @@ -92,7 +85,7 @@ -- | Core type for constructing a `VTree`, use this instead of `VTree` directly. newtype View action = View { - runView :: (action -> IO ()) -> IO VTree + runView :: Sink action -> IO VTree } deriving Functor -- | For constructing type-safe links @@ -205,11 +198,11 @@ -- | Attribute of a vnode in a `View`. -- --- The callback can be used to dispatch actions which are fed back to +-- The 'Sink' callback can be used to dispatch actions which are fed back to -- the @update@ function. This is especially useful for event handlers -- like the @onclick@ attribute. The second argument represents the -- vnode the attribute is attached to. -newtype Attribute action = Attribute ((action -> IO ()) -> Object -> IO ()) +newtype Attribute action = Attribute (Sink action -> Object -> IO ()) -- | @prop k v@ is an attribute that will set the attribute @k@ of the DOM node associated with the vnode -- to @v@. 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 @@ -83,8 +83,8 @@ chan = unsafePerformIO newNotify -- | Subscription for `popState` events, from the History API -uriSub :: (URI -> action) -> Sub action model -uriSub = \f _ sink -> do +uriSub :: (URI -> action) -> Sub action +uriSub = \f sink -> do void.forkIO.forever $ do wait chan >> do sink =<< f <$> getURI diff --git a/ghcjs-src/Miso/Subscription/Keyboard.hs b/ghcjs-src/Miso/Subscription/Keyboard.hs --- a/ghcjs-src/Miso/Subscription/Keyboard.hs +++ b/ghcjs-src/Miso/Subscription/Keyboard.hs @@ -62,22 +62,22 @@ check = any (`S.member` set) -- | Maps `Arrows` onto a Keyboard subscription -arrowsSub :: (Arrows -> action) -> Sub action model +arrowsSub :: (Arrows -> action) -> Sub action arrowsSub = directionSub ([38], [40], [37], [39]) -- | Maps `WASD` onto a Keyboard subscription for directions -wasdSub :: (Arrows -> action) -> Sub action model +wasdSub :: (Arrows -> action) -> Sub action wasdSub = directionSub ([87], [83], [65], [68]) -- | Maps a specified list of keys to directions (up, down, left, right) directionSub :: ([Int], [Int], [Int], [Int]) -> (Arrows -> action) - -> Sub action model + -> Sub action directionSub dirs = keyboardSub . (. toArrows dirs) -- | Returns subscription for Keyboard -keyboardSub :: (Set Int -> action) -> Sub action model -keyboardSub f _ sink = do +keyboardSub :: (Set Int -> action) -> Sub action +keyboardSub f sink = do keySetRef <- newIORef mempty windowAddEventListener "keyup" =<< keyUpCallback keySetRef windowAddEventListener "keydown" =<< keyDownCallback keySetRef @@ -97,4 +97,3 @@ let !new = S.delete key keys in (new, new) sink (f newKeys) - diff --git a/ghcjs-src/Miso/Subscription/Mouse.hs b/ghcjs-src/Miso/Subscription/Mouse.hs --- a/ghcjs-src/Miso/Subscription/Mouse.hs +++ b/ghcjs-src/Miso/Subscription/Mouse.hs @@ -21,11 +21,10 @@ -- | Captures mouse coordinates as they occur and writes them to -- an event sink -mouseSub :: ((Int,Int) -> action) -> Sub action model -mouseSub f _ = \sink -> do +mouseSub :: ((Int,Int) -> action) -> Sub action +mouseSub f = \sink -> do windowAddEventListener "mousemove" =<< do asyncCallback1 $ \mouseEvent -> do Just x <- fromJSVal =<< getProp "clientX" (Object mouseEvent) Just y <- fromJSVal =<< getProp "clientY" (Object mouseEvent) sink $ f (x,y) - diff --git a/ghcjs-src/Miso/Subscription/SSE.hs b/ghcjs-src/Miso/Subscription/SSE.hs --- a/ghcjs-src/Miso/Subscription/SSE.hs +++ b/ghcjs-src/Miso/Subscription/SSE.hs @@ -25,8 +25,8 @@ import Miso.String -- | Server-sent events Subscription -sseSub :: FromJSON msg => MisoString -> (SSE msg -> action) -> Sub action model -sseSub url f _ = \sink -> do +sseSub :: FromJSON msg => MisoString -> (SSE msg -> action) -> Sub action +sseSub url f = \sink -> do es <- newEventSource url onMessage es =<< do asyncCallback1 $ \val -> do @@ -66,4 +66,3 @@ -- | Test URL -- http://sapid.sourceforge.net/ssetest/webkit.events.php -- var source = new EventSource("demo_sse.php"); - diff --git a/ghcjs-src/Miso/Subscription/WebSocket.hs b/ghcjs-src/Miso/Subscription/WebSocket.hs --- a/ghcjs-src/Miso/Subscription/WebSocket.hs +++ b/ghcjs-src/Miso/Subscription/WebSocket.hs @@ -70,8 +70,8 @@ => URL -> Protocols -> (WebSocket m -> action) - -> Sub action model -websocketSub (URL u) (Protocols ps) f getModel sink = do + -> Sub action +websocketSub (URL u) (Protocols ps) f sink = do socket <- createWebSocket u ps writeIORef websocket (Just socket) void . forkIO $ handleReconnect @@ -103,7 +103,7 @@ if status == 3 then do unless (code == Just CLOSE_NORMAL) $ - websocketSub (URL u) (Protocols ps) f getModel sink + websocketSub (URL u) (Protocols ps) f sink else handleReconnect -- | Sends message to a websocket server diff --git a/ghcjs-src/Miso/Subscription/Window.hs b/ghcjs-src/Miso/Subscription/Window.hs --- a/ghcjs-src/Miso/Subscription/Window.hs +++ b/ghcjs-src/Miso/Subscription/Window.hs @@ -21,8 +21,8 @@ -- | Captures window coordinates changes as they occur and writes them to -- an event sink -windowSub :: ((Int, Int) -> action) -> Sub action model -windowSub f _ = \sink -> do +windowSub :: ((Int, Int) -> action) -> Sub action +windowSub f = \sink -> do sink . f =<< (,) <$> windowInnerHeight <*> windowInnerWidth windowAddEventListener "resize" =<< do asyncCallback1 $ \windowEvent -> do @@ -30,4 +30,3 @@ Just w <- fromJSVal =<< getProp "innerWidth" (Object target) Just h <- fromJSVal =<< getProp "innerHeight" (Object target) sink $ f (h, w) - 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 @@ -15,6 +15,7 @@ , fromTransition , toTransition , scheduleIO + , scheduleSub ) where import Control.Monad.Trans.Class (lift) @@ -34,7 +35,7 @@ -- See the 'Transition' monad for succinctly expressing model transitions. , view :: model -> View action -- ^ Function to draw `View` - , subs :: [ Sub action model ] + , subs :: [ Sub action ] -- ^ List of subscriptions to run during application lifetime , events :: M.Map MisoString Bool -- ^ List of delegated events that the body element will listen for @@ -72,7 +73,7 @@ -- , ... -- } -- @ -type Transition action model = StateT model (Writer [IO action]) +type Transition action model = StateT model (Writer [Sub action]) -- | Convert a @Transition@ computation to a function that can be given to 'update'. fromTransition @@ -93,4 +94,16 @@ -- Note that multiple IO action can be scheduled using -- @Control.Monad.Writer.Class.tell@ from the @mtl@ library. scheduleIO :: IO action -> Transition action model () -scheduleIO ioAction = lift $ tell [ ioAction ] +scheduleIO ioAction = scheduleSub $ \sink -> ioAction >>= sink + +-- | Like 'scheduleIO' but schedules a subscription which is an IO +-- computation that has access to a 'Sink' which can be used to +-- asynchronously dispatch actions to the 'update' function. +-- +-- A use-case is scheduling an IO computation which creates a +-- 3rd-party JS widget which has an associated callback. The callback +-- can then call the sink to turn events into actions. To do this +-- without accessing a sink requires going via a @'Sub'scription@ +-- which introduces a leaky-abstraction. +scheduleSub :: Sub action -> Transition action model () +scheduleSub sub = lift $ tell [ sub ] diff --git a/miso.cabal b/miso.cabal --- a/miso.cabal +++ b/miso.cabal @@ -1,5 +1,5 @@ name: miso -version: 0.14.0.0 +version: 0.15.0.0 category: Web, Miso, Data Structures license: BSD3 license-file: LICENSE diff --git a/src/Miso/Html/Element.hs b/src/Miso/Html/Element.hs --- a/src/Miso/Html/Element.hs +++ b/src/Miso/Html/Element.hs @@ -251,16 +251,16 @@ h6_ = nodeHtml "h6" -- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/hr -hr_ :: [Attribute action] -> [View action] -> View action -hr_ = nodeHtml "hr" +hr_ :: [Attribute action] -> View action +hr_ = flip (nodeHtml "hr") [] -- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/pre pre_ :: [Attribute action] -> [View action] -> View action pre_ = nodeHtml "pre" -- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/input -input_ :: [Attribute action] -> [View action] -> View action -input_ = nodeHtml "input" +input_ :: [Attribute action] -> View action +input_ = flip (nodeHtml "input") [] -- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/label label_ :: [Attribute action] -> [View action] -> View action @@ -288,8 +288,8 @@ bdo_ :: [Attribute action] -> [View action] -> View action bdo_ = nodeHtml "bdo" -- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/wbr -wbr_ :: [Attribute action] -> [View action] -> View action -wbr_ = nodeHtml "wbr" +wbr_ :: [Attribute action] -> View action +wbr_ = flip (nodeHtml "wbr") [] -- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/details details_ :: [Attribute action] -> [View action] -> View action details_ = nodeHtml "details" @@ -336,20 +336,20 @@ video_ :: [Attribute action] -> [View action] -> View action video_ = nodeHtml "video" -- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/source -source_ :: [Attribute action] -> [View action] -> View action -source_ = nodeHtml "source" +source_ :: [Attribute action] -> View action +source_ = flip (nodeHtml "source") [] -- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/track -track_ :: [Attribute action] -> [View action] -> View action -track_ = nodeHtml "track" +track_ :: [Attribute action] -> View action +track_ = flip (nodeHtml "track") [] -- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/embed -embed_ :: [Attribute action] -> [View action] -> View action -embed_ = nodeHtml "embed" +embed_ :: [Attribute action] -> View action +embed_ = flip (nodeHtml "embed") [] -- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/object object_ :: [Attribute action] -> [View action] -> View action object_ = nodeHtml "object" -- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/param -param_ :: [Attribute action] -> [View action] -> View action -param_ = nodeHtml "param" +param_ :: [Attribute action] -> View action +param_ = flip (nodeHtml "param") [] -- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/ins ins_ :: [Attribute action] -> [View action] -> View action ins_ = nodeHtml "ins" @@ -387,8 +387,8 @@ colgroup_ :: [Attribute action] -> [View action] -> View action colgroup_ = nodeHtml "colgroup" -- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/col -col_ :: [Attribute action] -> [View action] -> View action -col_ = nodeHtml "col" +col_ :: [Attribute action] -> View action +col_ = flip (nodeHtml "col") [] -- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/nav nav_ :: [Attribute action] -> [View action] -> View action nav_ = nodeHtml "nav" @@ -423,8 +423,8 @@ dd_ :: [Attribute action] -> [View action] -> View action dd_ = nodeHtml "dd" -- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/img -img_ :: [Attribute action] -> [View action] -> View action -img_ = nodeHtml "img" +img_ :: [Attribute action] -> View action +img_ = flip (nodeHtml "img") [] -- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/iframe iframe_ :: [Attribute action] -> [View action] -> View action iframe_ = nodeHtml "iframe" @@ -450,8 +450,8 @@ sup_ :: [Attribute action] -> [View action] -> View action sup_ = nodeHtml "sup" -- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/br -br_ :: [Attribute action] -> [View action] -> View action -br_ = nodeHtml "br" +br_ :: [Attribute action] -> View action +br_ = flip (nodeHtml "br") [] -- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/ol ol_ :: [Attribute action] -> [View action] -> View action ol_ = nodeHtml "ol" @@ -480,5 +480,5 @@ script_ :: [Attribute action] -> [View action] -> View action script_ = nodeHtml "script" -- | https://developer.mozilla.org/en-US/docs/Web/HTML/Element/link -link_ :: [Attribute action] -> [View action] -> View action -link_ = nodeHtml "link" +link_ :: [Attribute action] -> View action +link_ = flip (nodeHtml "link") []