Use latest Miso and make examples runnable with jsaddle-warp

app/App.hs

@@ -1,19 +1,23 @@
+{-# LANGUAGE CPP #-}
 module App (start) where
 
-import GHC.Wasm.Prim
 import Language.Javascript.JSaddle (JSM)
 import SimpleCounter qualified
 import Snake qualified
 import TodoMVC qualified
 import TwoZeroFourEight qualified
+#ifdef wasi_HOST_OS
 import XHR qualified
+#endif
 
-start :: JSString -> JSM ()
+start :: String -> JSM ()
 start e =
-  case fromJSString e of
+  case e of
     "simplecounter" -> SimpleCounter.start
     "snake" -> Snake.start
     "todomvc" -> TodoMVC.start
+#ifdef wasi_HOST_OS
     "xhr" -> XHR.start
+#endif
     "2048" -> TwoZeroFourEight.start
     _ -> fail "unknown example"

app/Main.hs

@@ -1,10 +1,27 @@
-module MyMain (main) where
+{-# LANGUAGE CPP #-}
+
+#ifdef wasi_HOST_OS
+module MyMain (myMain) where
+#else
+module Main (main) where
+#endif
 
 import App (start)
-import GHC.Wasm.Prim
-import Language.Javascript.JSaddle.Wasm qualified as JSaddle.Wasm
+import Miso qualified
 
-foreign export javascript "hs_start" main :: JSString -> IO ()
+#ifdef wasi_HOST_OS
+import GHC.Wasm.Prim
+#else
+import System.Environment (getArgs)
+#endif
 
-main :: JSString -> IO ()
-main e = JSaddle.Wasm.run $ start e
+#ifdef wasi_HOST_OS
+myMain :: JSString -> IO ()
+myMain e = Miso.run $ start $ fromJSString e
+foreign export javascript "hs_start" myMain :: JSString -> IO ()
+#else
+main :: IO ()
+main = getArgs >>= \case
+    [arg] -> Miso.run $ start arg
+    _ -> fail "bad args: specify an example, e.g. 2048"
+#endif

app/SimpleCounter.hs

@@ -3,15 +3,16 @@
 module SimpleCounter (start) where
 
 import Control.Monad.State.Strict
+import Language.Javascript.JSaddle (JSM)
 import Miso
 import Miso.String (ms)
 
 start :: JSM ()
-start = startApp App {..}
+start = startComponent Component {..}
   where
-    initialAction = 0
+    initialAction = Just 0
     model = 0 :: Int
-    update n = fromTransition do
+    update n = do
       modify' (+ n)
     view n =
       div_
@@ -27,6 +28,7 @@ start = startApp App {..}
     subs = []
     mountPoint = Nothing
     logLevel = Off
+    styles = []
 
 -- https://github.com/dmjio/miso/issues/631
 -- but it seems to work fine!
@@ -36,4 +38,4 @@ onClickPreventDefault a =
     (defaultOptions {preventDefault = True})
     "click"
     emptyDecoder
-    (\() -> a)
+    (\() _ -> a)

app/Snake.hs

@@ -9,12 +9,13 @@ module Snake (start) where
 import           Control.Concurrent
 import           Control.Monad
 import           Control.Monad.IO.Class
-import qualified Data.Map           as M
 import qualified Data.Set           as Set
+import           Language.Javascript.JSaddle (JSM, askJSM, runJSM)
 import           System.Random
 
 import           Miso
 import           Miso.String        (MisoString, ms)
+import qualified Miso.Style         as CSS
 import           Miso.Svg           hiding (height_, id_, style_, width_)
 
 -- | miso-snake: heavily inspired by elm-snake
@@ -29,12 +30,12 @@ cherryRadius = 7.5
 every :: Int -> (Double -> action) -> Sub action
 every n f sink = void . forkJSM . forever $ do
   liftIO $ threadDelay n
-  liftIO . sink =<< f <$> now
+  sink =<< f <$> now
 
 start :: JSM ()
-start = startApp App {..}
+start = startComponent Component {..}
   where
-    initialAction = NoOp
+    initialAction = Nothing
     mountPoint = Nothing
     model  = NotStarted
     update = updateModel
@@ -45,6 +46,7 @@ start = startApp App {..}
              , every 50000 Tick -- 50 ms
              ]
     logLevel = Off
+    styles = []
 
 -- | Model
 data Direction
@@ -85,7 +87,6 @@ data Msg
   | ArrowPress !Arrows
   | KeyboardPress !(Set.Set Int)
   | Spawn !Double !Position
-  | NoOp
 
 -- | Initial Snake
 initSnake :: Snake
@@ -105,7 +106,7 @@ rootBase content = div_ [] [ svg_ [ height_ $ px height
 
 
 textStyle :: Attribute a
-textStyle = style_ $ M.fromList [ ("fill", "green")
+textStyle = CSS.style_ [ ("fill", "green")
                                 , ("stroke", "green")
                                 , ("text-anchor", "middle")
                                 ]
@@ -130,7 +131,7 @@ viewModel Started{..} =
                                 , cy_ $ px y
                                 , rx_ $ px cherryRadius
                                 , ry_ $ px cherryRadius
-                                , style_ $ M.fromList [ ("fill", "red")
+                                , CSS.style_ [ ("fill", "red")
                                                       , ("stroke", "black")
                                                       , ("stroke-width", "2")
                                                       ]
@@ -140,29 +141,31 @@ viewModel Started{..} =
                                    , height_ $ px segmentDim
                                    , x_ $ px x
                                    , y_ $ px y
-                                   , style_ $ M.fromList [ ("fill", color)
+                                   , CSS.style_ $ [ ("fill", color)
                                                          , ("stroke", "black")
                                                          , ("stroke-width", "2")
                                                          ]
                                    ] []
 
 -- | Updates model, optionally introduces side effects
-updateModel :: Msg -> Model -> Effect Msg Model
-updateModel msg NotStarted =
-  case msg of
-       KeyboardPress keys | Set.member 32 keys -> noEff $ Started initSnake Nothing 0
-       _                                       -> noEff NotStarted
-updateModel (ArrowPress arrs) model@Started{..} =
+updateModel :: Msg -> Effect Model Msg
+updateModel msg = get >>= \case
+  NotStarted -> case msg of
+    KeyboardPress keys | Set.member 32 keys -> put $ Started initSnake Nothing 0
+    _                                       -> put NotStarted
+  Started{..} -> updateModel' msg snake cherry score
+updateModel' :: Msg -> Snake -> Cherry -> Score -> Effect Model Msg
+updateModel' (ArrowPress arrs) snake cherry score =
   let newDir = getNewDirection arrs (direction snake)
       newSnake = snake { direction = newDir } in
-  noEff $ model { snake = newSnake }
-updateModel (Spawn chance (randX, randY)) model@Started{}
+  put Started{ snake = newSnake, ..}
+updateModel' (Spawn chance (randX, randY)) snake cherry score
   | chance <= 0.1 =
      let newCherry = spawnCherry randX randY in
-     noEff model { cherry = newCherry }
+     put Started{ cherry = newCherry, ..}
   | otherwise =
-     noEff model
-updateModel (Tick _) model@Started{..} =
+     put Started{..}
+updateModel' (Tick _) snake cherry score =
   let newHead = getNewSegment (shead snake) (direction snake)
       ateCherry = maybe False (isOverlap newHead) cherry
       newTail =
@@ -172,15 +175,15 @@ updateModel (Tick _) model@Started{..} =
       (newCherry, newScore) =
         if ateCherry then (Nothing, score + 1)
                      else (cherry, score)
-      newModel = model { snake = newSnake, cherry = newCherry, score = newScore }
+      newModel = Started{ snake = newSnake, cherry = newCherry, score = newScore }
       gameOver = isGameOver newHead newTail
       in
-  if | gameOver          -> noEff NotStarted
+  if | gameOver          -> put NotStarted
      | cherry == Nothing -> newModel <# do
                                         [chance, xPos, yPos] <- replicateM 3 $ randomRIO (0, 1)
                                         return $ Spawn chance (xPos, yPos)
-     | otherwise         -> noEff newModel
-updateModel _ model = noEff model
+     | otherwise         -> put newModel
+updateModel' _ snake cherry score = put Started{..}
 
 getNewDirection :: Arrows -> Direction -> Direction
 getNewDirection (Arrows arrX arrY) dir
@@ -224,3 +227,8 @@ isOverlap (snakeX, snakeY) (cherryX, cherryY) =
                  )
       distance = sqrt(xd * xd + yd * yd)
   in distance <= (cherryRadius * 2)
+
+forkJSM :: JSM () -> JSM ThreadId
+forkJSM a = do
+  ctx <- askJSM
+  liftIO (forkIO (runJSM a ctx))

app/TodoMVC.hs

@@ -17,11 +17,12 @@ module TodoMVC (start) where
 
 import           Data.Aeson hiding (Object)
 import           Data.Bool
-import qualified Data.Map as M
 import           GHC.Generics
+import           Language.Javascript.JSaddle (JSM)
 import           Miso
 import           Miso.String (MisoString)
 import qualified Miso.String as S
+import qualified Miso.Style as CSS
 
 import           Control.Monad.IO.Class
 
@@ -82,7 +83,7 @@ data Msg
    deriving Show
 
 start :: JSM ()
-start = startApp App { initialAction = NoOp, ..}
+start = startComponent Component { initialAction = Nothing, ..}
   where
     model      = emptyModel
     update     = updateModel
@@ -91,59 +92,61 @@ start = startApp App { initialAction = NoOp, ..}
     mountPoint = Nothing
     subs       = []
     logLevel   = Off
-
-updateModel :: Msg -> Model -> Effect Msg Model
-updateModel NoOp m = noEff m
-updateModel (CurrentTime n) m =
-  m <# do liftIO (print n) >> pure NoOp
-updateModel Add model@Model{..} =
-  noEff model {
+    styles     = []
+
+updateModel :: Msg -> Effect Model Msg
+updateModel NoOp = pure ()
+updateModel (CurrentTime n) =
+  io_ $ liftIO (print n)
+updateModel Add = modify $ \model@Model{..} ->
+  model {
     uid = uid + 1
   , field = mempty
   , entries = entries <> [ newEntry field uid | not $ S.null field ]
   }
-updateModel (UpdateField str) model = noEff model { field = str }
-updateModel (EditingEntry id' isEditing) model@Model{..} =
-  model { entries = newEntries } <# do
-    focus $ S.pack $ "todo-" ++ show id'
-    pure NoOp
-    where
+updateModel (UpdateField str) = modify $ \model -> model { field = str }
+updateModel (EditingEntry id' isEditing) = do
+  modify $ \model@Model{..} ->
+    let
       newEntries = filterMap entries (\t -> eid t == id') $
          \t -> t { editing = isEditing, focussed = isEditing }
-
-updateModel (UpdateEntry id' task) model@Model{..} =
-  noEff model { entries = newEntries }
-    where
-      newEntries =
-        filterMap entries ((==id') . eid) $ \t ->
-           t { description = task }
-
-updateModel (Delete id') model@Model{..} =
-  noEff model { entries = filter (\t -> eid t /= id') entries }
-
-updateModel DeleteComplete model@Model{..} =
-  noEff model { entries = filter (not . completed) entries }
-
-updateModel (Check id' isCompleted) model@Model{..} =
-   model { entries = newEntries } <# eff
-    where
-      eff =
-        liftIO (putStrLn "clicked check") >>
-          pure NoOp
-
+    in
+      model { entries = newEntries }
+  io_ $ focus $ S.pack $ "todo-" ++ show id'
+
+updateModel (UpdateEntry id' task) = modify $ \model@Model{..} ->
+  let
+    newEntries =
+      filterMap entries ((==id') . eid) $ \t ->
+          t { description = task }
+  in
+    model { entries = newEntries }
+
+updateModel (Delete id') = modify $ \model@Model{..} ->
+  model { entries = filter (\t -> eid t /= id') entries }
+
+updateModel DeleteComplete = modify $ \model@Model{..} ->
+  model { entries = filter (not . completed) entries }
+
+updateModel (Check id' isCompleted) = do
+  modify $ \model@Model{..} ->
+    let
       newEntries =
         filterMap entries (\t -> eid t == id') $ \t ->
           t { completed = isCompleted }
+    in
+      model { entries = newEntries }
+  io_ $ liftIO (putStrLn "clicked check")
 
-updateModel (CheckAll isCompleted) model@Model{..} =
-  noEff model { entries = newEntries }
-    where
+updateModel (CheckAll isCompleted) = modify $ \model@Model{..} ->
+    let
       newEntries =
         filterMap entries (const True) $
           \t -> t { completed = isCompleted }
+    in
+      model { entries = newEntries }
 
-updateModel (ChangeVisibility v) model =
-  noEff model { visibility = v }
+updateModel (ChangeVisibility v) = modify $ \model -> model { visibility = v }
 
 filterMap :: [a] -> (a -> Bool) -> (a -> a) -> [a]
 filterMap xs predicate f = go' xs
@@ -171,7 +174,7 @@ viewEntries :: MisoString -> [ Entry ] -> View Msg
 viewEntries visibility entries =
   section_
     [ class_ "main"
-    , style_ $ M.singleton "visibility" cssVisibility
+    , CSS.style_ [("visibility", cssVisibility)]
     ]
     [ input_
         [ class_ "toggle-all"
@@ -201,9 +204,10 @@ viewKeyedEntry :: Entry -> View Msg
 viewKeyedEntry = viewEntry
 
 viewEntry :: Entry -> View Msg
-viewEntry Entry {..} = liKeyed_ (toKey eid)
+viewEntry Entry {..} = li_
     [ class_ $ S.intercalate " " $
        [ "completed" | completed ] <> [ "editing" | editing ]
+    , key_ $ toKey eid
     ]
     [ div_
         [ class_ "view" ]