{-# 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
<html>

<head>
<title>Canvas (demo)</title>
</head>
<body>

<script>

function get(text) {
  var getReq = new XMLHttpRequest() || new ActiveXObject("Microsoft.XMLHTTP");
  if (getReq) {
    // be sure where the requests come from, especially 
    // if you're evaluating javascript requests!
    getReq.open("GET",text,true);
    getReq.setRequestHeader( "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT" );
    getReq.onreadystatechange=callback(getReq);
    getReq.send(null);
  }
}

function callback(req) { return function() {
  if (req.readyState==4) {
      if (req.status==200) {
        if (req.getResponseHeader('Content-Type')=='text/javascript') {

          // simplicity over safety here..
          // evaluate javascript sent from haskell server
          eval(req.responseText); 

        } else if (req.getResponseHeader('Content-Type')=='text/plain') {

          // text sent from haskell server is embedded in current text label
          var label = document.getElementById('label'+labelcount);
          label.textContent += ': '+req.responseText;

        } else {
          alert('unknown request')
        }
      } else {
      }
  }
} }

canvasWidth  = 400;
canvasHeight = 200;
labelcount = 0;

function init() {
  var canvas = document.getElementById('canvas');
  var ctxt   = canvas.getContext('2d');
  // a grey background, to identify the canvas
  ctxt.fillStyle = 'rgb(220,220,220)';
  ctxt.fillRect(0,0,canvasWidth,canvasHeight);
  ctxt.beginPath();
  ctxt.moveTo(0,0);
  // ctxt.lineTo(canvasWidth,canvasHeight);
  ctxt.stroke();
}

function clicked(e) {
  var evt    = e;     // || window.event;
  addLabel(evt.clientX,evt.clientY
          ,(evt.clientX-evt.target.offsetLeft)+'/'+(evt.clientY-evt.target.offsetTop));
//  alert((evt.clientX-evt.target.offsetLeft)+'/'+(evt.clientY-evt.target.offsetTop));
}

function addLabel(x,y,text) {
  // clone the label prototype, position it over the canvas
  var label  = document.getElementById('label');
  var labels = document.getElementById('labels');
  var labelClone = label.cloneNode(true);
  labelClone.id            = "label"+ ++labelcount;
  labelClone.style.left    = x;
  labelClone.style.top     = y;
  labelClone.style.display = "inline";
  labelClone.textContent   = text;
  labels.insertBefore(labelClone,labels.firstChild);
  // let haskell server add to the label text
  get('label');
}

</script>

<h2>playing with the new html canvas</h2>

<input type="button" value="draw" onclick="get('draw')">
<input type="button" value="stop" onclick="get('stop')">

<br>

<canvas id="canvas" width="400" height="200" onclick="clicked(event)"> </canvas>

<!-- a reservoir of text labels, to be cloned and placed over canvas -->
<span id="labels">
<div id="label" style="position:absolute; top:150px; left:50px; z-index:2; display:none"> text label </div>
</span>

<script> init(); </script>

<p>
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.
</p>

</body>
</html>
DATA END -}