Use of oCanvas in Reflex

OCanvas.hs

{-# LANGUAGE JavaScriptFFI #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}

module Scorch.OCanvas
       (
         mkCanvas

       , canvasDisplay
       , canvasAddChild
       , imageAddChild
       , moveTo
       , redraw
       ) where


--import           Data.Text (Text)
import           Control.Monad.Trans (liftIO)
import           GHCJS.Prim (toJSInt)
import           GHCJS.Types
import           GHCJS.Foreign
import           GHCJS.Marshal
import           Reflex.Dom 
import           Scorch.OCanvas.CanvasInfo
import           Scorch.OCanvas.ImageOrigin
import           Scorch.OCanvas.ImageInfo
--default(Text)

data OCanvas
type OCanvasRef = JSRef OCanvas

data OImage
type OImageRef = JSRef OImage

foreign import javascript unsafe "$r = oCanvas.create($1)"
  js_create :: JSRef CanvasInfo -> IO OCanvasRef

foreign import javascript unsafe "$1.width = $2"
  js_setWidth :: OCanvasRef -> JSNumber -> IO ()

foreign import javascript unsafe "$r = $1.width"
  js_getWidth :: OCanvasRef -> IO JSNumber

foreign import javascript unsafe "$1.height = $2"
  js_setHeight :: OCanvasRef -> JSNumber -> IO ()

foreign import javascript unsafe "$r = $1.height"
  js_getHeight :: OCanvasRef -> IO JSNumber

foreign import javascript unsafe "$r = $1.display.image($2)"
  js_display :: OCanvasRef -> JSRef ImageInfo -> IO OImageRef

foreign import javascript unsafe "$1.zIndex = $2"
  js_setZIndex :: OImageRef -> JSNumber -> IO ()

foreign import javascript unsafe "$1.addChild($2)"
  js_addChild :: OCanvasRef -> OImageRef -> IO ()

foreign import javascript unsafe "$1.addChild($2)"
  js_addImageChild :: OImageRef -> OImageRef -> IO ()

foreign import javascript unsafe "$1.redraw()"
  js_redraw :: OCanvasRef -> IO ()

foreign import javascript unsafe "$1.move($2, $3)"
  js_move :: OImageRef -> JSNumber -> JSNumber -> IO ()

foreign import javascript unsafe "$1.moveTo($2, $3)"
  js_moveTo :: OImageRef -> JSNumber -> JSNumber -> IO ()

foreign import javascript unsafe "$r = $1.toDataURL($2)"
  js_toDataURL :: OCanvasRef -> JSString -> IO (JSString)

foreign import javascript unsafe "$1 === null && typeof $1 === \"object\""
  js_is_null :: JSRef a -> Bool


--filterNull :: JSRef a -> _ -> Maybe (JSRef a)
filterNull x _ =
  case js_is_null x of
    True ->
      Nothing
    False ->
      Just x

------------------------------------------------------------------------------
-- 
mkCanvas' :: CanvasInfo -> IO (OCanvasRef)
mkCanvas' cnvInfo = do
  cnvObj <- toJSRef cnvInfo
  cnvRef <- js_create cnvObj
  js_setWidth cnvRef (toJSInt $ width cnvInfo)
  js_setHeight cnvRef (toJSInt $ height cnvInfo)
  return cnvRef


mkCanvas :: (MonadWidget t m) => Event t CanvasInfo -> m (Event t OCanvasRef)
mkCanvas cnvInfoE = do
  performEvent $ fmap (liftIO . mkCanvas') cnvInfoE
  

canvasDisplay' :: (OCanvasRef, ImageInfo) -> IO (OImageRef)
canvasDisplay' (cnvRef, imgInfo) = do
  imgInfoRef <- toJSRef imgInfo
  imgRef <- js_display cnvRef imgInfoRef
  return imgRef


canvasDisplay :: (MonadWidget t m) => Event t OCanvasRef -> Dynamic t ImageInfo -> m (Event t OImageRef)
canvasDisplay cnvRefE imgInfoD = do
  --let cnvReadyE = attachDynWith (\ii cnvRef -> (cnvRef, ii)) imgInfoD cnvRefE
  cnvRefD <- foldDynMaybe filterNull jsNull cnvRefE
  imgReadyE <- performEvent $ fmap (liftIO . canvasDisplay') (updated cnvImgD)
  return 


canvasAddChild' :: (OCanvasRef, OImageRef) -> IO ()
canvasAddChild' (cnvRef, imgRef) = do
  js_addChild cnvRef imgRef


canvasAddChild :: (MonadWidget t m) => Event t OCanvasRef -> Event t OImageRef -> m (Event t ())
canvasAddChild cnvRefE imgRefE = do
  cnvImgRefD <- combineDyn (\a b -> (a, b)) cnvRefD imgRefD
  performEvent $ fmap (liftIO . canvasAddChild') (updated cnvImgRefD)


imageAddChild' :: (OImageRef, OImageRef) -> IO ()
imageAddChild' (imgRef1, imgRef2) = do
  js_addImageChild imgRef1 imgRef2


imageAddChild :: (MonadWidget t m) => Dynamic t OImageRef -> Dynamic t OImageRef -> m (Event t ())
imageAddChild imgRef1D imgRef2D = do
  imgImgRefD <- combineDyn (,) imgRef1D imgRef2D
  performEvent $ fmap (liftIO . imageAddChild') (updated imgImgRefD)


redraw' :: OCanvasRef -> () -> IO ()
redraw' cnvRef _ = js_redraw cnvRef


redraw :: MonadWidget t m => Dynamic t OCanvasRef -> Event t () -> m ()
redraw cnvRefD redrawE = do
  cnvRef <- sample $ current cnvRefD
  addVoidAction $ fmap (liftIO . redraw' cnvRef) redrawE


moveTo' :: OImageRef -> (Int, Int) -> IO ()
moveTo' imgRef (x, y) = do
  js_moveTo imgRef (toJSInt x) (toJSInt y)


moveTo :: (MonadWidget t m) => Dynamic t OImageRef -> Dynamic t (Int, Int) -> m ()
moveTo imgRefD coordsD = do
  imgRef <- sample $ current imgRefD
  performEvent_ $ fmap (liftIO . moveTo' imgRef) (updated coordsD)