From ca6d2dae13ad7bf0ebdf5e2b5bee13524ad5e308 Mon Sep 17 00:00:00 2001 From: dmjio Date: Wed, 19 Mar 2025 15:55:23 -0500 Subject: [PATCH 1/9] Make initialAction optional - defaultApp no longer takes 'a' - Refactor examples to account for optionality --- README.md | 10 ++++++---- examples/canvas2d/Main.hs | 2 +- examples/components/Main.hs | 16 ++++++++-------- examples/compose-update/Main.hs | 6 +----- examples/file-reader/Main.hs | 2 +- examples/mario/Main.hs | 22 ++++++---------------- examples/mathml/Main.hs | 24 ++++++------------------ examples/router/Main.hs | 16 +++++----------- examples/simple/Main.hs | 2 +- examples/sse/shared/Common.hs | 23 +++++++---------------- examples/svg/Main.hs | 2 +- examples/three/Main.hs | 16 +++------------- examples/todo-mvc/Main.hs | 2 +- examples/websocket/Main.hs | 2 +- examples/xhr/Main.hs | 2 +- haskell-miso.org/shared/Common.hs | 2 +- sample-app/Main.hs | 4 ++-- src/Miso.hs | 23 ++++++++++++----------- src/Miso/Internal.hs | 2 +- src/Miso/Types.hs | 11 +++++------ 20 files changed, 70 insertions(+), 119 deletions(-) diff --git a/README.md b/README.md index cf18c199..13115650 100644 --- a/README.md +++ b/README.md @@ -270,7 +270,7 @@ main :: IO () main = run (startApp app) ---------------------------------------------------------------------------- app :: App Model Action -app = defaultApp emptyModel updateModel viewModel SayHelloWorld +app = defaultApp emptyModel updateModel viewModel ---------------------------------------------------------------------------- -- | Empty model emptyModel :: Model @@ -281,7 +281,7 @@ updateModel :: Action -> Model -> Effect Action Model updateModel NoOp m = noEff m updateModel AddOne m = noEff (m + 1) updateModel SubtractOne m = noEff (m - 1) -updateModel SayHelloWorld m = m <# NoOp <$ consoleLog "Hello World" +updateModel SayHelloWorld m = m <# NoOp <$ alert "Hello World" ---------------------------------------------------------------------------- -- | Constructs a virtual DOM from a model viewModel :: Model -> View Action @@ -289,6 +289,7 @@ viewModel x = div_ [] [ button_ [ onClick AddOne ] [ text "+" ] , text (ms x) , button_ [ onClick SubtractOne ] [ text "-" ] + , button_ [ onClick SayHelloWorld ] [ text "Alert Hello World!" ] ] ---------------------------------------------------------------------------- ``` @@ -334,9 +335,9 @@ data Action main :: IO () main = run (startApp app) ---------------------------------------------------------------------------- --- | `defaultApp` takes as arguments the initial model, update function, view function and initial action. +-- | `defaultApp` takes as arguments the initial model, update function, view function app :: App Model Action -app = defaultApp emptyModel (fromTransition . updateModel) viewModel SayHelloWorld +app = defaultApp emptyModel (fromTransition . updateModel) viewModel ---------------------------------------------------------------------------- -- | Empty application state emptyModel :: Model @@ -356,6 +357,7 @@ viewModel x = div_ [] [ button_ [ onClick AddOne ] [ text "+" ] , text . ms $ x^.counter , button_ [ onClick SubtractOne ] [ text "-" ] + , button_ [ onClick SayHelloWorld ] [ text "Alert Hello World!" ] ] ---------------------------------------------------------------------------- ``` diff --git a/examples/canvas2d/Main.hs b/examples/canvas2d/Main.hs index b15f41b5..3b1dc183 100644 --- a/examples/canvas2d/Main.hs +++ b/examples/canvas2d/Main.hs @@ -26,7 +26,7 @@ main = run $ do setSrc earth "https://7b40c187-5088-4a99-9118-37d20a2f875e.mdnplay.dev/en-US/docs/Web/API/Canvas_API/Tutorial/Basic_animations/canvas_earth.png" startApp App - { initialAction = GetTime + { initialAction = Just GetTime , update = updateModel (sun, moon, earth) , .. } diff --git a/examples/components/Main.hs b/examples/components/Main.hs index 8584d06e..25fdac21 100644 --- a/examples/components/Main.hs +++ b/examples/components/Main.hs @@ -39,7 +39,10 @@ data MainAction type MainModel = Bool main :: IO () -main = run $ startApp app { logLevel = DebugPrerender } +main = run $ startApp app + { logLevel = DebugPrerender + , subs = [loggerSub "main-app"] + } secs :: Int -> Int secs = (* 1000000) @@ -51,10 +54,7 @@ loggerSub msg = \_ -> consoleLog msg app :: App MainModel MainAction -app = - (defaultApp False updateModel1 viewModel1 MainNoOp) - { subs = [loggerSub "main-app"] - } +app = defaultApp False updateModel1 viewModel1 component2 :: Component Model Action component2 = @@ -120,7 +120,7 @@ updateModel1 SampleChild m = pure MainNoOp counterApp2 :: App Model Action -counterApp2 = defaultApp 0 updateModel2 viewModel2 SayHelloWorld +counterApp2 = defaultApp 0 updateModel2 viewModel2 -- | Updates model, optionally introduces side effects updateModel2 :: Action -> Model -> Effect Action Model @@ -156,7 +156,7 @@ viewModel2 x = ] counterApp3 :: App (Bool, Model) Action -counterApp3 = defaultApp (True, 0) updateModel3 viewModel3 SayHelloWorld +counterApp3 = defaultApp (True, 0) updateModel3 viewModel3 -- | Updates model, optionally introduces side effects updateModel3 :: Action -> (Bool, Model) -> Effect Action (Bool, Model) @@ -199,7 +199,7 @@ viewModel3 (toggle, x) = ] counterApp4 :: App Model Action -counterApp4 = defaultApp 0 updateModel4 viewModel4 SayHelloWorld +counterApp4 = defaultApp 0 updateModel4 viewModel4 -- | Updates model, optionally introduces side effects updateModel4 :: Action -> Model -> Effect Action Model diff --git a/examples/compose-update/Main.hs b/examples/compose-update/Main.hs index 1b0613cd..d0e7f65b 100644 --- a/examples/compose-update/Main.hs +++ b/examples/compose-update/Main.hs @@ -100,15 +100,11 @@ foreign export javascript "hs_start" main :: IO () #endif main :: IO () -main = run $ startApp App{initialAction = NoOp, ..} +main = run $ startApp (defaultApp model update view) where model = (0, 0) update = updateModel view = viewModel - events = defaultEvents - subs = [] - mountPoint = Nothing - logLevel = Off viewModel :: Model -> View Action viewModel (x, y) = diff --git a/examples/file-reader/Main.hs b/examples/file-reader/Main.hs index ba5985e2..a1bf5db7 100644 --- a/examples/file-reader/Main.hs +++ b/examples/file-reader/Main.hs @@ -40,7 +40,7 @@ main = run $ do startApp App { model = Model "" - , initialAction = NoOp + , initialAction = Nothing , .. } where diff --git a/examples/mario/Main.hs b/examples/mario/Main.hs index a19d64bd..760b40ef 100644 --- a/examples/mario/Main.hs +++ b/examples/mario/Main.hs @@ -30,22 +30,12 @@ main :: IO () main = run $ do time <- now let m = mario{time = time} - startApp - App - { model = m - , initialAction = NoOp - , .. - } - where - update = updateMario - view = display - events = defaultEvents - subs = - [ arrowsSub GetArrows - , windowCoordsSub WindowCoords - ] - mountPoint = Nothing - logLevel = Off + startApp (defaultApp m updateMario display) + { subs = + [ arrowsSub GetArrows + , windowCoordsSub WindowCoords + ] + } data Model = Model { x :: !Double diff --git a/examples/mathml/Main.hs b/examples/mathml/Main.hs index bfe307ce..0a396877 100644 --- a/examples/mathml/Main.hs +++ b/examples/mathml/Main.hs @@ -1,13 +1,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} - --- \| Haskell module declaration - --- | Haskell language pragma module Main where --- \| Miso framework import import Miso #if defined(wasm32_HOST_ARCH) @@ -16,22 +11,15 @@ foreign export javascript "hs_start" main :: IO () -- | Entry point for a miso application main :: IO () -main = run $ startApp App{..} - where - initialAction = NoOp -- initial action to be executed on application load - model = Main.Empty -- initial model - update = updateModel -- update function - view = viewModel -- view function - events = defaultEvents -- default delegated events - subs = [] -- empty subscription list - mountPoint = Nothing -- mount point for application (Nothing defaults to 'body') - logLevel = Off +main = run $ startApp (defaultApp Main.Empty updateModel viewModel) -data Model = Empty deriving (Eq) +data Model + = Empty + deriving (Eq) data Action - = NoOp - deriving (Show, Eq) + = NoOp + deriving (Show, Eq) -- | Updates model, optionally introduces side effects updateModel :: Action -> Model -> Effect Action Model diff --git a/examples/router/Main.hs b/examples/router/Main.hs index d72329ce..3c40f970 100644 --- a/examples/router/Main.hs +++ b/examples/router/Main.hs @@ -33,17 +33,11 @@ data Action -- | Main entry point main :: IO () -main = - run $ do - currentURI <- getCurrentURI - startApp App{model = Model currentURI, initialAction = NoOp, ..} - where - update = updateModel - events = defaultEvents - subs = [uriSub HandleURI] - view = viewModel - mountPoint = Nothing - logLevel = Off +main = run $ + miso $ \uri -> + (defaultApp (Model uri) updateModel viewModel) + { subs = [uriSub HandleURI] + } -- | Update your model updateModel :: Action -> Model -> Effect Action Model diff --git a/examples/simple/Main.hs b/examples/simple/Main.hs index c3c88f84..b0342651 100644 --- a/examples/simple/Main.hs +++ b/examples/simple/Main.hs @@ -34,7 +34,7 @@ main = run $ startApp app -- | Application definition (uses 'defaultApp' smart constructor) app :: App Model Action -app = defaultApp 0 updateModel viewModel SayHelloWorld +app = defaultApp 0 updateModel viewModel -- | UpdateModels model, optionally introduces side effects updateModel :: Action -> Model -> Effect Action Model diff --git a/examples/sse/shared/Common.hs b/examples/sse/shared/Common.hs index 0ab39e2b..aed1cb1a 100644 --- a/examples/sse/shared/Common.hs +++ b/examples/sse/shared/Common.hs @@ -5,11 +5,9 @@ module Common ( -- * App sse, - -- * Types Model, Action, - -- * Exported links goHome, the404, @@ -64,25 +62,18 @@ goHome :: URI goHome = allLinks' linkURI (Proxy :: Proxy ClientRoutes) sse :: URI -> App Model Action -sse currentURI = - App - { initialAction = NoOp - , model = Model currentURI "No event received" - , .. - } +sse currentURI + = app { subs = + [ sseSub "/sse" handleSseMsg + , uriSub HandleURI + ] + } where - update = updateModel + app = defaultApp (Model currentURI "No event received") updateModel view view m | Right r <- route (Proxy :: Proxy ClientRoutes) home modelUri m = r | otherwise = the404 - events = defaultEvents - subs = - [ sseSub "/sse" handleSseMsg - , uriSub HandleURI - ] - mountPoint = Nothing - logLevel = Off handleSseMsg :: SSE String -> Action handleSseMsg (SSEMessage msg) = ServerMsg msg diff --git a/examples/svg/Main.hs b/examples/svg/Main.hs index ff57e0c3..8e04cbda 100644 --- a/examples/svg/Main.hs +++ b/examples/svg/Main.hs @@ -24,7 +24,7 @@ main = run $ startApp app -- | Application definition (uses 'defaultApp' smart constructor) app :: App Model Action -app = defaultApp emptyModel updateModel viewModel Id +app = defaultApp emptyModel updateModel viewModel emptyModel :: Model emptyModel = Model (0, 0) diff --git a/examples/three/Main.hs b/examples/three/Main.hs index aa2564f6..df3b8c5b 100644 --- a/examples/three/Main.hs +++ b/examples/three/Main.hs @@ -62,19 +62,9 @@ main = run $ do stats <- newStats ref <- newIORef $ Context (pure ()) (pure ()) stats m <- now - startApp - App - { model = m - , initialAction = Init - , update = updateModel ref - , mountPoint = Nothing - , logLevel = Off - , .. - } - where - events = defaultEvents - view = viewModel - subs = [] + startApp (defaultApp m (updateModel ref) viewModel) + { initialAction = Just Init + } viewModel :: Double -> View action viewModel _ = diff --git a/examples/todo-mvc/Main.hs b/examples/todo-mvc/Main.hs index 35886dac..04203b51 100644 --- a/examples/todo-mvc/Main.hs +++ b/examples/todo-mvc/Main.hs @@ -94,7 +94,7 @@ main = run $ startApp app } app :: App Model Msg -app = defaultApp emptyModel updateModel viewModel NoOp +app = defaultApp emptyModel updateModel viewModel updateModel :: Msg -> Model -> Effect Msg Model updateModel NoOp m = noEff m diff --git a/examples/websocket/Main.hs b/examples/websocket/Main.hs index bb5e7356..782c8aa9 100644 --- a/examples/websocket/Main.hs +++ b/examples/websocket/Main.hs @@ -37,7 +37,7 @@ main = run $ startApp app protocols = Protocols [] app :: App Model Action -app = defaultApp emptyModel updateModel appView Id +app = defaultApp emptyModel updateModel appView emptyModel :: Model emptyModel = Model (Message "") mempty diff --git a/examples/xhr/Main.hs b/examples/xhr/Main.hs index b5e4ca34..2c0f3bf4 100644 --- a/examples/xhr/Main.hs +++ b/examples/xhr/Main.hs @@ -34,7 +34,7 @@ main :: IO () main = run (startApp app) app :: App Model Action -app = defaultApp emptyModel updateModel viewModel NoOp +app = defaultApp emptyModel updateModel viewModel emptyModel :: Model emptyModel = Model Nothing diff --git a/haskell-miso.org/shared/Common.hs b/haskell-miso.org/shared/Common.hs index cd25b997..a0bcf189 100644 --- a/haskell-miso.org/shared/Common.hs +++ b/haskell-miso.org/shared/Common.hs @@ -97,7 +97,7 @@ haskellMisoComponent uri } app :: URI -> App Model Action -app currentUri = defaultApp emptyModel updateModel viewModel NoOp +app currentUri = defaultApp emptyModel updateModel viewModel where emptyModel = Model currentUri False viewModel m = diff --git a/sample-app/Main.hs b/sample-app/Main.hs index c927b123..dcbd4b42 100644 --- a/sample-app/Main.hs +++ b/sample-app/Main.hs @@ -29,7 +29,7 @@ main :: IO () main = run (startApp app) ---------------------------------------------------------------------------- app :: App Model Action -app = defaultApp emptyModel updateModel viewModel SayHelloWorld +app = defaultApp emptyModel updateModel viewModel ---------------------------------------------------------------------------- -- | Empty model emptyModel :: Model @@ -40,7 +40,7 @@ updateModel :: Action -> Model -> Effect Action Model updateModel NoOp m = noEff m updateModel AddOne m = noEff (m + 1) updateModel SubtractOne m = noEff (m - 1) -updateModel SayHelloWorld m = m <# NoOp <$ consoleLog "Hello World" +updateModel SayHelloWorld m = m <# NoOp <$ alert "Hello World" ---------------------------------------------------------------------------- -- | Constructs a virtual DOM from a model viewModel :: Model -> View Action diff --git a/src/Miso.hs b/src/Miso.hs index 670d2816..ccf1ec46 100644 --- a/src/Miso.hs +++ b/src/Miso.hs @@ -55,6 +55,7 @@ module Miso , getElementById , focus , blur + , alert ) where ----------------------------------------------------------------------------- import Control.Monad (void) @@ -92,12 +93,12 @@ miso f = withJS $ do app@App {..} <- f <$> getCurrentURI initialize app $ \snk -> do VTree (Object vtree) <- runView Prerender (view model) snk events - let mount = getMountPoint mountPoint - setBodyComponent mount - body <- getBody - copyDOMIntoVTree (logLevel `elem` [DebugPrerender, DebugAll]) body vtree + let name = getMountPoint mountPoint + setBodyComponent name + mount <- getBody + copyDOMIntoVTree (logLevel `elem` [DebugPrerender, DebugAll]) mount vtree viewRef <- liftIO $ newIORef $ VTree (Object vtree) - pure (mount, body, viewRef) + pure (name, mount, viewRef) ----------------------------------------------------------------------------- -- | Runs a miso application -- Initializes application at @mountPoint@ (defaults to // when @Nothing@) @@ -105,12 +106,12 @@ startApp :: Eq model => App model action -> JSM () startApp app@App {..} = withJS $ initialize app $ \snk -> do vtree <- runView DontPrerender (view model) snk events - let mount = getMountPoint mountPoint - setBodyComponent mount - mountEl <- mountElement mount - diff mountEl Nothing (Just vtree) - ref <- liftIO (newIORef vtree) - pure (mount, mountEl, ref) + let name = getMountPoint mountPoint + setBodyComponent name + mount <- mountElement name + diff mount Nothing (Just vtree) + viewRef <- liftIO (newIORef vtree) + pure (name, mount, viewRef) ----------------------------------------------------------------------------- -- | Used when compiling with jsaddle to make miso's JavaScript present in -- the execution context. diff --git a/src/Miso/Internal.hs b/src/Miso/Internal.hs index 027aaf55..189017c0 100644 --- a/src/Miso/Internal.hs +++ b/src/Miso/Internal.hs @@ -92,7 +92,7 @@ initialize App {..} getView = do componentMainThread <- FFI.forkJSM (eventLoop model) registerComponent ComponentState {..} delegator componentMount componentVTree events (logLevel `elem` [DebugEvents, DebugAll]) - componentSink initialAction + forM_ initialAction componentSink pure componentVTree ----------------------------------------------------------------------------- -- | Prerender avoids calling @diff@ diff --git a/src/Miso/Types.hs b/src/Miso/Types.hs index b3ee210b..cf06ecf8 100644 --- a/src/Miso/Types.hs +++ b/src/Miso/Types.hs @@ -67,8 +67,8 @@ data App model action = App , events :: M.Map MisoString Bool -- ^ List of delegated events that the body element will listen for. -- You can start with 'Miso.Event.Types.defaultEvents' and modify as needed. - , initialAction :: action - -- ^ Initial action that is run after the application has loaded + , initialAction :: Maybe action + -- ^ Initial action that is run after the application has loaded, optional since *1.9* , mountPoint :: Maybe MisoString -- ^ Id of the root element for DOM diff. -- If 'Nothing' is provided, the entire document body is used as a mount point. @@ -84,17 +84,16 @@ defaultApp :: model -> (action -> model -> Effect action model) -> (model -> View action) - -> action -> App model action -defaultApp m u v a = App - { initialAction = a - , model = m +defaultApp m u v = App + { model = m , view = v , update = u , subs = [] , events = defaultEvents , mountPoint = Nothing , logLevel = Off + , initialAction = Nothing } ----------------------------------------------------------------------------- -- | Optional Logging for debugging miso internals (useful to see if prerendering is successful) From 61a7ab30b867b63a39a99b42eae3f3b4472e393f Mon Sep 17 00:00:00 2001 From: dmjio Date: Wed, 19 Mar 2025 16:26:40 -0500 Subject: [PATCH 2/9] Put more examples under CI - Puts 2048, flatris, snake, plane under CI - Exposes more-examples top-level --- .github/workflows/main.yml | 3 +++ default.nix | 3 +++ 2 files changed, 6 insertions(+) diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml index 2f6582ae..d434c7a7 100644 --- a/.github/workflows/main.yml +++ b/.github/workflows/main.yml @@ -53,6 +53,9 @@ jobs: - name: (JS) Miso examples run: nix-build -A miso-examples + - name: (JS) Miso third-party examples (2048, flatris, etc.) + run: nix-build -A more-examples + - name: (x86) Miso examples run: nix-build -A miso-examples-ghc diff --git a/default.nix b/default.nix index 07051af3..cd620533 100644 --- a/default.nix +++ b/default.nix @@ -64,4 +64,7 @@ in with pkgs.haskell.lib; # utils inherit (pkgs.haskell.packages.ghc865) miso-from-html; + + # misc. examples + inherit (pkgs) more-examples; } From 8abe79befaac33d6ddb69089bd6cad61b10e17f2 Mon Sep 17 00:00:00 2001 From: dmjio Date: Wed, 19 Mar 2025 16:31:16 -0500 Subject: [PATCH 3/9] Formatting --- default.nix | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/default.nix b/default.nix index cd620533..f014df15 100644 --- a/default.nix +++ b/default.nix @@ -26,8 +26,11 @@ in with pkgs.haskell.lib; miso-examples-ghc = pkgs.haskell.packages.ghc865.miso-examples; inherit (pkgs.haskell.packages.ghc865) sample-app; - # miso wasm examples - # nix-build -A wasmExamples && ./result/bin/build.sh && nix-build -A svgWasm && http-server ./result/svg.wasmexe + # Miso wasm examples + # nix-build -A wasmExamples + # && ./result/bin/build.sh + # && nix-build -A svgWasm + # && http-server ./result/svg.wasmexe inherit (pkgs) wasmExamples svgWasm From 9d192fddca9a11b74c8e951092efd54249723c35 Mon Sep 17 00:00:00 2001 From: dmjio Date: Wed, 19 Mar 2025 18:22:49 -0500 Subject: [PATCH 4/9] Conditionally log events - Was logging all events w/o respect logLevel, fixes that --- src/Miso.hs | 4 ++-- src/Miso/Html/Event.hs | 24 +++++++++++++----------- src/Miso/Internal.hs | 30 ++++++++++++++++-------------- src/Miso/Subscription/Keyboard.hs | 2 +- src/Miso/Types.hs | 2 +- 5 files changed, 33 insertions(+), 29 deletions(-) diff --git a/src/Miso.hs b/src/Miso.hs index ccf1ec46..3de8b159 100644 --- a/src/Miso.hs +++ b/src/Miso.hs @@ -92,7 +92,7 @@ miso :: Eq model => (URI -> App model action) -> JSM () miso f = withJS $ do app@App {..} <- f <$> getCurrentURI initialize app $ \snk -> do - VTree (Object vtree) <- runView Prerender (view model) snk events + VTree (Object vtree) <- runView Prerender (view model) snk logLevel events let name = getMountPoint mountPoint setBodyComponent name mount <- getBody @@ -105,7 +105,7 @@ miso f = withJS $ do startApp :: Eq model => App model action -> JSM () startApp app@App {..} = withJS $ initialize app $ \snk -> do - vtree <- runView DontPrerender (view model) snk events + vtree <- runView DontPrerender (view model) snk logLevel events let name = getMountPoint mountPoint setBodyComponent name mount <- mountElement name diff --git a/src/Miso/Html/Event.hs b/src/Miso/Html/Event.hs index 19ccc613..e10ed3d3 100644 --- a/src/Miso/Html/Event.hs +++ b/src/Miso/Html/Event.hs @@ -65,13 +65,14 @@ module Miso.Html.Event , onPointerMove ) where ----------------------------------------------------------------------------- +import Control.Monad (when) import qualified Data.Map.Strict as M import Data.Aeson.Types (parseEither) import Language.Javascript.JSaddle ----------------------------------------------------------------------------- import Miso.Event import Miso.FFI (syncCallback, set, eventJSON, asyncCallback1, consoleError) -import Miso.Html.Types ( Attribute (Event) ) +import Miso.Types ( Attribute (Event), LogLevel(..) ) import Miso.String (MisoString, unpack) ----------------------------------------------------------------------------- -- | Convenience wrapper for @onWithOptions defaultOptions@. @@ -102,15 +103,16 @@ onWithOptions -> (r -> action) -> Attribute action onWithOptions options eventName Decoder{..} toAction = - Event $ \sink n events -> + Event $ \sink n logLevel events -> case M.lookup eventName events of Nothing -> - consoleError $ mconcat - [ "Event \"" - , eventName - , "\" is not being listened on. To use this event, " - , "add to the 'events' Map in 'App'" - ] + when (logLevel `elem` [ DebugAll, DebugEvents ]) $ + consoleError $ mconcat + [ "Event \"" + , eventName + , "\" is not being listened on. To use this event, " + , "add to the 'events' Map in 'App'" + ] Just _ -> do eventObj <- getProp "events" n eventHandlerObject@(Object eo) <- create @@ -140,7 +142,7 @@ onMounted = onCreated -- otherwise the event may not be reliably called! onCreated :: action -> Attribute action onCreated action = - Event $ \sink object _ -> do + Event $ \sink object _ _ -> do callback <- syncCallback (sink action) set "onCreated" callback object ----------------------------------------------------------------------------- @@ -152,7 +154,7 @@ onCreated action = -- otherwise the event may not be reliably called! onDestroyed :: action -> Attribute action onDestroyed action = - Event $ \sink object _ -> do + Event $ \sink object _ _ -> do callback <- syncCallback (sink action) set "onDestroyed" callback object ----------------------------------------------------------------------------- @@ -173,7 +175,7 @@ onUnmounted = onBeforeDestroyed -- otherwise the event may not be reliably called! onBeforeDestroyed :: action -> Attribute action onBeforeDestroyed action = - Event $ \sink object _ -> do + Event $ \sink object _ _ -> do callback <- syncCallback (sink action) set "onBeforeDestroyed" callback object ----------------------------------------------------------------------------- diff --git a/src/Miso/Internal.hs b/src/Miso/Internal.hs index 189017c0..4b2d2939 100644 --- a/src/Miso/Internal.hs +++ b/src/Miso/Internal.hs @@ -80,7 +80,7 @@ initialize App {..} getView = do oldName <- liftIO $ oldModel `seq` makeStableName oldModel newName <- liftIO $ newModel `seq` makeStableName newModel when (oldName /= newName && oldModel /= newModel) $ do - newVTree <- runView DontPrerender (view newModel) componentSink events + newVTree <- runView DontPrerender (view newModel) componentSink logLevel events oldVTree <- liftIO (readIORef componentVTree) void waitForAnimationFrame diff componentMount (Just oldVTree) (Just newVTree) @@ -209,7 +209,7 @@ drawComponent -> Sink action -> JSM (MisoString, JSVal, IORef VTree) drawComponent prerender name App {..} snk = do - vtree <- runView prerender (view model) snk events + vtree <- runView prerender (view model) snk logLevel events mountElement <- FFI.getComponent name when (prerender == DontPrerender) $ diff mountElement Nothing (Just vtree) ref <- liftIO (newIORef vtree) @@ -240,9 +240,10 @@ runView :: Prerender -> View action -> Sink action + -> LogLevel -> Events -> JSM VTree -runView prerender (Embed attributes (SomeComponent (Component key mount app))) snk _ = do +runView prerender (Embed attributes (SomeComponent (Component key mount app))) snk _ _ = do mountCallback <- do FFI.syncCallback1 $ \continuation -> do vtreeRef <- initialize app (drawComponent prerender mount app) @@ -255,15 +256,15 @@ runView prerender (Embed attributes (SomeComponent (Component key mount app))) s Just componentState -> do unmount mountCallback app componentState vcomp <- createNode "vcomp" HTML key "div" - setAttrs vcomp attributes snk (events app) + setAttrs vcomp attributes snk (logLevel app) (events app) flip (FFI.set "children") vcomp =<< toJSVal ([] :: [MisoString]) FFI.set "data-component-id" mount vcomp flip (FFI.set "mount") vcomp =<< toJSVal mountCallback FFI.set "unmount" unmountCallback vcomp pure (VTree vcomp) -runView prerender (Node ns tag key attrs kids) snk events = do +runView prerender (Node ns tag key attrs kids) snk logLevel events = do vnode <- createNode "vnode" ns key tag - setAttrs vnode attrs snk events + setAttrs vnode attrs snk logLevel events flip (FFI.set "children") vnode =<< ghcjsPure . jsval =<< setKids @@ -271,22 +272,22 @@ runView prerender (Node ns tag key attrs kids) snk events = do where setKids = do kidsViews <- forM kids $ \kid -> do - VTree (Object vtree) <- runView prerender kid snk events + VTree (Object vtree) <- runView prerender kid snk logLevel events pure vtree ghcjsPure (JSArray.fromList kidsViews) -runView _ (Text t) _ _ = do +runView _ (Text t) _ _ _ = do vtree <- create FFI.set "type" ("vtext" :: JSString) vtree FFI.set "text" t vtree pure $ VTree vtree -runView prerender (TextRaw str) snk events = +runView prerender (TextRaw str) snk logLevel events = case parseView str of [] -> - runView prerender (Text (" " :: MisoString)) snk events + runView prerender (Text (" " :: MisoString)) snk logLevel events [parent] -> - runView prerender parent snk events + runView prerender parent snk logLevel events kids -> do - runView prerender (Node HTML "div" Nothing mempty kids) snk events + runView prerender (Node HTML "div" Nothing mempty kids) snk logLevel events ----------------------------------------------------------------------------- -- | @createNode@ -- A helper function for constructing a vtree (used for 'vcomp' and 'vnode') @@ -312,15 +313,16 @@ setAttrs :: Object -> [Attribute action] -> Sink action + -> LogLevel -> Events -> JSM () -setAttrs vnode attrs snk events = +setAttrs vnode attrs snk logLevel events = forM_ attrs $ \case Property k v -> do value <- toJSVal v o <- getProp "props" vnode FFI.set k value (Object o) - Event attr -> attr snk vnode events + Event attr -> attr snk vnode logLevel events Style styles -> do cssObj <- getProp "css" vnode forM_ (M.toList styles) $ \(k,v) -> do diff --git a/src/Miso/Subscription/Keyboard.hs b/src/Miso/Subscription/Keyboard.hs index 659baef5..5be311b9 100644 --- a/src/Miso/Subscription/Keyboard.hs +++ b/src/Miso/Subscription/Keyboard.hs @@ -61,7 +61,7 @@ toArrows (up, down, left, right) set' = Arrows arrowsSub :: (Arrows -> action) -> Sub action arrowsSub = directionSub ([38], [40], [37], [39]) ----------------------------------------------------------------------------- --- | Maps @Arrows@ onto a Keyboard subscription for directions +-- | Maps @Arrows@ onto a Keyboard subscription for directions (W+A+S+D keys) wasdSub :: (Arrows -> action) -> Sub action wasdSub = directionSub ([87], [83], [65], [68]) ----------------------------------------------------------------------------- diff --git a/src/Miso/Types.hs b/src/Miso/Types.hs index cf06ecf8..67176744 100644 --- a/src/Miso/Types.hs +++ b/src/Miso/Types.hs @@ -236,7 +236,7 @@ instance ToKey Word where toKey = Key . toMisoString -- vnode the attribute is attached to. data Attribute action = Property MisoString Value - | Event (Sink action -> Object -> Events -> JSM ()) + | Event (Sink action -> Object -> LogLevel -> Events -> JSM ()) | Style (M.Map MisoString MisoString) deriving Functor ----------------------------------------------------------------------------- From 1850d50a45096c41581d1246fe7df3e757c97ca3 Mon Sep 17 00:00:00 2001 From: dmjio Date: Wed, 19 Mar 2025 18:32:40 -0500 Subject: [PATCH 5/9] Add pointerId to PointerEvent --- src/Miso/Event/Decoder.hs | 1 + src/Miso/Event/Types.hs | 1 + 2 files changed, 2 insertions(+) diff --git a/src/Miso/Event/Decoder.hs b/src/Miso/Event/Decoder.hs index e3bb7b91..a593a3a4 100644 --- a/src/Miso/Event/Decoder.hs +++ b/src/Miso/Event/Decoder.hs @@ -118,6 +118,7 @@ pointerDecoder = Decoder {..} decoder = withObject "pointerDecoder" $ \o -> PointerEvent <$> o .: "pointerType" + <*> o .: "pointerId" <*> o .: "isPrimary" <*> pair o "x" "y" <*> pair o "screenX" "screenY" diff --git a/src/Miso/Event/Types.hs b/src/Miso/Event/Types.hs index 3b9ba868..6bda596d 100644 --- a/src/Miso/Event/Types.hs +++ b/src/Miso/Event/Types.hs @@ -65,6 +65,7 @@ newtype Checked = Checked Bool data PointerEvent = PointerEvent { pointerType :: PointerType + , pointerId :: Int , isPrimary :: Bool , coords :: (Int, Int) -- ^ clientX (or x), clientY (or y) From c7f38f4d73a2ed6381069e00c48e8ee9b542540a Mon Sep 17 00:00:00 2001 From: dmjio Date: Wed, 19 Mar 2025 18:34:29 -0500 Subject: [PATCH 6/9] Add pointercancel to top-level pointerevents Map --- src/Miso/Event/Types.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Miso/Event/Types.hs b/src/Miso/Event/Types.hs index 6bda596d..463ebde8 100644 --- a/src/Miso/Event/Types.hs +++ b/src/Miso/Event/Types.hs @@ -169,6 +169,7 @@ pointerEvents = M.fromList [ ("pointerup", False) , ("pointerdown", False) , ("pointerenter", True) + , ("pointercancel", False) , ("pointerleave", False) , ("pointerover", False) , ("pointerout", False) From 3aa348aabac1661075575e5c721202f1b5fcecfd Mon Sep 17 00:00:00 2001 From: dmjio Date: Wed, 19 Mar 2025 19:30:58 -0500 Subject: [PATCH 7/9] Update example hashes --- nix/haskell/packages/ghcjs/default.nix | 2 +- nix/haskell/packages/source.nix | 24 ++++++++++++------------ 2 files changed, 13 insertions(+), 13 deletions(-) diff --git a/nix/haskell/packages/ghcjs/default.nix b/nix/haskell/packages/ghcjs/default.nix index 08b47cb1..05e128c7 100644 --- a/nix/haskell/packages/ghcjs/default.nix +++ b/nix/haskell/packages/ghcjs/default.nix @@ -10,7 +10,7 @@ self: super: sample-app-js = self.callCabal2nix "app" source.sample-app {}; jsaddle = self.callCabal2nix "jsaddle" "${source.jsaddle}/jsaddle" {}; jsaddle-warp = dontCheck (self.callCabal2nix "jsaddle-warp" "${source.jsaddle}/jsaddle-warp" {}); - flatris = self.callCabal2nix "hs-flatris" source.flatris {}; + flatris = self.callCabal2nix "flatris" source.flatris {}; miso-plane = let miso-plane = self.callCabal2nix "miso-plane" source.miso-plane {}; diff --git a/nix/haskell/packages/source.nix b/nix/haskell/packages/source.nix index 1382af67..4baab3e2 100644 --- a/nix/haskell/packages/source.nix +++ b/nix/haskell/packages/source.nix @@ -37,28 +37,28 @@ in sha256 = "sha256-jyJ7bdz0gNLOSzRxOWcv7eWGIwo3N/O4PcY7HyNF8Fo="; }; flatris = fetchFromGitHub { + owner = "dmjio"; repo = "hs-flatris"; - owner = "ptigwe"; - rev = "5b386e35db143205b4bd8d45cdf98423ed51b713"; - sha256 = "0wll5fizkdmj2hgd71v9klnnr6wxvvf36imchh2chm1slqm78zca"; + rev = "8ff07a4"; + sha256 = "sha256-8CyAxOI/OfPOOidDg2sWBMlPBo8ujtpdnEowVi9QbZc="; }; miso-plane = fetchFromGitHub { - repo = "miso-plane"; owner = "dmjio"; - rev = "a156422f710484ac89d22bd00f09ca706b6a65b8"; - sha256 = "sha256-eQFlZ+9ndWxwMSpOl973Hl3VPmIcnxhWvSsmsyzpyEA="; + repo = "miso-plane"; + rev = "ca840da"; + sha256 = "sha256-uh6gmuVX7YpeVmRShINJm5FJu5QSodxCPb6Yt18LNH4="; }; the2048 = fetchFromGitHub { - repo = "hs2048"; owner = "dmjio"; - rev = "07dbed79a012240bfe19b836b6d445bb16a0602a"; - sha256 = "00rqix5g8s8y6ngxnjskvcyj19g639havn9pgpkdpxp8ni6g7xsm"; + repo = "hs2048"; + rev = "f9feab8"; + sha256 = "sha256-lyR1XvYHvXePORnxG1+a8lEope2iC7WACZ0KmcWKpLk="; }; snake = fetchFromGitHub { - repo = "miso-snake"; owner = "dmjio"; - rev = "c38947cd9417ab8bf8a8d3652d8bf549e35f14af"; - sha256 = "17rdc7fisqgf8zq90c3cw9c08b1qac6wirqmwifw2a0xxbigz4qc"; + repo = "miso-snake"; + rev = "ef3f3fd"; + sha256 = "sha256-w8czHPy9TX4iTTVNc/qg3vUuZiVmTO2KHQK/lsgv3hI="; }; todomvc-common = fetchFromGitHub { owner = "tastejs"; From e46c6d697fb35cc9ba41e1bb5daa0fa9d07d0c26 Mon Sep 17 00:00:00 2001 From: dmjio Date: Wed, 19 Mar 2025 19:42:27 -0500 Subject: [PATCH 8/9] Build serially --- .github/workflows/main.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml index d434c7a7..a74e136a 100644 --- a/.github/workflows/main.yml +++ b/.github/workflows/main.yml @@ -54,7 +54,7 @@ jobs: run: nix-build -A miso-examples - name: (JS) Miso third-party examples (2048, flatris, etc.) - run: nix-build -A more-examples + run: nix-build -A more-examples -j1 - name: (x86) Miso examples run: nix-build -A miso-examples-ghc From 18d365fd1102a106f4d62d52f6158e93c6147476 Mon Sep 17 00:00:00 2001 From: dmjio Date: Wed, 19 Mar 2025 20:08:16 -0500 Subject: [PATCH 9/9] Update source URLs again (support for WASM) --- examples/components/Main.hs | 2 +- nix/haskell/packages/source.nix | 16 ++++++++-------- 2 files changed, 9 insertions(+), 9 deletions(-) diff --git a/examples/components/Main.hs b/examples/components/Main.hs index 25fdac21..e716bc0c 100644 --- a/examples/components/Main.hs +++ b/examples/components/Main.hs @@ -14,7 +14,7 @@ import Miso.String type Model = Int -#if defined(wasm32_HOST_ARCH) +#ifdef WASM foreign export javascript "hs_start" main :: IO () #endif diff --git a/nix/haskell/packages/source.nix b/nix/haskell/packages/source.nix index 4baab3e2..13a9b2e7 100644 --- a/nix/haskell/packages/source.nix +++ b/nix/haskell/packages/source.nix @@ -39,26 +39,26 @@ in flatris = fetchFromGitHub { owner = "dmjio"; repo = "hs-flatris"; - rev = "8ff07a4"; - sha256 = "sha256-8CyAxOI/OfPOOidDg2sWBMlPBo8ujtpdnEowVi9QbZc="; + rev = "4d63a06"; + sha256 = "sha256-wTMOtGQYsAGOW8UJr1V2WoXyo6QwUJIQQ4Fqimm1xfc="; }; miso-plane = fetchFromGitHub { owner = "dmjio"; repo = "miso-plane"; - rev = "ca840da"; - sha256 = "sha256-uh6gmuVX7YpeVmRShINJm5FJu5QSodxCPb6Yt18LNH4="; + rev = "3fd4f3a"; + sha256 = "sha256-jbHn3BqrpuBt7KPvbHHzrG6t2cdDrYyFjHdLyD/vgAg="; }; the2048 = fetchFromGitHub { owner = "dmjio"; repo = "hs2048"; - rev = "f9feab8"; - sha256 = "sha256-lyR1XvYHvXePORnxG1+a8lEope2iC7WACZ0KmcWKpLk="; + rev = "25192e8"; + sha256 = "sha256-sxAqm6VpuBPyFw19KM6/XAi8NmbIm/cYXr7SwAExumE="; }; snake = fetchFromGitHub { owner = "dmjio"; repo = "miso-snake"; - rev = "ef3f3fd"; - sha256 = "sha256-w8czHPy9TX4iTTVNc/qg3vUuZiVmTO2KHQK/lsgv3hI="; + rev = "712b91f"; + sha256 = "sha256-kpI4aBnj5ehoRJAazMM+oHg9fj3XA69sP5bTk/pvFtQ="; }; todomvc-common = fetchFromGitHub { owner = "tastejs";