Support compiling the frontend API using JSaddle

Support for JSaddle is currently opt-in using a Cabal flag.

* If you compile with GHCJS and disable the flag, you should get the
same dependencies, performance, … as before.
* If you compile with GHC and disable the flag, you can still use miso
for server-side rendering.
* If you compile with GHC and enable the flag, you will get the same
  API as when compiling with GHCJS but the implementation uses
  JSaddle. This allows you to compile and run your code using one of
  the various backends for JSaddle, most notably `jsaddle-warp`.

default.nix

@@ -8,7 +8,12 @@
 }:
 let
   inherit (pkgs.haskell.lib) buildFromSdist enableCabalFlag sdistTarball buildStrictly;
-  inherit (pkgs.haskell.packages) ghc802 ghcjs;
+  inherit (pkgs.haskell.packages) ghc802;
+  ghcjs = pkgs.haskell.packages.ghcjsHEAD.override {
+     overrides = self: super: {
+       jsaddle-warp = super.callPackage ./jsaddle-warp-ghcjs.nix {};
+     };
+  };
   inherit (pkgs.lib) overrideDerivation optionalString;
   inherit (pkgs.stdenv) isDarwin;
   inherit (pkgs) closurecompiler;
@@ -18,9 +23,6 @@ let
     postInstall = ''
       mkdir -p $out/bin/mario.jsexe/imgs
       cp -r ${drv.src}/examples/mario/imgs $out/bin/mario.jsexe/
-      cp ${drv.src}/examples/todo-mvc/index.html $out/bin/todo-mvc.jsexe/
-      cp ${drv.src}/examples/mario/index.html $out/bin/mario.jsexe/
-      cp ${drv.src}/examples/websocket/index.html $out/bin/websocket.jsexe/
       cp ${drv.src}/examples/xhr/index.html $out/bin/xhr.jsexe/
       ${closurecompiler}/bin/closure-compiler $out/bin/todo-mvc.jsexe/all.js > $out/bin/todo-mvc.jsexe/min.js
       rm $out/bin/todo-mvc.jsexe/all.js

examples/file-reader/Main.hs

@@ -76,9 +76,6 @@ foreign import javascript unsafe "console.log($1);"
 foreign import javascript unsafe "$r = new FileReader();"
   newReader :: IO JSVal
 
-foreign import javascript unsafe "$r = document.getElementById($1);"
-  getElementById :: MisoString -> IO JSVal
-
 foreign import javascript unsafe "$r = $1.files[0];"
   getFile :: JSVal -> IO JSVal
 

examples/haskell-miso.org/default.nix

@@ -8,6 +8,11 @@
 let
   inherit (pkgs) runCommand closurecompiler;
   inherit (pkgs.haskell.packages) ghcjsHEAD ghc802;
+  ghcjs = ghcjs.override {
+    overrides = self: super: {
+      jsaddle-warp = super.callPackage ./../../jsaddle-warp-ghcjs.nix;
+    };
+  };
   miso-ghc = ghc802.callPackage ./../../miso-ghc.nix { };
   miso-ghcjs = ghcjsHEAD.callPackage ./../../miso-ghcjs.nix { };
   client = ghcjsHEAD.callPackage ./client { miso = miso-ghcjs; };

