temp

qualify-web-ui/web/Main.hs

@@ -0,0 +1,69 @@
+-- | Haskell language pragma
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE CPP #-}
+
+-- | Haskell module declaration
+module Main where
+
+-- | Miso framework import
+import           Miso
+import           Miso.String
+
+-- | JSAddle import
+#ifndef __GHCJS__
+import           Language.Javascript.JSaddle.Warp as JSaddle
+import qualified Network.Wai.Handler.Warp         as Warp
+import           Network.WebSockets
+#endif
+import           Control.Monad.IO.Class
+
+-- | Type synonym for an application model
+newtype Model = Model Int
+  deriving (Show, Eq)
+
+-- | Sum type for application events
+data Action
+  = AddOne
+  | SubtractOne
+  | NoOp
+  | SayHelloWorld
+  deriving (Show, Eq)
+
+#ifndef __GHCJS__
+runApp :: JSM () -> IO ()
+runApp f = JSaddle.debugOr 8080 (f >> syncPoint) JSaddle.jsaddleApp
+#else
+runApp :: IO () -> IO ()
+runApp app = app
+#endif
+
+-- | Entry point for a miso application
+main :: IO ()
+main = runApp $ startApp App {..}
+  where
+    initialAction = SayHelloWorld -- initial action to be executed on application load
+    model  = Model 3              -- initial model
+    update = updateModel          -- update function
+    view   = viewModel            -- view function
+    events = defaultEvents        -- default delegated events
+    subs   = []                   -- empty subscription list
+    mountPoint = Nothing          -- mount point for application (Nothing defaults to 'body')
+    logLevel = Off                -- used during prerendering to see if the VDOM and DOM are in synch (only used with `miso` function)
+
+-- | Updates model, optionally introduces side effects
+updateModel :: Action -> Model -> Effect Action Model
+updateModel AddOne (Model m) = noEff $ Model (m + 1)
+updateModel SubtractOne (Model m) = noEff $ Model (m - 1)
+updateModel NoOp m = noEff m
+updateModel SayHelloWorld m = m <# do
+  liftIO (putStrLn "Hello World") >> pure NoOp
+
+-- | Constructs a virtual DOM from a model
+viewModel :: Model -> View Action
+viewModel (Model m) = div_ [] [
+   button_ [ onClick AddOne ] [ text "+" ]
+ , text (ms m)
+ , button_ [ onClick SubtractOne ] [ text "-" ]
+ , div_ [] [ text "UGH" ]
+ ]