{-# OPTIONS_GHC -fno-ignore-asserts #-} {-# LANGUAGE NoMonomorphismRestriction #-} -- depends on package network, which is part of the Haskell Platform, -- or can be installed via 'cabal install network' {- demo: using web browser as gui for haskell program (some buttons, canvas graphics, mouse clicks, texts) -} module Canvas where import System.IO import Network import Data.Char(isSpace) import Control.Monad(unless) import Control.Concurrent import Control.Exception(finally) import Control.Monad.State -- hack to get current source path (hardcode path if hack unavailable..) import qualified Control.Exception as CE import Data.List(findIndices) thisFile = CE.catch (CE.assert False undefined) getName where getName (CE.AssertionFailed msg) = let (_:_:x:_) = reverse $ findIndices (==':') msg in return $ take x msg -- thisFile = return "Canvas.hs" -- poor man's HERE document.. (data in comments at the end of this file) commentData tag = do this <- readFile =<< thisFile let (_,_:rest) = span (/="{- "++tag++" START") (lines this) (hereData,_) = span (/=tag++" END -}") rest return hereData ------------------------------------------------------ -- not tested with other browsers yet, but should work with -- opera on other platforms, with other haskell implementations -- (tested on windows, with ghc 7.1, opera, firefox, safari) -- -- portable to other browsers in principle, -- but there are always minor differences -- -- run this, then point your browser at http://[::1]:8000/start main = withSocketsDo $ do page <- commentData "DATA" s <- listenOn (PortNumber 8000) server s (False,page,["gui lib?","no, thanks!","i'm","just","browsing"]) `finally` sClose s --------------------------- fake http server --use happs or similar if you want robustness server s st = do (h,host,portnr) <- accept s -- usually, we'd forkIO here reqstr <- hGetContents h st@(stop,_,_) <- loop st h (lines reqstr) `finally` hClose h unless stop $ server s st loop st h [] = do putStrLn "end of requests!" return st loop st@(stop,page,labels) h rs = do let (r,rs') = request rs hPutStrLn stderr $ unlines r hPutStrLn stderr $ show (parseRequestHead r) case parseRequestHead r of (("GET":"/start":_),_) -> do reply h ("text/html",unlines page) loop (stop,page,labels) h rs' (("GET":"/stop":_),_) -> do reply h ("text/plain","stopped!") return (True,page,labels) (("GET":"/draw":_),_) -> do reply h ("text/javascript" ,draw) loop (stop,page,labels) h rs' (("GET":"/label":_),_) -> do let (l:ls) = labels reply h ("text/plain",l) return (stop,page,ls++[l]) _ -> do reply h ("text/plain","unknown request"++show (head r)) loop st h rs' parseRequestHead :: [String] -> ([String],Maybe (Int,Int)) parseRequestHead (h:_) = let (req,dta) = span (/='?') h (x ,_:y') = span (/=',') (tail dta) (y ,_) = span (not . isSpace) y' in (words req,if null dta then Nothing else Just (read x ,read y )) request rs = case span (not . all isSpace) rs of (r,rs'@[]) -> (r,rs') (r,_:rs' ) -> (r,rs') reply h (ctype,body) = do let l = 1+length body msg = unlines ["HTTP/1.1 200" ,"Content-Length: "++show l ,"Content-Type: "++ctype ,"Cache-Control: no-cache" ,"" ,body ] hPutStr stderr msg hPutStr h msg hFlush h --------------------------- some canvas drawing from haskell -- we'd usually provide an abstract interface to the -- javascript canvas api, plus support for text labels; -- but sending plain javascript for remote evaluation -- is simple enough (less safe, though!) draw = unlines ["var canvas = document.getElementById('canvas');" ,"var ctxt = canvas.getContext('2d');" ,"ctxt.fillStyle = 'rgb(100,0,0)';" ,"ctxt.fillRect(10,10,10,10);" ,"ctxt.fillRect(canvasWidth-20,10,10,10);" ,"ctxt.fillRect(10,canvasHeight-20,10,10);" ,"ctxt.fillRect(canvasWidth-20,canvasHeight-20,10,10);" ,"ctxt.moveTo(0,0);" ,script $ execState graphic initState ,"ctxt.stroke();" ] graphic :: CanvasScript () graphic = do strokeStyle (200,0,0) translate 50 50 replicateM_ 10 (square 100 >> shrink) where square l = do beginPath move 0 0 line l 0 line l l line 0 l line 0 0 stroke shrink = do { translate 20 0; rotate (pi/12); scale 0.9 0.9 } --------------------------- canvas api fragments data ScriptState = St { script :: String, ctxt :: String } deriving Show type CanvasScript a = State ScriptState a initState = St{script="",ctxt="ctxt."} addCommand cmd = modify $ \s->s{script=script s++ctxt s++cmd++"\n"} beginPath = addCommand "beginPath();" closePath = addCommand "closePath();" move x y = addCommand ("moveTo("++show x++","++show y++");") line x y = addCommand ("lineTo("++show x++","++show y++");") translate x y = addCommand $ "translate("++show x++","++show y++");" scale x y = addCommand $ "scale("++show x++","++show y++");" rotate a = addCommand $ "rotate("++show a++");" stroke = addCommand "stroke();" save = addCommand "save();" restore = addCommand "restore();" fillStyle (r,g,b) = addCommand $ "fillStyle = \"rgb("++show r++","++show g++","++show b++")\";" strokeStyle (r,g,b) = addCommand $ "strokeStyle = \"rgb("++show r++","++show g++","++show b++")\";" {- DATA START Canvas (demo)

playing with the new html canvas

click anywhere on the canvas to get a text label with canvas coordinates (implemented by overlaying and positioning text divs over the canvas). the label texts are supplied dynamically by the haskell server code. press 'draw' to let haskell draw a few boring boxes on the canvas. press 'stop' to stop the haskell server. to start again, restart haskell server and reload page in browser.