examples/mario/Main.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards   #-}
 {-# LANGUAGE MultiWayIf        #-}
@@ -6,12 +7,33 @@ module Main where
 
 import           Data.Bool
 import           Data.Function
-import qualified Data.Map      as M
+import qualified Data.Map as M
 import           Data.Monoid
 
 import           Miso
 import           Miso.String
 
+import qualified Language.Javascript.JSaddle.Warp as JSaddle
+
+#ifdef ghcjs_HOST_OS
+run :: Int -> JSM () -> IO ()
+run = JSaddle.run
+#else
+import           Network.Wai.Application.Static
+import qualified Network.Wai as Wai
+import qualified Network.Wai.Handler.Warp as Warp
+import           Network.WebSockets
+
+run :: Int -> JSM () -> IO ()
+run port f =
+    Warp.runSettings (Warp.setPort port (Warp.setTimeout 3600 Warp.defaultSettings)) =<<
+        JSaddle.jsaddleOr defaultConnectionOptions (f >> syncPoint) app
+    where app req sendResp =
+            case Wai.pathInfo req of
+              ("imgs" : _) -> staticApp (defaultWebAppSettings "examples/mario") req sendResp
+              _ -> JSaddle.jsaddleApp req sendResp
+#endif
+
 data Action
   = GetArrows !Arrows
   | Time !Double
@@ -22,7 +44,7 @@ spriteFrames :: [MisoString]
 spriteFrames = ["0 0", "-74px 0","-111px 0","-148px 0","-185px 0","-222px 0","-259px 0","-296px 0"]
 
 main :: IO ()
-main = do
+main = run 8080 $ do
     time <- now
     let m = mario { time = time }
     startApp App { model = m
@@ -122,7 +144,10 @@ display m@Model{..} = marioImage
     marioImage =
       div_ [ height_ $ ms h
            , width_ $ ms w
-           ] [ div_ [ style_ (marioStyle m groundY) ] [] ]
+           ]
+           [ nodeHtml "style" [] ["@keyframes play { 100% { background-position: -296px; } }"]
+           , div_ [ style_ (marioStyle m groundY) ] []
+           ]
 
 marioStyle :: Model -> Double -> M.Map MisoString MisoString
 marioStyle Model {..} gy =

examples/router/Main.hs

@@ -9,9 +9,12 @@ module Main where
 
 import Data.Proxy
 import Servant.API
-#if MIN_VERSION_servant(0,10,0)
+#if MIN_VERSION_servant(0,14,1)
+import Servant.Links
+#elif MIN_VERSION_servant(0,10,0)
 import Servant.Utils.Links
 #endif
+import Language.Javascript.JSaddle.Warp as JSaddle
 
 import Miso
 
@@ -32,8 +35,9 @@ data Action
 -- | Main entry point
 main :: IO ()
 main = do
-  currentURI <- getCurrentURI
-  startApp App { model = Model currentURI, initialAction = NoOp, ..}
+  JSaddle.run 8080 $ do
+    currentURI <- getCurrentURI
+    startApp App { model = Model currentURI, initialAction = NoOp, ..}
   where
     update = updateModel
     events = defaultEvents

examples/sse/default.nix

@@ -7,7 +7,12 @@
 }:
 let
   inherit (pkgs) runCommand closurecompiler;
-  inherit (pkgs.haskell.packages) ghcjs ghc802;
+  inherit (pkgs.haskell.packages) ghc802;
+  ghcjs = pkgs.haskell.packages.ghcjs.override (oldAttrs: {
+    overrides = self: super: {
+      jsaddle-warp = super.callPackage ./../../jsaddle-warp-ghcjs.nix {};
+    };
+  });
   miso-ghc = ghc802.callPackage ./../../miso-ghc.nix { };
   miso-ghcjs = ghcjs.callPackage ./../../miso-ghcjs.nix { };
   server = ghc802.callPackage ./server.nix { miso = miso-ghc; };

examples/three/Main.hs

@@ -129,9 +129,6 @@ foreign import javascript unsafe "$r = new THREE.WebGLRenderer({canvas:$1, antia
 foreign import javascript unsafe "$1.setSize( window.innerWidth, window.innerHeight );"
   setSize :: JSVal -> IO ()
 
-foreign import javascript unsafe "$r = document.getElementById($1);"
-  getElementById :: MisoString -> IO JSVal
-
 foreign import javascript unsafe "$1.add($2);"
   addToScene :: JSVal -> JSVal -> IO ()
 

examples/todo-mvc/Main.hs

