upgrade showing widget composition

app/Main.hs

@@ -1,6 +1,10 @@
 module Main where
 
-import Lib (startServer)
+import PeekPoke (peekPoke)
+import Hello (hello)
+
+import GHCJS.HPlay.View
+import Transient.Base
 
 main :: IO ()
-main = startServer
+main = keep . initNode . onBrowser $ peekPoke <|> hello

src/Hello.hs

@@ -0,0 +1,21 @@
+{-# LANGUAGE NoMonomorphismRestriction #-}
+module Hello
+  ( hello )
+where
+
+import Prelude hiding(div,id)
+import GHCJS.HPlay.View
+import Transient.Move
+
+import Data.String
+
+hello :: Cloud ()
+hello = local $ do
+  render $ rawHtml $ br >> br
+  name <- render $ inputString Nothing ! placeholder (fs "your name") `fire` OnKeyUp
+  render $ rawHtml $ h2 $ "hello " ++ name
+
+placeholder= atr (fs "placeholder")
+
+fs :: IsString a => String -> a
+fs = fromString

src/Lib.hs

@@ -1,40 +0,0 @@
-{-# LANGUAGE NoMonomorphismRestriction #-}
-module Lib
-  ( startServer )
-where
-
-import GHCJS.HPlay.View
-import Transient.Base
-import Transient.Move
-import Data.IORef
-import Control.Monad.IO.Class
-import Data.String
-import Prelude hiding(div,id)
-
-startServer :: IO ()
-startServer = keep . initNode $ onBrowser peekPoke
-
-peekPoke = do
-   model <- onAll . liftIO $ newIORef (0 :: Int)
-   poke  <|> peek model
-
-pokeMessages = fs "pokeMessages"
-
--- send a message to the server each click
-poke :: Cloud ()
-poke  =  do
-    local $ render $ do
-       rawHtml $ div  ! id (fs "pokes") $ p "Pokes: 0"
-       inputSubmit  "Poke others" `fire` OnClick
-
-    atRemote . local $ putMailbox pokeMessages "poke" >> stop  -- update the mailbox in the server
-
--- receive updates from the server
-peek :: IORef Int -> Cloud ()
-peek model = do
-    msg <- atRemote . local $ getMailbox pokeMessages  :: Cloud String  -- each update send a msg to each client
-    local $ render $ do
-       n <- liftIO $ atomicModifyIORef model $ \n ->  (n +1,n+1)
-       at  (fs "#pokes")  Insert . rawHtml  $ p $  "Pokes: " ++  show n
-
-fs= fromString

src/PeekPoke.hs

@@ -0,0 +1,54 @@
+{-# LANGUAGE NoMonomorphismRestriction #-}
+module PeekPoke
+  ( peekPoke )
+where
+
+import Prelude hiding(div,id)
+import GHCJS.HPlay.View
+import Transient.Base
+import Transient.Move
+
+import Data.IORef (newIORef,IORef,atomicModifyIORef)
+import Control.Monad.IO.Class
+import Data.String
+import Data.Typeable
+
+type Model = Int
+data Msg = Increase | Decrease deriving (Read, Show, Typeable)
+
+peekPoke :: Cloud ()
+peekPoke = do
+   model <- onAll . liftIO $ newIORef 0
+   poke  <|> peek model
+
+pokeMessages :: IsString a => a
+pokeMessages = fs "pokeMessages"
+
+-- send a message to the server each click
+poke :: Cloud ()
+poke  =  do
+    msg <- local $ render $ do
+       rawHtml $ div  ! id (fs "pokes") $ h1 "Pokes: 0"
+       increaseButton <|> decreaseButton
+    local $ render $ wprint msg
+    -- update the mailbox in the server
+    atRemote . local $ putMailbox pokeMessages msg >> stop
+  where
+    increaseButton = inputSubmit  "increase" `fire` OnClick >> return Increase
+    decreaseButton = inputSubmit  "decrease" `fire` OnClick >> return Decrease
+
+update :: Msg -> Model -> (Model,Model)
+update Increase n = (n+1,n+1)
+update Decrease n = (n-1,n-1)
+
+-- receive updates from the server
+peek :: IORef Model -> Cloud ()
+peek model = do
+  -- each update send a msg to each client
+  msg <- atRemote . local $ getMailbox pokeMessages :: Cloud Msg
+  local $ render $ do
+    n <- liftIO $ atomicModifyIORef model (update msg)
+    at (fs "#pokes") Insert . rawHtml  $ p $  "Pokes: " ++  show n
+
+fs :: IsString a => String -> a
+fs = fromString

wse.cabal

@@ -15,7 +15,8 @@ cabal-version:       >=1.10
 
 library
   hs-source-dirs:      src
-  exposed-modules:     Lib
+  exposed-modules:     PeekPoke
+                     , Hello
   build-depends:       base >= 4.7 && < 5
                      , transient
                      , transient-universe
@@ -26,9 +27,11 @@ library
 executable wse-exe
   hs-source-dirs:      app
   main-is:             Main.hs
-  ghc-options:         -threaded -rtsopts -with-rtsopts=-N
+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N -Wall
   build-depends:       base
                      , wse
+                     , ghcjs-hplay
+                     , transient
   default-language:    Haskell2010
 
 test-suite wse-test