Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: master
Fetching contributors…

Cannot retrieve contributors at this time

file 94 lines (75 sloc) 2.939 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94
import UHC.Ptr

data JSKeyEvent
data Document
data Element
data Context2D

type JSString = PackedString
foreign import prim "primStringToPackedString" toJS :: String -> JSString

foreign import js "alert(%1)" jsAlert :: JSString -> IO ()
alert = jsAlert . toJS

foreign import js "document"
    document :: IO Document
foreign import js "document.getElementById(%1)"
    jsGetElementById :: JSString -> IO Element
getElementById = jsGetElementById . toJS
foreign import js "%1.getContext('2d')"
    getContext2dFromCanvas :: Element -> IO Context2D

getContext2d :: String -> IO Context2D
getContext2d canvasName = do
  c <- getElementById canvasName
  getContext2dFromCanvas c

foreign import js "%1.fillRect(%*)"
  fillRect :: Context2D -> Double -> Double -> Double -> Double -> IO ()
foreign import js "jsSetFillColor(%*)"
  jsSetFillColor :: Context2D -> JSString -> IO ()
setFillColor ctx = jsSetFillColor ctx . toJS
foreign import js "%1.clearRect(%2, %3, %4, %5)"
  clearRect :: Context2D -> Double -> Double -> Double -> Double -> IO ()

foreign import js "%1.canvas.width" canvasWidth :: Context2D -> IO Double
foreign import js "%1.canvas.height" canvasHeight :: Context2D -> IO Double
clear :: Context2D -> IO ()
clear ctx = do
  w <- canvasWidth ctx
  h <- canvasHeight ctx
  clearRect ctx 0.0 0.0 w h
  

foreign import js "wrapper" mkCb :: IO () -> IO (FunPtr (IO ()))
foreign import js "wrapper"
    mkKeyEventCb :: (JSKeyEvent -> IO ()) -> IO (FunPtr (JSKeyEvent -> IO ()))

foreign import js "%1.keyCode"
  keyCode :: JSKeyEvent -> IO Int


foreign import js "%1.addEventListener('keydown',%2,true)"
  jsSetOnKeyDown :: Element -> FunPtr (JSKeyEvent -> IO ()) -> IO ()
setOnKeyDown :: String -> (Int -> IO ()) -> IO ()
setOnKeyDown elemName fp = do
  cb <- mkKeyEventCb fp'
  el <- getElementById elemName
  jsSetOnKeyDown el cb
  where
    fp' event = keyCode event >>= fp

foreign import js "%1.addEventListener('keyup',%2,true)"
  jsSetOnKeyUp :: Element -> FunPtr (JSKeyEvent -> IO ()) -> IO ()

setOnKeyUp :: String -> (Int -> IO ()) -> IO ()
setOnKeyUp elemName fp = do
  cb <- mkKeyEventCb fp'
  el <- getElementById elemName
  jsSetOnKeyUp el cb
  where
    fp' event = keyCode event >>= fp

foreign import js "window.addEventListener('load', %1, 'false')"
  jsSetOnLoad :: FunPtr (IO ()) -> IO ()
setOnLoad :: IO () -> IO ()
setOnLoad fp = mkCb fp >>= jsSetOnLoad

foreign import js "setInterval(%1,%2)"
  jsSetInterval :: FunPtr (IO ()) -> Double -> IO ()
setInterval :: Double -> IO () -> IO ()
setInterval time fp = do
  cb <- mkCb fp
  jsSetInterval cb time

foreign import ccall jsSaveGlobalObject :: JSString -> a -> IO ()
foreign import ccall jsLoadGlobalObject :: JSString -> IO a

saveGlobalObject :: String -> a -> IO ()
saveGlobalObject name obj = jsSaveGlobalObject (toJS name) obj

loadGlobalObject :: String -> IO a
loadGlobalObject name = do
  ptr <- jsLoadGlobalObject (toJS name)
  return $ ptr
Something went wrong with that request. Please try again.