Main.hs

 {-# LANGUAGE OverloadedStrings #-}

module Main where

import Control.Monad.Trans
import GHCJS.DOM
import GHCJS.DOM.Node
import Style
import Util

data Tree = Tree String [Tree]

renderTree :: NodeClass parent => Int -> Tree -> Browser parent ()
renderTree level (Tree title children) = do
    div_ ("msg level-" ++ show level ++ " level-mod-8-is-" ++ show (level `mod` 8)) $ do
        let l = show level
        "style" %= "margin-left: " ++ l ++ "em" -- ++ "; background-color: #" ++ l ++ l ++ l ++ ";"
        setText title
    mapM_ (renderTree (level + 1)) children

main = runBrowser $ do
    lift . enableInspector =<< getWebView
    addStyle style
    div_ "container" $ renderTree 0 $ Tree "hello" [Tree "how" [Tree "deep" [Tree "does" [Tree "it" [Tree "go" []]]]]]

Style.hs

module Style where

import Data.Text.Lazy (unpack)
import Text.Lucius

style = unpack $ renderCss $ [lucius|
    .holder {
        margin-left: 1em;
    }
    .container {
        overflow-y: auto;
        height: 100%;
    }
  |] undefined

Util.hs

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleInstances #-}

module Util where

import Control.Applicative
import Control.Arrow (second)
import Control.Monad.Base
import Control.Monad.Catch
import Control.Monad.IO.Class
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Trans.Control
import Data.Maybe
import GHCJS.DOM
import GHCJS.DOM.Document
import GHCJS.DOM.Element
import GHCJS.DOM.HTMLBodyElement
import GHCJS.DOM.HTMLDivElement
import GHCJS.DOM.HTMLElement
import GHCJS.DOM.HTMLStyleElement
import GHCJS.DOM.Node
import GHCJS.DOM.Types

-- Idea: Have the type system track which operations trigger layout,
-- and don't allow these to be directly interspersed with queries.

data Global = Global WebView Document

newtype BrowserT s m a = BrowserT (ReaderT (Global, s) m a)
    deriving (Functor, Applicative, Monad, MonadFix, MonadPlus, Alternative, MonadTrans, MonadIO)

type Browser s a = BrowserT s IO a

getWebView :: Monad m => BrowserT s m WebView
getWebView = do
    (Global webView _, _) <- BrowserT ask
    return webView

getDocument :: Monad m => BrowserT s m Document
getDocument = do
    (Global _ document, _) <- BrowserT ask
    return document

getCursor :: Monad m => BrowserT s m s
getCursor = do
    (_, s) <- BrowserT ask
    return s

withCursor :: Monad m => s' -> BrowserT s' m a -> BrowserT s m a
withCursor x = onCursor (const x)

onCursor :: Monad m => (s -> s') -> BrowserT s' m a -> BrowserT s m a
onCursor f (BrowserT g) = BrowserT $ withReaderT (second f) g

getBody :: Browser s HTMLBodyElement
getBody = do
    doc <- getDocument
    Just body <- lift (documentGetBody doc)
    return (unsafeCast body)

runBrowser :: Browser HTMLBodyElement () -> IO ()
runBrowser (BrowserT f) = runWebGUI $ \webView -> do
    Just doc <- webViewGetDomDocument webView
    Just body <- fmap castToHTMLBodyElement <$> documentGetBody doc
    runReaderT f (Global webView doc, body)

addStyle :: String -> Browser _node HTMLStyleElement
addStyle css = do
    style <- unsafeBuild "style"
    lift $ htmlElementSetInnerText style css
    body <- getBody
    lift $ nodeAppendChild body (Just style)
    return style

setText :: HTMLElementClass node => String -> Browser node ()
setText str = lift . flip htmlElementSetInnerText str =<< getCursor

getText :: HTMLElementClass node => Browser node String
getText = lift . htmlElementGetInnerText =<< getCursor

div_ :: NodeClass parent => String -> Browser HTMLDivElement a -> Browser parent a
div_ clz f = unsafeAdd "div" $ do
    setClass clz
    f

setClass :: ElementClass node => String -> Browser node ()
setClass clz = do
    node <- getCursor
    lift $ elementSetClassName node clz

unsafeAdd :: (NodeClass parent, NodeClass child) => String -> Browser child a -> Browser parent a
unsafeAdd name f = do
    obj <- unsafeBuild name
    result <- withCursor obj f
    cursor <- getCursor
    lift $ nodeAppendChild cursor (Just obj)
    return result

unsafeBuild :: GObjectClass a => String -> Browser s a
unsafeBuild name = do
    doc <- getDocument
    unsafeCast . fromMaybe (error ("Failed to build " ++ name)) <$>
        lift (documentCreateElement doc name)

unsafeCast :: (GObjectClass a, GObjectClass b) => a -> b
unsafeCast = unsafeCastGObject . toGObject

infixl 1 %=

(%=) :: ElementClass node => String -> String -> Browser node ()
attr %= val = do
    cursor <- getCursor
    lift $ elementSetAttribute cursor attr val