How to convert a ByteString value to a JSVal

Question

In the module GHCJS.DOM.JSFFI.Generated.CanvasRenderingContext2D there is the function putImageData with the following type:

putImageData ::
  Control.Monad.IO.Class.MonadIO m =>
  CanvasRenderingContext2D
  -> Maybe GHCJS.DOM.Types.ImageData -> Float -> Float -> m ()

The second parameter has the type Maybe GHCJS.DOM.Types.ImageData. This type is defined in the module GHCJS.DOM.Types as a newtype wrapper around a JSVal value:

newtype ImageData = ImageData {unImageData :: GHCJS.Prim.JSVal}

I have a value of type ByteString that has always 4 bytes with the RGBA values of each pixel. How to I convert my ByteString value to a GHCJS.Prim.JSVal?

Answer 1

Edit: Looks like my original answer was too GHC centric. Added an untested fix that might work for GHCJS.

Edit #2: Added my stack.yaml file for the example.

You can use GHCJS.DOM.ImageData.newImageData to construct the ImageData object. It requires the data to be a GHCJS.DOM.Types.Uint8ClampedArray (which is a byte array in RGBA format).

There are conversion functions in GHCJS.Buffer from ByteStrings to Buffers (via fromByteString) and from there to typed arrays (e.g., getUint8Array). They do the conversion directly under GHCJS, and even under plain GHC they use a base64 conversion as an intermediary which should be pretty fast. Unfortunately, the conversion function getUint8ClampedArray isn't included (and for plain GHC, it looks like fromByteString might be broken anyway -- in jsaddle 0.8.3.0, it's calling the wrong JavaScript helper function).

For plain GHC, the following seems to work (the first line is copied from fromByteString with the helper renamed from the apparently incorrect h$newByteArrayBase64String):

uint8ClampedArrayFromByteString :: ByteString -> GHCJSPure (Uint8ClampedArray)
uint8ClampedArrayFromByteString bs = GHCJSPure $ do
  buffer <- SomeBuffer <$> jsg1 "h$newByteArrayFromBase64String"
                                (decodeUtf8 $ B64.encode bs)
  arrbuff <- ghcjsPure (getArrayBuffer (buffer :: MutableBuffer))
  liftDOM (Uint8ClampedArray <$> new (jsg "Uint8ClampedArray") [pToJSVal arrbuff])

Here is an untested GHCJS version that may work. If they fix the above-mentioned jsaddle bug, it should work under plain GHC, too:

uint8ClampedArrayFromByteString :: ByteString -> GHCJSPure (Uint8ClampedArray)
uint8ClampedArrayFromByteString bs = GHCJSPure $ do
  (buffer,_,_) <- ghcjsPure (fromByteString bs)
  buffer' <- thaw buffer
  arrbuff <- ghcjsPure (getArrayBuffer buffer')
  liftDOM (Uint8ClampedArray <$> new (jsg "Uint8ClampedArray") [pToJSVal arrbuff])

I don't have a running GHCJS installation, but here's a complete working example I tested using JSaddle+Warp under plain GHC which seems to work okay (i.e., if you point a browser at localhost:6868, it displays a 3x4 image on the canvas element):

module Main where

import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.Text.Encoding (decodeUtf8)
import qualified Data.ByteString.Base64 as B64 (encode)
import Language.Javascript.JSaddle (js, js1, jss, jsg, jsg1,
                                    new, pToJSVal, GHCJSPure(..), ghcjsPure, JSM,
                                    fromJSVal, toJSVal, Object)
import Language.Javascript.JSaddle.Warp (run)
import JSDOM.Types (liftDOM, Uint8ClampedArray(..), RenderingContext(..))
import JSDOM.ImageData
import JSDOM.HTMLCanvasElement
import JSDOM.CanvasRenderingContext2D
import GHCJS.Buffer (getArrayBuffer, MutableBuffer)
import GHCJS.Buffer.Types (SomeBuffer(..))
import Control.Lens ((^.))

main :: IO ()
main = run 6868 $ do
  let smallImage = BS.pack [0xff,0x00,0x00,0xff,  0xff,0x00,0x00,0xff,  0xff,0x00,0x00,0xff,
                            0x00,0x00,0x00,0xff,  0x00,0xff,0x00,0xff,  0x00,0x00,0x00,0xff,
                            0x00,0x00,0xff,0xff,  0x00,0x00,0xff,0xff,  0x00,0x00,0xff,0xff,
                            0x00,0x00,0xff,0xff,  0x00,0x00,0x00,0xff,  0x00,0x00,0xff,0xff]
  img <- makeImageData 3 4 smallImage
  doc <- jsg "document"
  doc ^. js "body" ^. jss "innerHTML" "<canvas id=c width=10 height=10></canvas>"
  Just canvas <- doc ^. js1 "getElementById" "c" >>= fromJSVal
  Just ctx <- getContext canvas "2d" ([] :: [Object])
  let ctx' = CanvasRenderingContext2D (unRenderingContext ctx)
  putImageData ctx' img 3 4
  return ()

uint8ClampedArrayFromByteString :: ByteString -> GHCJSPure (Uint8ClampedArray)
uint8ClampedArrayFromByteString bs = GHCJSPure $ do
  buffer <- SomeBuffer <$> jsg1 "h$newByteArrayFromBase64String"
                                (decodeUtf8 $ B64.encode bs)
  arrbuff <- ghcjsPure (getArrayBuffer (buffer :: MutableBuffer))
  liftDOM (Uint8ClampedArray <$> new (jsg "Uint8ClampedArray") [pToJSVal arrbuff])

makeImageData :: Int -> Int -> ByteString -> JSM ImageData
makeImageData width height dat
  = do dat' <- ghcjsPure (uint8ClampedArrayFromByteString dat)
       newImageData dat' (fromIntegral width) (Just (fromIntegral height))

To build this, I used the following stack.yaml:

resolver: lts-8.12
extra-deps:
- ghcjs-dom-0.8.0.0
- ghcjs-dom-jsaddle-0.8.0.0
- jsaddle-0.8.3.0
- jsaddle-warp-0.8.3.0
- jsaddle-dom-0.8.0.0
- ref-tf-0.4.0.1