updated threads.hs ghcjs example to ghcjs-dom https://github.com/ghcjs/ghcjs-examples/blob/217b7fd3816f57634977beac711452704c3ea688/threads/threads.hs

threads.hs

{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}

{-
   start 10000 threads that each randomly update the color of a single cell in a table
-}

module Main where

import Control.Concurrent
import Control.Monad
import System.Random

import GHCJS.Types

import GHCJS.DOM (currentDocument)
import GHCJS.DOM.CSSStyleSheet (insertRule, castToCSSStyleSheet)
import GHCJS.DOM.Document (getBody, getHead, createTextNode, createElement)
import GHCJS.DOM.Element (setClassName)
import GHCJS.DOM.HTMLStyleElement (castToHTMLStyleElement, getSheet)
import GHCJS.DOM.Node (appendChild)
import GHCJS.DOM.Types

addStyle :: [JSString] -> IO ()
addStyle styles = do
  Just doc <- currentDocument
  Just st <- createElement doc $ Just ("style" :: JSString)
  appendChild st =<< createTextNode doc (""::JSString)
  Just head' <- getHead doc
  appendChild head' $ Just st
  Just sheet <- getSheet $ castToHTMLStyleElement st
  forM_ styles $ \s -> insertRule (castToCSSStyleSheet sheet) s 0

addChild :: Element -> JSString -> IO Element
addChild parent tagName = do
  Just doc <- currentDocument
  Just node <- createElement doc $ Just tagName
  appendChild parent $ Just node
  return node

setCol :: Element -> Int -> IO ()
setCol elem col = setClassName elem $ "col-" ++ show col

main :: IO ()
main = do
  let dim = 100
  addStyle [ "body { background-color: #666; }"
           , "table { border-collapse: collapse; }"
           , "td { width: 7px; height: 7px; padding: 0; margin: 0; border: none; }"
           , "td.col-0 { background-color: #000; }", "td.col-1 { background-color: #444; }"
           , "td.col-2 { background-color: #888; }", "td.col-3 { background-color: #bbb; }"
           , "td.col-4 { background-color: #fff; }"
           ]
  Just doc <- currentDocument
  Just body <- getBody doc
  table <- addChild (toElement body) "table"
  rows  <- replicateM dim (addChild table "tr")
  cells <- concat <$> forM rows (\r -> replicateM dim (addChild r "td"))
  forM_ cells (void . forkIO . cellThread)

cellThread :: Element -> IO a
cellThread elem = forever $ do
  setCol elem =<< randomRIO (0,4)
  threadDelay . (1000000+) =<< randomRIO (0,10000000)