diff --git a/app/App.hs b/app/App.hs index 0bac028..c6b9f0d 100644 --- a/app/App.hs +++ b/app/App.hs @@ -1,19 +1,58 @@ -module App (start) where +{-# LANGUAGE CPP #-} +module App (start, App(..)) where + +#ifdef wasi_HOST_OS import GHC.Wasm.Prim import Language.Javascript.JSaddle (JSM) +#else +import Language.Javascript.JSaddle +#endif + +import Data.Text.Lazy (Text) import SimpleCounter qualified import Snake qualified import TodoMVC qualified import TwoZeroFourEight qualified import XHR qualified -start :: JSString -> JSM () +data App = App + { name :: Text + , stylesheets :: [Text] + , app :: JSM () + } + +start :: JSString -> App start e = - case fromJSString e of - "simplecounter" -> SimpleCounter.start - "snake" -> Snake.start - "todomvc" -> TodoMVC.start - "xhr" -> XHR.start - "2048" -> TwoZeroFourEight.start - _ -> fail "unknown example" + case fromJSString e :: String of + "simplecounter" -> + App + { name = "SimpleCounter" + , stylesheets = [] + , app = SimpleCounter.start + } + "snake" -> + App + { name = "Snake" + , stylesheets = [] + , app = Snake.start + } + "todomvc" -> + App + { name = "TodoMVC" + , stylesheets = ["todomvc/base.css", "todomvc/index.css"] + , app = TodoMVC.start + } + "xhr" -> + App + { name = "XHR" + , stylesheets = [] + , app = XHR.start + } + "2048" -> + App + { name = "TwoZeroFourEight" + , stylesheets = ["2048/main.css"] + , app = TwoZeroFourEight.start + } + _ -> error "unknown example" diff --git a/app/Main.hs b/app/Main.hs index 3f1a49c..7fbed10 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,10 +1,75 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedRecordDot #-} + +#ifdef wasi_HOST_OS + module MyMain (main) where -import App (start) +import App import GHC.Wasm.Prim import Language.Javascript.JSaddle.Wasm qualified as JSaddle.Wasm foreign export javascript "hs_start" main :: JSString -> IO () main :: JSString -> IO () -main e = JSaddle.Wasm.run $ start e +main e = JSaddle.Wasm.run (start e).app + +#else + +module Main (main) where + +import App +import Data.Text.Lazy qualified as T +import Data.Text.Lazy.Encoding (encodeUtf8) +import Language.Javascript.JSaddle +import Language.Javascript.JSaddle.Warp +import Network.Wai.Application.Static +import System.Environment + +{- TODO +work out how to live-reload on changes to stylesheet +maybe don't use `dist` version... +maybe just a matter of passing right flag to GHCID? +in theory I shouldn't even need to do that - just force a page refresh +is that something we can hook in to? + +open jsaddle PR and use it here as a SRP + +punt: +somehow DRY to match static HTML files +-} +main :: IO () +main = + getArgs >>= \case + -- Note that `debug` works with `cabal repl` but not `cabal run`. + -- The best workflow is to run `ghcid -c "cabal repl ghc-wasm-miso-examples" -W -T ':main simplecounter'`. + [arg] -> + let app = + start + -- "2048" + (toJSString arg) + -- we can't use multiline syntax alongside CPP... + -- "\n\ + -- \\n\ + -- \2048 | Miso example via GHC WASM\n\ + -- \\n\ + -- \" + header = + encodeUtf8 $ + T.unlines $ + [ "" <> app.name <> "" + ] + <> map + (\s -> "") + app.stylesheets + in + -- can't work out how to get non-`debug` version working + -- but I think I prefer this anyway + debugOr + (Just header) + 8000 + app.app + (staticApp (defaultWebAppSettings "frontend/dist")) + _ -> fail "bad args: specify an example, e.g. 2048" + +#endif diff --git a/app/XHR.hs b/app/XHR.hs index c26e4ac..8ea38a6 100644 --- a/app/XHR.hs +++ b/app/XHR.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE RecordWildCards #-} @@ -9,13 +10,19 @@ module XHR (start) where -- slightly adapted from https://github.com/dmjio/miso/blob/master/examples/xhr/Main.hs +#ifdef wasi_HOST_OS +import GHC.Wasm.Prim +#else +import Data.JSString (JSString) +import Language.Javascript.JSaddle (fromJSString, toJSString) +#endif + 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 Miso hiding (defaultOptions) import Miso.String @@ -135,14 +142,19 @@ instance FromJSON APIInfo where getGitHubAPIInfo :: JSM APIInfo getGitHubAPIInfo = do resp <- liftIO $ - T.pack . fromJSString <$> js_fetch (toJSString "https://api.github.com") + T.pack . fromJSString <$> js_fetch (toJSString ("https://api.github.com" :: String)) case eitherDecodeStrictText resp :: Either String APIInfo of Left s -> error s Right j -> pure j +#ifdef wasi_HOST_OS -- We use the WASM JS FFI here to access the more modern fetch API. If you want -- your code to eg also work when compiling with non-cross GHC and using -- jsaddle-warp, you can use fetch or XMLHttpRequest via JSaddle, for example -- 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 +js_fetch :: JSString -> IO JSString +js_fetch = error "not implemented" +#endif diff --git a/cabal.project b/cabal.project index 17bd992..d1485ff 100644 --- a/cabal.project +++ b/cabal.project @@ -1,6 +1,6 @@ packages: . hs2048 -index-state: 2024-10-26T13:27:42Z +index-state: 2024-11-25T21:40:33Z if arch(wasm32) -- Required for TemplateHaskell. When using wasm32-wasi-cabal from @@ -18,5 +18,13 @@ if arch(wasm32) location: https://github.com/amesgen/splitmix tag: 5f5b766d97dc735ac228215d240a3bb90bc2ff75 +else + -- https://github.com/ghcjs/jsaddle/pull/149 + source-repository-package + type: git + location: https://github.com/georgefst/jsaddle + tag: 8ebf96891fe9580fc16e1fe99b0ca503b9cf2ed8 + subdir: jsaddle jsaddle-warp + package aeson flags: -ordered-keymap diff --git a/ghc-wasm-miso-examples.cabal b/ghc-wasm-miso-examples.cabal index d8e3fe1..e898d0e 100644 --- a/ghc-wasm-miso-examples.cabal +++ b/ghc-wasm-miso-examples.cabal @@ -8,11 +8,10 @@ executable ghc-wasm-miso-examples , aeson , base , containers - , ghc-experimental , hs2048 , jsaddle - , jsaddle-wasm , miso + , miso >= 1.8.5.0 , mtl , random , text @@ -26,4 +25,8 @@ 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) + build-depends: ghc-experimental, jsaddle-wasm + ghc-options: -no-hs-main -optl-mexec-model=reactor "-optl-Wl,--export=hs_start" + else + build-depends: jsaddle-warp, wai-app-static, warp, websockets