@@ -12,14 +12,17 @@
 {-# LANGUAGE ExtendedDefaultRules #-}
 module Main where
 
-import           Data.Aeson   hiding (Object)
+import           Data.Aeson hiding (Object)
 import           Data.Bool
-import qualified Data.Map     as M
+import qualified Data.Map as M
 import           Data.Monoid
 import           GHC.Generics
 import           Miso
-import           Miso.String  (MisoString)
-import qualified Miso.String  as S
+import           Miso.String (MisoString)
+import qualified Miso.String as S
+
+import           Control.Monad.IO.Class
+import           Language.Javascript.JSaddle.Warp as JSaddle
 
 default (MisoString)
 
@@ -78,7 +81,8 @@ data Msg
    deriving Show
 
 main :: IO ()
-main = startApp App { initialAction = NoOp, ..}
+main =
+  JSaddle.run 8080 $ startApp App { initialAction = NoOp, ..}
   where
     model      = emptyModel
     update     = updateModel
@@ -90,7 +94,7 @@ main = startApp App { initialAction = NoOp, ..}
 updateModel :: Msg -> Model -> Effect Msg Model
 updateModel NoOp m = noEff m
 updateModel (CurrentTime n) m =
-  m <# do print n >> pure NoOp
+  m <# do liftIO (print n) >> pure NoOp
 updateModel Add model@Model{..} =
   noEff model {
     uid = uid + 1
@@ -123,7 +127,7 @@ updateModel (Check id' isCompleted) model@Model{..} =
    model { entries = newEntries } <# eff
     where
       eff =
-        putStrLn "clicked check" >>
+        liftIO (putStrLn "clicked check") >>
           pure NoOp
 
       newEntries =
@@ -161,6 +165,10 @@ viewModel m@Model{..} =
         , viewControls m visibility entries
         ]
     , infoFooter
+    , link_
+        [ rel_ "stylesheet"
+        , href_ "https://d33wubrfki0l68.cloudfront.net/css/d0175a264698385259b5f1638f2a39134ee445a0/style.css"
+        ]
     ]
 
 viewEntries :: MisoString -> [ Entry ] -> View Msg

examples/websocket/Main.hs

@@ -20,10 +20,12 @@ import           Miso
 import           Miso.String  (MisoString)
 import qualified Miso.String  as S
 
+import qualified Language.Javascript.JSaddle.Warp as JSaddle
+
 main :: IO ()
-main = startApp App { initialAction = Id, ..}
+main = JSaddle.run 8080 $ startApp App { initialAction = Id, ..}
   where
-    model = Model mempty mempty
+    model = Model (Message "") mempty
     events = defaultEvents
     subs = [ websocketSub uri protocols HandleWebSocket ]
     update = updateModel
@@ -43,7 +45,7 @@ instance ToJSON Message
 instance FromJSON Message
 
 newtype Message = Message MisoString
-  deriving (Eq, Show, Generic, Monoid)
+  deriving (Eq, Show, Generic)
 
 data Action
   = HandleWebSocket (WebSocket Message)
@@ -58,7 +60,8 @@ data Model = Model {
 
 appView :: Model -> View Action
 appView Model{..} = div_ [ style_ $ M.fromList [("text-align", "center")] ] [
-   h1_ [style_ $ M.fromList [("font-weight", "bold")] ] [ a_ [ href_ "https://github.com/dmjio/miso" ] [ text $ S.pack "Miso Websocket Example" ] ]
+   link_ [rel_ "stylesheet", href_ "https://cdnjs.cloudflare.com/ajax/libs/bulma/0.4.3/css/bulma.min.css"]
+ , h1_ [style_ $ M.fromList [("font-weight", "bold")] ] [ a_ [ href_ "https://github.com/dmjio/miso" ] [ text $ S.pack "Miso Websocket Example" ] ]
  , h3_ [] [ text $ S.pack "wss://echo.websocket.org" ]
  , input_  [ type_ "text"
            , onInput UpdateMessage

exe/Main.hs

@@ -9,6 +9,9 @@ module Main where
 import Miso
 import Miso.String
 
+import Control.Monad.IO.Class
+import Language.Javascript.JSaddle.Warp as JSaddle
+
 -- | Type synonym for an application model
 type Model = Int
 
@@ -22,7 +25,8 @@ data Action
 
 -- | Entry point for a miso application
 main :: IO ()
-main = startApp App {..}
+main = JSaddle.run 8080 $ do
+  startApp App {..}
   where
     initialAction = SayHelloWorld -- initial action to be executed on application load
     model  = 0                    -- initial model
@@ -38,7 +42,7 @@ updateModel AddOne m = noEff (m + 1)
 updateModel SubtractOne m = noEff (m - 1)
 updateModel NoOp m = noEff m
 updateModel SayHelloWorld m = m <# do
-  putStrLn "Hello World" >> pure NoOp
+  liftIO (putStrLn "Hello World") >> pure NoOp
 
 -- | Constructs a virtual DOM from a model
 viewModel :: Model -> View Action