{-# LANGUAGE   CPP, NoMonomorphismRestriction, DeriveDataTypeable  #-}

module Main where

import Prelude hiding (div,id)
import Transient.Internals



import GHCJS.HPlay.Cell
import GHCJS.HPlay.View
#ifdef ghcjs_HOST_OS
   hiding (map, input,option)
#else
   hiding (map, option,input)
#endif


import Transient.Move
import Transient.EVars
import Transient.Indeterminism

import Control.Applicative
import qualified Data.Vector as V
import qualified Data.Map as M
import Transient.MapReduce
import Control.Monad.IO.Class
import Data.String
import qualified Data.Text as T

#ifdef ghcjs_HOST_OS
import qualified Data.JSString as JS hiding (span,empty,strip,words)
#endif

import Data.Typeable





data Options= MapReduce | Chat | MonitorNodes | AllThree deriving (Typeable, Read, Show)

main =  keep' $  initNode  $ inputNodes <|> menuApp  <|> thelink

-- thelink :: Cloud ()
thelink=   do
     local . render $ rawHtml $ do
         br;br
         a ! href (fs "https://github.com/agocorona/transient-universe/blob/master/examples/distributedApps.hs") $ "source code"

-- menuApp :: Cloud ()
menuApp= do
     local . render . rawHtml $ do
        h1 "Transient Demo"
        br; br
     op <- local .  render $
                wlink MapReduce (b "map-reduce") <++ fs "   " <|>
                wlink Chat (b "chat") <++ fs "   " <|>
                wlink MonitorNodes (b "monitor nodes") <++ fs "   " <|>
                wlink AllThree  (b "all widgets")

     case op of
       AllThree -> allw
       MapReduce -> mapReduce
       Chat -> chat
       MonitorNodes -> monitorNodes

-- allw :: Cloud ()
allw=   mapReduce <|> chat  <|>  monitorNodes




-- A Web node launch a map-reduce computation in all the server nodes, getting data from a
-- textbox and render the results returned

-- mapReduce :: Cloud ()
mapReduce= onBrowser $ do

    content <- local . render $
            h1 "Map-Reduce widget" ++>
            p "Return the frequencies of words from a text using all the server nodes connected" ++>
            textArea   (fs "") ! atr "placeholder" (fs "enter the content")
                               ! atr "rows"  (fs "4")
                               ! atr "cols"  (fs "80")
            <++  br
            <**  inputSubmit "send"  `fire` OnClick
            <++  br

    r <- atRemote $ do
           lliftIO $ print content
           r<- reduce  (+) . mapKeyB (\w -> (w, 1 :: Int))  $ distribute $ V.fromList $ words content
           lliftIO $ putStr "result:" >> print r
           return   (r :: M.Map String Int)


    local . render $ rawHtml $ do
             h1 "Results"
             mconcat[i "word " >> b w >> i " appears " >> b n >> i " times" >> br
                    | (w,n) <- M.assocs r]

    empty

fs= fromString

-- a chat widget that run in the browser and in a cloud of servers

-- chat :: Cloud ()
chat = do

    let chatMessages= fs "chatMessages"

    local . render . rawHtml $ do
            h1 "Federated chat server"
            div ! id (fs "chatbox")
                ! style (fs $"overflow: auto;height: 200px;"
                         ++  "background-color: #FFCC99; max-height: 200px;")
                $ noHtml  -- create the chat box

    sendMessages  chatMessages <|>  waitMessages chatMessages

  where

  -- sendMessages :: Text -> Cloud ()
  sendMessages  chatMessages = do
--      node <- atRemote $ local getMyNode
      let entry= boxCell (fs "msg") ! atr "size"  (fs "60")
      (nick,text) <- local . render $  (,) <$> getString (Just "anonymous") ! size (fs "10")
                                           <*> mk entry Nothing  `fire` OnChange
                                           <** inputSubmit "send"
                                           <++ br
      local $ entry .= ""

      atRemote $ do
          node <- local getMyNode

          clustered $ local $ putMailbox chatMessages (showPrompt nick node ++ text )  >> empty :: Cloud ()
          empty

      where
      fs= fromString
      size= atr (fs "size")
      showPrompt u (Node h p _ _)= u ++ "@" ++ h ++ ":" ++ show p ++ "> "

  -- waitMessages :: Text -> Cloud ()
  waitMessages chatMessages =   do

      resp <- atRemote . local $ single $   getMailbox chatMessages
                                                           -- wait in the server for messages

      local . render . at (fs "#chatbox") Append $ rawHtml $ do
                                          p (resp :: String)    -- display the response
#ifdef ghcjs_HOST_OS
                                          liftIO $ scrollBottom $ fs "chatbox"


foreign import javascript unsafe
  "var el= document.getElementById($1);el.scrollTop=  el.scrollHeight"
  scrollBottom  :: JS.JSString -> IO()
#endif

-- monitorNodes :: Cloud ()
monitorNodes= do
    local . render $ rawHtml $ do
         h1 "Nodes connected"
         div ! atr (fs "id") (fs "nodes") $ noHtml

    nodes <- atRemote . local $ single $  sample getNodes 1000000

    local . render . at (fs "#nodes") Insert . rawHtml $
           table $ mconcat[tr $ td h >> td p >> td s | Node h p _ s  <- nodes]
    empty