Skip to content

Instantly share code, notes, and snippets.

@luigy
Last active November 27, 2016 11:20
Show Gist options
  • Save luigy/b4e14c356ac1120985fd36b79525ca28 to your computer and use it in GitHub Desktop.
Save luigy/b4e14c356ac1120985fd36b79525ca28 to your computer and use it in GitHub Desktop.
{-# 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)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment