Make examples runnable with jsaddle-warp

tweag · Nov 6, 2024 · 14a29ad · 14a29ad
1 parent 29f97c9
commit 14a29ad
Show file tree

Hide file tree

Showing 4 changed files with 51 additions and 6 deletions.
diff --git a/app/App.hs b/app/App.hs
@@ -1,7 +1,14 @@
+{-# LANGUAGE CPP #-}
+
 module App (start) where
 
+#ifdef wasi_HOST_OS
 import GHC.Wasm.Prim
 import Language.Javascript.JSaddle (JSM)
+#else
+import Language.Javascript.JSaddle
+#endif
+
 import SimpleCounter qualified
 import Snake qualified
 import TodoMVC qualified
@@ -10,7 +17,7 @@ import XHR qualified
 
 start :: JSString -> JSM ()
 start e =
-  case fromJSString e of
+  case fromJSString e :: String of
     "simplecounter" -> SimpleCounter.start
     "snake" -> Snake.start
     "todomvc" -> TodoMVC.start

diff --git a/app/Main.hs b/app/Main.hs
@@ -1,3 +1,7 @@
+{-# LANGUAGE CPP #-}
+
+#ifdef wasi_HOST_OS
+
 module MyMain (main) where
 
 import App (start)
@@ -8,3 +12,23 @@ foreign export javascript "hs_start" main :: JSString -> IO ()
 
 main :: JSString -> IO ()
 main e = JSaddle.Wasm.run $ start e
+
+#else
+
+module Main (main) where
+
+import App (start)
+import Language.Javascript.JSaddle
+import Language.Javascript.JSaddle.Warp
+import Network.Wai.Handler.Warp
+import Network.WebSockets
+import System.Environment
+
+main :: IO ()
+main = getArgs >>= \case
+    [arg] -> runSettings (setPort 8000 defaultSettings)
+        =<< jsaddleOr defaultConnectionOptions (start $ toJSString arg)
+            jsaddleApp
+    _ -> fail "bad args: specify an example, e.g. 2048"
+
+#endif
diff --git 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/ghc-wasm-miso-examples.cabal b/ghc-wasm-miso-examples.cabal
@@ -8,10 +8,8 @@ executable ghc-wasm-miso-examples
       , aeson
       , base
       , containers
-      , ghc-experimental
       , hs2048
       , jsaddle
-      , jsaddle-wasm
       , miso
       , mtl
       , random
@@ -26,4 +24,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, warp, websockets