reflex-dom-fragment-shader-canvas 0.1 → 0.1.0.1
raw patch · 4 files changed
+153/−97 lines, 4 filesdep ~ghcjs-domdep ~jsaddle
Dependency ranges changed: ghcjs-dom, jsaddle
Files
- ChangeLog.md +5/−1
- Reflex/Dom/FragmentShaderCanvas.hs +105/−55
- demo/Main.hs +38/−38
- reflex-dom-fragment-shader-canvas.cabal +5/−3
ChangeLog.md view
@@ -1,5 +1,9 @@ # Revision history for reflex-dom-fragment-shader-canvas -## 0.1 -- YYYY-mm-dd+## 0.1.0.1 -- 2018-08-08++* Try to work around the problem of lost WebGL contexts++## 0.1 -- 2018-07-18 * First version. Released on an unsuspecting world.
Reflex/Dom/FragmentShaderCanvas.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-unused-do-bind #-} module Reflex.Dom.FragmentShaderCanvas (fragmentShaderCanvas, trivialFragmentShader) where @@ -8,12 +9,19 @@ import Control.Lens ((^.)) import Control.Monad.IO.Class -import Reflex.Dom+import Reflex.Dom hiding (preventDefault) +import GHCJS.DOM+import GHCJS.DOM.Document import GHCJS.DOM.Types hiding (Text)-import Language.Javascript.JSaddle.String-import Language.Javascript.JSaddle.Object (js1, js2, jsf, js, js0, new, jsg)+import GHCJS.DOM.HTMLCanvasElement+import GHCJS.DOM.WebGLRenderingContextBase+import GHCJS.DOM.CanvasRenderingContext2D+import GHCJS.DOM.EventM (on, preventDefault)+import qualified GHCJS.DOM.EventTargetClosures as DOM (EventName, unsafeEventName)+import Language.Javascript.JSaddle.Object (new, jsg, js1) + vertexShaderSource :: Text vertexShaderSource = "attribute vec2 a_position;\@@ -21,76 +29,100 @@ \ gl_Position = vec4(a_position, 0, 1);\ \}" +-- | An example fragment shader program, drawing a red circle trivialFragmentShader :: Text trivialFragmentShader = Text.unlines [ "precision mediump float;" , "uniform vec2 u_windowSize;" , "void main() {" , " float s = 2.0 / min(u_windowSize.x, u_windowSize.y);"- , " vec2 pos0 = s * (gl_FragCoord.xy - 0.5 * u_windowSize);"- , " if (length(pos0) > 1.0) { gl_FragColor = vec4(0,0,0,0); return; }"- , " vec3 col0 = vec3(1.0,0.0,0.0);"- , " gl_FragColor = vec4(col0, 1.0);"+ , " vec2 pos = s * (gl_FragCoord.xy - 0.5 * u_windowSize);"+ , " // pos is a scaled pixel position, (0,0) is in the center of the canvas"+ , " // If the position is outside the inscribed circle, make it transparent"+ , " if (length(pos) > 1.0) { gl_FragColor = vec4(0,0,0,0); return; }"+ , " // Otherwise, return red"+ , " gl_FragColor = vec4(1.0,0.0,0.0,1.0);" , "}" ] +onOffScreenCanvas :: MonadDOM m => HTMLCanvasElement -> (HTMLCanvasElement -> m ()) -> m ()+onOffScreenCanvas onScreen paint = do+ doc <- currentDocumentUnchecked+ offScreen <- createElement doc ("canvas" :: JSString)+ >>= unsafeCastTo HTMLCanvasElement -paintGL :: (MonadJSM m) => JSVal -> (Maybe Text -> m ()) -> Text -> m ()-paintGL canvas printErr fragmentShaderSource = do+ getWidth onScreen >>= setWidth offScreen+ getHeight onScreen >>= setHeight offScreen++ paint offScreen++ ctx <- getContextUnsafe onScreen ("2d"::Text) ([]::[()])+ ctx <- unsafeCastTo CanvasRenderingContext2D ctx+ drawImage ctx offScreen 0 0+ return ()+++paintGL :: MonadDOM m => (Maybe Text -> m ()) -> Text -> HTMLCanvasElement -> m ()+paintGL printErr fragmentShaderSource canvas = do -- adaption of -- https://blog.mayflower.de/4584-Playing-around-with-pixel-shaders-in-WebGL.html- gl <- liftJSM $ canvas ^. js1 ("getContext"::Text) ("experimental-webgl"::Text)- liftJSM $ gl ^. jsf ("viewport"::Text) (0::Int, 0::Int, gl ^. js ("drawingBufferWidth"::Text), gl ^. js ("drawingBufferHeight"::Text)) - -- gl ^. jsf "clearColor" [1.0, 0.0, 0.0, 1.0 :: Double]- -- gl ^. js1 "clear" (gl^. js "COLOR_BUFFER_BIT")+ gl <- getContextUnsafe canvas ("experimental-webgl"::Text) ([]::[()])+ gl <- unsafeCastTo WebGLRenderingContext gl - buffer <- liftJSM $ gl ^. js0 ("createBuffer"::Text)- liftJSM $ gl ^. jsf ("bindBuffer"::Text) (gl ^. js ("ARRAY_BUFFER"::Text), buffer)- liftJSM $ gl ^. jsf ("bufferData"::Text)- ( gl ^. js ("ARRAY_BUFFER"::Text)- , new (jsg ("Float32Array"::Text)) [[- -1.0, -1.0,- 1.0, -1.0,- -1.0, 1.0,- -1.0, 1.0,- 1.0, -1.0,- 1.0, 1.0 :: Double]]- , gl ^. js ("STATIC_DRAW"::Text)- )- -- jsg "console" ^. js1 "log" (gl ^. js0 "getError")+ w <- getDrawingBufferWidth gl+ h <- getDrawingBufferHeight gl+ viewport gl 0 0 w h - vertexShader <- liftJSM $ gl ^. js1 ("createShader"::Text) (gl ^. js ("VERTEX_SHADER"::Text))- liftJSM $ gl ^. js2 ("shaderSource"::Text) vertexShader vertexShaderSource- liftJSM $ gl ^. js1 ("compileShader"::Text) vertexShader+ buffer <- createBuffer gl+ bindBuffer gl ARRAY_BUFFER (Just buffer)+ array <- liftDOM (new (jsg ("Float32Array"::Text))+ [[ -1.0, -1.0,+ 1.0, -1.0,+ -1.0, 1.0,+ -1.0, 1.0,+ 1.0, -1.0,+ 1.0, 1.0 :: Double]])+ >>= unsafeCastTo Float32Array+ let array' = uncheckedCastTo ArrayBuffer array+ bufferData gl ARRAY_BUFFER (Just array') STATIC_DRAW++ vertexShader <- createShader gl VERTEX_SHADER+ shaderSource gl (Just vertexShader) vertexShaderSource+ compileShader gl (Just vertexShader) -- jsg "console" ^. js1 "log" (gl ^. js1 "getShaderInfoLog" vertexShader) - fragmentShader <- liftJSM $ gl ^. js1 ("createShader"::Text) (gl ^. js ("FRAGMENT_SHADER"::Text))- liftJSM $ gl ^. js2 ("shaderSource"::Text) fragmentShader fragmentShaderSource- liftJSM $ gl ^. js1 ("compileShader"::Text) fragmentShader+ fragmentShader <- createShader gl FRAGMENT_SHADER+ shaderSource gl (Just fragmentShader) fragmentShaderSource+ compileShader gl (Just fragmentShader) -- jsg "console" ^. js1 "log" (gl ^. js1 "getShaderInfoLog" fragmentShader)- err <- liftJSM $ gl ^. js1 ("getShaderInfoLog"::Text) fragmentShader- -- liftJSM $ jsg ("console"::Text) ^. js1 ("log"::Text) err- printErr . fmap textFromJSString =<< liftJSM (fromJSVal err)+ err <- getShaderInfoLog gl (Just fragmentShader)+ printErr err - program <- liftJSM $ gl ^. js0 ("createProgram"::Text)- liftJSM $ gl ^. js2 ("attachShader"::Text) program vertexShader- liftJSM $ gl ^. js2 ("attachShader"::Text) program fragmentShader- liftJSM $ gl ^. js1 ("linkProgram"::Text) program- liftJSM $ gl ^. js1 ("useProgram"::Text) program+ program <- createProgram gl+ attachShader gl (Just program) (Just vertexShader)+ attachShader gl (Just program) (Just fragmentShader)+ linkProgram gl (Just program)+ useProgram gl (Just program) -- jsg "console" ^. js1 "log" (gl ^. js1 "getProgramInfoLog" program) - positionLocation <- liftJSM $ gl ^. js2 ("getAttribLocation"::Text) program ("a_position"::Text)- liftJSM $ gl ^. js1 ("enableVertexAttribArray"::Text) positionLocation- liftJSM $ gl ^. jsf ("vertexAttribPointer"::Text) (positionLocation, 2::Int, gl ^. js ("FLOAT"::Text), False, 0::Int, 0::Int)- liftJSM $ jsg ("console"::Text) ^. js1 ("log"::Text) program+ positionLocation <- getAttribLocation gl (Just program) ("a_position" :: Text)+ enableVertexAttribArray gl (fromIntegral positionLocation)+ vertexAttribPointer gl (fromIntegral positionLocation) 2 FLOAT False 0 0+ -- liftJSM $ jsg ("console"::Text) ^. js1 ("log"::Text) program - windowSizeLocation <- liftJSM $ gl ^. js2 ("getUniformLocation"::Text) program ("u_windowSize"::Text)- liftJSM $ gl ^. jsf ("uniform2f"::Text) (windowSizeLocation, gl ^. js ("drawingBufferWidth"::Text), gl ^. js ("drawingBufferHeight"::Text))+ windowSizeLocation <- getUniformLocation gl (Just program) ("u_windowSize" :: Text)+ uniform2f gl (Just windowSizeLocation) (fromIntegral w) (fromIntegral h) - liftJSM $ gl ^. jsf ("drawArrays"::Text) (gl ^. js ("TRIANGLES"::Text), 0::Int, 6::Int);+ drawArrays gl TRIANGLES 0 6 return () +webglcontextrestored :: DOM.EventName HTMLCanvasElement WebGLContextEvent+webglcontextrestored = DOM.unsafeEventName "webglcontextrestored"++webglcontextlost :: DOM.EventName HTMLCanvasElement WebGLContextEvent+webglcontextlost = DOM.unsafeEventName "webglcontextlost"+ fragmentShaderCanvas :: (MonadWidget t m) => (Map Text Text) ->@@ -100,11 +132,29 @@ (canvasEl, _) <- elAttr' "canvas" attrs $ blank (eError, reportError) <- newTriggerEvent pb <- getPostBuild- performEvent $ (<$ pb) $ do- e <- liftJSM $ fromJSValUnchecked =<< toJSVal (_element_raw canvasEl)- src0 <- sample (current fragmentShaderSource)- paintGL e (liftIO . reportError) src0- performEvent $ (<$> updated fragmentShaderSource) $ \src -> do- e <- liftJSM $ fromJSValUnchecked =<< toJSVal (_element_raw canvasEl)- paintGL e (liftIO . reportError) src++ domEl <- unsafeCastTo HTMLCanvasElement $ _element_raw canvasEl++ {-+ eContextBack <- wrapDomEvent domEl (`on` webglcontextrestored) (return ())+ eContextLost <- wrapDomEvent domEl (`on` webglcontextlost) preventDefault++ performEvent $ (<$> eContextLost) $ \() -> do+ liftJSM $+ jsg ("console"::Text) ^. js1 ("log"::Text) ("lost" :: Text)++ performEvent $ (<$> eContextBack) $ \() -> do+ liftJSM $+ jsg ("console"::Text) ^. js1 ("log"::Text) ("back" :: Text)+ -}++ let eDraw = leftmost+ [ updated fragmentShaderSource+ , tag (current fragmentShaderSource) pb+ -- , tag (current fragmentShaderSource) eContextBack+ ]++ performEvent $ (<$> eDraw) $ \src -> do+ onOffScreenCanvas domEl $ paintGL (liftIO . reportError) src+ holdDyn Nothing eError
demo/Main.hs view
@@ -6,59 +6,59 @@ import qualified Data.Text as T main :: IO ()-main = mainWidgetWithHead- (el "style" (text css) >> el "title" (text "Fragment Shader Demo")) $ mdo- inp <- divClass "left" $ do- inp <- textArea $ def- & textAreaConfig_initialValue .~ trivialFragmentShader- divClass "error" $ dynText (maybe "" id <$> dError)- return inp+main = mainWidgetWithHead htmlHead $ mdo+ inp <- divClass "left" $ do+ inp <- textArea $ def+ & textAreaConfig_initialValue .~ trivialFragmentShader+ divClass "error" $ dynText (maybe "" id <$> dError)+ return inp - dError <- divClass "right" $ fragmentShaderCanvas- (mconcat [ "width" =: "1000" , "height" =: "1000" ])- (_textArea_value inp)- return ()+ dError <- divClass "right" $ fragmentShaderCanvas+ -- Here we determine the resolution of the canvas+ -- It would be desireable to do so dynamically, based on the widget+ -- size. But Reflex.Dom.Widget.Resize messes with the CSS layout.+ (mconcat [ "width" =: "1000" , "height" =: "1000" ])+ (_textArea_value inp)+ return ()+ where+ htmlHead :: DomBuilder t m => m ()+ htmlHead = do+ el "style" (text css)+ el "title" (text "Fragment Shader Demo") css :: T.Text css = T.unlines- [ "document {"+ [ "html {" , " margin: 0;"- , " padding: 0;"- , " width: 100vw;"- , " height: 100vh;"+ , " height: 100%;" , "}" , "body {"- , " margin: 0;"- , " padding: 0;" , " display: flex;"- , " align-items: stretch;"- , " width: 100vw;"- , " height: 100vh;"+ , " height: 100%;" , "}"+ , ".left {"+ , " flex:1 1 0;"+ , " display:flex;"+ , " flex-direction:column;"+ , " padding:1em;"+ , "}"+ , ".right {"+ , " flex:1 1 0;"+ , "}" , "textarea {"- , " width: 50vw;"- , " height: 50vh;"+ , " resize:vertical;"+ , " height:50%;" , "}" , ".error {"- , " width: 100%;"+ , " margin-top:1em;" , " text-align: left;"- , " white-space:pre;" , " font-family:mono;"- , " padding-top: 2em;"- , " overflow: scrolll"- , "}"- , ".left {"- , " width:50%;"- , " padding:2em;"- , "}"- , ".right {"- , " width:50%;"- , " display: flex;"+ , " width:100%;"+ , " overflow: auto;" , "}" , "canvas {"- , " border: 1px solid black;"- , " max-width: 80%;"- , " max-height: 80%;"- , " margin:auto;"+ , " height:100%;"+ , " width:100%;"+ , " object-fit:contain;" , "}" ]
reflex-dom-fragment-shader-canvas.cabal view
@@ -1,11 +1,13 @@ name: reflex-dom-fragment-shader-canvas-version: 0.1+version: 0.1.0.1 synopsis: A reflex-dom widget to draw on a canvas with a fragment shader program description: This simple reflex-dom widget takes a `Dynamic t Text` value representing the source code of a WebGL fragment shader, and renders it to a HTML canvas element. .+ A live demo can be found at <https://nomeata.github.io/reflex-dom-fragment-shader-canvas/>.+ . It also provides possible compiler errors in another `Dynamic t Text`. homepage: https://github.com/nomeata/reflex-dom-fragment-shader-canvas license: MIT@@ -26,10 +28,10 @@ library exposed-modules: Reflex.Dom.FragmentShaderCanvas build-depends: base >=4.2 && <5- build-depends: jsaddle >=0.9.5.0 && <0.10+ build-depends: ghcjs-dom >=0.9.2 && <0.10+ build-depends: jsaddle >=0.9.4 && <0.10 build-depends: reflex-dom >= 0.4 build-depends: lens >=4.0.7 && <5.0- build-depends: ghcjs-dom build-depends: transformers build-depends: containers build-depends: text