diff --git a/app/App.hs b/app/App.hs index 0bac028..02c6388 100644 --- a/app/App.hs +++ b/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" diff --git a/app/Main.hs b/app/Main.hs index 3f1a49c..65e4d46 100644 --- a/app/Main.hs +++ b/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 diff --git a/app/SimpleCounter.hs b/app/SimpleCounter.hs index 5ce3d12..89d8b2d 100644 --- a/app/SimpleCounter.hs +++ b/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) diff --git a/app/Snake.hs b/app/Snake.hs index 81bcba9..af87e24 100644 --- a/app/Snake.hs +++ b/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)) diff --git a/app/TodoMVC.hs b/app/TodoMVC.hs index 99bc835..44505a3 100644 --- a/app/TodoMVC.hs +++ b/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" ] diff --git a/app/XHR.hs b/app/XHR.hs index c26e4ac..9a2ac30 100644 --- a/app/XHR.hs +++ b/app/XHR.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE RecordWildCards #-} @@ -5,20 +6,23 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +#ifdef wasi_HOST_OS + module XHR (start) where -- slightly adapted from https://github.com/dmjio/miso/blob/master/examples/xhr/Main.hs import Control.Monad.IO.Class import Data.Aeson -import qualified Data.Map as M import Data.Maybe import qualified Data.Text as T import GHC.Generics import GHC.Wasm.Prim +import Language.Javascript.JSaddle (JSM) import Miso hiding (defaultOptions) -import Miso.String +import Miso.String hiding (JSString) +import qualified Miso.Style as CSS -- | Model data Model @@ -36,20 +40,21 @@ data Action -- | Main entry point start :: JSM () start = do - startApp App { model = Model Nothing - , initialAction = NoOp + startComponent Component { model = Model Nothing + , initialAction = Just NoOp , mountPoint = Nothing , .. } where - update = updateModel + update = \a -> get >>= updateModel a events = defaultEvents subs = [] view = viewModel logLevel = Off + styles = [] -- | Update your model -updateModel :: Action -> Model -> Effect Action Model +updateModel :: Action -> Model -> Effect Model Action updateModel FetchGitHub m = m <# do SetGitHub <$> getGitHubAPIInfo updateModel (SetGitHub apiInfo) m = @@ -60,7 +65,7 @@ updateModel NoOp m = noEff m viewModel :: Model -> View Action viewModel Model {..} = view where - view = div_ [ style_ $ M.fromList [ + view = div_ [ CSS.style_ [ (pack "text-align", pack "center") , (pack "margin", pack "200px") ] @@ -146,3 +151,7 @@ getGitHubAPIInfo = do -- via ghcjs-dom, servant-jsaddle or servant-client-js. foreign import javascript safe "const r = await fetch($1); return r.text();" js_fetch :: JSString -> IO JSString + +#else +module XHR () where +#endif diff --git a/cabal.project b/cabal.project index 4adff71..56b7ed5 100644 --- a/cabal.project +++ b/cabal.project @@ -1,6 +1,6 @@ packages: . hs2048 -index-state: 2025-04-03T07:26:54Z +index-state: 2025-06-09T12:19:05Z allow-newer: all:base @@ -18,3 +18,8 @@ if arch(wasm32) package aeson flags: -ordered-keymap + +source-repository-package + type: git + location: https://github.com/dmjio/miso + tag: da664f2c33344f545d4fd1c9b2f3c6cbf91c9068 diff --git a/ghc-wasm-miso-examples.cabal b/ghc-wasm-miso-examples.cabal index bd061f1..d57f320 100644 --- a/ghc-wasm-miso-examples.cabal +++ b/ghc-wasm-miso-examples.cabal @@ -11,7 +11,6 @@ executable ghc-wasm-miso-examples , ghc-experimental , hs2048 , jsaddle - , jsaddle-wasm , miso >= 1.8.7.0 , mtl , random @@ -26,4 +25,5 @@ executable ghc-wasm-miso-examples Snake TodoMVC XHR - ghc-options: -no-hs-main -optl-mexec-model=reactor "-optl-Wl,--export=hs_start" + if arch(wasm32) + ghc-options: -no-hs-main -optl-mexec-model=reactor "-optl-Wl,--export=hs_start" diff --git a/hs2048/src/InputModel.hs b/hs2048/src/InputModel.hs index cf54891..146c4a0 100644 --- a/hs2048/src/InputModel.hs +++ b/hs2048/src/InputModel.hs @@ -21,7 +21,6 @@ data Action | Sync | TouchStart TouchEvent | TouchEnd TouchEvent - | NoOp toDirection :: Arrows -> Direction toDirection arr@Arrows {..} = diff --git a/hs2048/src/Logic.hs b/hs2048/src/Logic.hs index 18e960e..5d44c37 100644 --- a/hs2048/src/Logic.hs +++ b/hs2048/src/Logic.hs @@ -148,24 +148,22 @@ step state@GameState {..} = | direction /= None -> stepSlide state | otherwise -> state -updateGameState :: Action -> GameState -> Effect Action GameState -updateGameState Sync state@GameState {..} = - noEff state {drawScoreAdd = scoreAdd} -updateGameState NewGame state = newGame state <# pure Sync -updateGameState Continue state = noEff state {gameProgress = Continuing} -updateGameState (GetArrows arr) state = step nState <# pure Sync - where - nState = state {direction = toDirection arr} -updateGameState (TouchStart (TouchEvent touch)) state = - state {prevTouch = Just touch} <# do +updateGameState :: Action -> Effect GameState Action +updateGameState Sync = modify $ \state@GameState {..} -> state {drawScoreAdd = scoreAdd} +updateGameState NewGame = modify newGame >> issue Sync +updateGameState Continue = modify $ \state -> state {gameProgress = Continuing} +updateGameState (GetArrows arr) = do + modify $ \state -> step $ state {direction = toDirection arr} + issue Sync +updateGameState (TouchStart (TouchEvent touch)) = do + modify $ \state -> state {prevTouch = Just touch} -- putStrLn "Touch did start" - pure NoOp -updateGameState (TouchEnd (TouchEvent touch)) state = - state {prevTouch = Nothing} <# do +updateGameState (TouchEnd (TouchEvent touch)) = do + state <- get + put state {prevTouch = Nothing} -- putStrLn "Touch did end" - let (GetArrows x) = - swipe (client . fromJust . prevTouch $ state) (client touch) + let (GetArrows x) = + swipe (Touch.client . fromJust . prevTouch $ state) (Touch.client touch) -- print x - pure $ swipe (client . fromJust . prevTouch $ state) (client touch) -updateGameState Init state = state <# pure NewGame -updateGameState _ state = noEff state + issue $ swipe (Touch.client . fromJust . prevTouch $ state) (Touch.client touch) +updateGameState Init = issue NewGame diff --git a/hs2048/src/Rendering.hs b/hs2048/src/Rendering.hs index 7d94662..41a8f98 100644 --- a/hs2048/src/Rendering.hs +++ b/hs2048/src/Rendering.hs @@ -10,6 +10,7 @@ import InputModel import Miso import Miso.String (MisoString, ms) import qualified Miso.String as S +import qualified Miso.Style as CSS import Touch black :: MisoString @@ -211,7 +212,7 @@ display model = where preview = div_ - [ style_ . M.fromList $ + [ CSS.style_ [("left", "100px"), ("width", "100px"), ("position", "absolute")] ] [text . S.pack . show $ model] diff --git a/hs2048/src/Touch.hs b/hs2048/src/Touch.hs index 3fe22e1..1834e4f 100644 --- a/hs2048/src/Touch.hs +++ b/hs2048/src/Touch.hs @@ -42,13 +42,13 @@ touchDecoder = Decoder {..} decoder = parseJSON onTouchMove :: (TouchEvent -> action) -> Attribute action -onTouchMove = on "touchmove" touchDecoder +onTouchMove f = on "touchmove" touchDecoder $ const . f onTouchStart :: (TouchEvent -> action) -> Attribute action -onTouchStart = on "touchstart" touchDecoder +onTouchStart f = on "touchstart" touchDecoder $ const . f onTouchEnd :: (TouchEvent -> action) -> Attribute action -onTouchEnd = on "touchend" touchDecoder +onTouchEnd f = on "touchend" touchDecoder $ const . f touchEvents :: M.Map MisoString Bool touchEvents = diff --git a/hs2048/src/TwoZeroFourEight.hs b/hs2048/src/TwoZeroFourEight.hs index 92fb197..f590635 100644 --- a/hs2048/src/TwoZeroFourEight.hs +++ b/hs2048/src/TwoZeroFourEight.hs @@ -13,6 +13,7 @@ import System.Random import GameModel import InputModel +import Language.Javascript.JSaddle (JSM) import Logic import Rendering import Touch @@ -22,9 +23,9 @@ start :: JSM () start = do stdGen <- getStdGen let (seed, _) = random stdGen - startApp App {model = defaultGame {randomSeed = seed}, ..} + startComponent Component {model = defaultGame {randomSeed = seed}, ..} where - initialAction = Init -- initial action to be executed on application load + initialAction = Just Init -- initial action to be executed on application load model = defaultGame -- initial model update = updateGameState -- update function view = display -- view function @@ -32,3 +33,4 @@ start = do mountPoint = Nothing -- defaults to body subs = [arrowsSub GetArrows] -- empty subscription list logLevel = Off + styles = []