reflex-dom-fragment-shader-canvas (empty) → 0.1
raw patch · 6 files changed
+248/−0 lines, 6 filesdep +basedep +containersdep +ghcjs-domsetup-changed
Dependencies added: base, containers, ghcjs-dom, jsaddle, lens, reflex-dom, reflex-dom-fragment-shader-canvas, text, transformers
Files
- ChangeLog.md +5/−0
- LICENSE +20/−0
- Reflex/Dom/FragmentShaderCanvas.hs +110/−0
- Setup.hs +2/−0
- demo/Main.hs +64/−0
- reflex-dom-fragment-shader-canvas.cabal +47/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for reflex-dom-fragment-shader-canvas++## 0.1 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2018 Joachim Breitner++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Reflex/Dom/FragmentShaderCanvas.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# OPTIONS_GHC -Wno-unused-do-bind #-}+module Reflex.Dom.FragmentShaderCanvas (fragmentShaderCanvas, trivialFragmentShader) where++import Data.Map (Map)+import Data.Text as Text (Text, unlines)+import Control.Lens ((^.))+import Control.Monad.IO.Class++import Reflex.Dom++import GHCJS.DOM.Types hiding (Text)+import Language.Javascript.JSaddle.String+import Language.Javascript.JSaddle.Object (js1, js2, jsf, js, js0, new, jsg)++vertexShaderSource :: Text+vertexShaderSource =+ "attribute vec2 a_position;\+ \void main() {\+ \ gl_Position = vec4(a_position, 0, 1);\+ \}"++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);"+ , "}"+ ]+++paintGL :: (MonadJSM m) => JSVal -> (Maybe Text -> m ()) -> Text -> m ()+paintGL canvas printErr fragmentShaderSource = 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")++ 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")++ vertexShader <- liftJSM $ gl ^. js1 ("createShader"::Text) (gl ^. js ("VERTEX_SHADER"::Text))+ liftJSM $ gl ^. js2 ("shaderSource"::Text) vertexShader vertexShaderSource+ liftJSM $ gl ^. js1 ("compileShader"::Text) 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+ -- 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)++ 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+ -- 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++ windowSizeLocation <- liftJSM $ gl ^. js2 ("getUniformLocation"::Text) program ("u_windowSize"::Text)+ liftJSM $ gl ^. jsf ("uniform2f"::Text) (windowSizeLocation, gl ^. js ("drawingBufferWidth"::Text), gl ^. js ("drawingBufferHeight"::Text))++ liftJSM $ gl ^. jsf ("drawArrays"::Text) (gl ^. js ("TRIANGLES"::Text), 0::Int, 6::Int);+ return ()++fragmentShaderCanvas ::+ (MonadWidget t m) =>+ (Map Text Text) ->+ Dynamic t Text ->+ m (Dynamic t (Maybe Text))+fragmentShaderCanvas attrs fragmentShaderSource = do+ (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+ holdDyn Nothing eError
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ demo/Main.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE RecursiveDo #-}+import Reflex.Dom+import Reflex.Dom.FragmentShaderCanvas+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++ dError <- divClass "right" $ fragmentShaderCanvas+ (mconcat [ "width" =: "1000" , "height" =: "1000" ])+ (_textArea_value inp)+ return ()++css :: T.Text+css = T.unlines+ [ "document {"+ , " margin: 0;"+ , " padding: 0;"+ , " width: 100vw;"+ , " height: 100vh;"+ , "}"+ , "body {"+ , " margin: 0;"+ , " padding: 0;"+ , " display: flex;"+ , " align-items: stretch;"+ , " width: 100vw;"+ , " height: 100vh;"+ , "}"+ , "textarea {"+ , " width: 50vw;"+ , " height: 50vh;"+ , "}"+ , ".error {"+ , " width: 100%;"+ , " text-align: left;"+ , " white-space:pre;"+ , " font-family:mono;"+ , " padding-top: 2em;"+ , " overflow: scrolll"+ , "}"+ , ".left {"+ , " width:50%;"+ , " padding:2em;"+ , "}"+ , ".right {"+ , " width:50%;"+ , " display: flex;"+ , "}"+ , "canvas {"+ , " border: 1px solid black;"+ , " max-width: 80%;"+ , " max-height: 80%;"+ , " margin:auto;"+ , "}"+ ]
+ reflex-dom-fragment-shader-canvas.cabal view
@@ -0,0 +1,47 @@+name: reflex-dom-fragment-shader-canvas+version: 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.+ .+ It also provides possible compiler errors in another `Dynamic t Text`.+homepage: https://github.com/nomeata/reflex-dom-fragment-shader-canvas+license: MIT+license-file: LICENSE+author: Joachim Breitner+maintainer: mail@joachim-breitner.de+copyright: 2018 Joachim Breitner+category: Web+build-type: Simple+extra-source-files: ChangeLog.md+cabal-version: >=1.10+tested-with: GHC ==8.2++source-repository head+ type: git+ location: https://github.com/nomeata/reflex-dom-fragment-shader-canvas++library+ exposed-modules: Reflex.Dom.FragmentShaderCanvas+ build-depends: base >=4.2 && <5+ build-depends: jsaddle >=0.9.5.0 && <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+ default-language: Haskell2010++executable demo+ main-is: Main.hs+ build-depends: base >=4.2 && <5+ build-depends: text+ build-depends: reflex-dom >= 0.4+ build-depends: reflex-dom-fragment-shader-canvas+ hs-source-dirs: demo+ default-language: Haskell2010+ ghc-options: -threaded -rtsopts+