fwgl-javascript 0.1.0.6 → 0.1.1.0
raw patch · 5 files changed
+171/−79 lines, 5 filesdep +vectdep −Yampadep ~fwgl
Dependencies added: vect
Dependencies removed: Yampa
Dependency ranges changed: fwgl
Files
- FWGL/Backend/JavaScript.hs +126/−72
- FWGL/Backend/JavaScript/Event.hs +15/−5
- FWGL/Backend/JavaScript/WebGL/Raw.hs +16/−0
- FWGL/Backend/JavaScript/WebGL/Types.hs +12/−0
- fwgl-javascript.cabal +2/−2
FWGL/Backend/JavaScript.hs view
@@ -1,21 +1,26 @@ {-# LANGUAGE NullaryTypeClasses, TypeFamilies, UndecidableInstances #-} {-| The GHCJS/WebGL backend. This just exports the instances for 'BackendIO'- and 'GLES'. -}-module FWGL.Backend.JavaScript () where+ and 'GLES'.+ + 'createCanvas' doesn't really create new canvases, but uses the first <canvas> that it finds. Use createCanvas' to choose another <canvas>. -}+module FWGL.Backend.JavaScript (+ querySelector,+ createCanvas'+) where import Control.Applicative import Control.Concurrent+import Data.Maybe import qualified Data.HashMap.Strict as H import Data.IORef+import Data.Vect.Float import Data.Word-import FRP.Yampa import FWGL.Backend import FWGL.Backend.JavaScript.Event import qualified FWGL.Backend.JavaScript.WebGL as JS import FWGL.Graphics.Color import FWGL.Input-import FWGL.Vector import GHCJS.Foreign import GHCJS.Types import GHCJS.Marshal@@ -45,20 +50,61 @@ -> IO () foreign import javascript unsafe "document.querySelector($1)"- query :: JSString -> IO (JSRef a)+ querySelector :: JSString -> IO (JSRef a) foreign import javascript unsafe "$2.getAttribute($1)" getAttributeRaw :: JSString -> JSRef a -> IO JSString +foreign import javascript unsafe "$3.setAttribute($1, $2)"+ setAttributeRaw :: JSString -> JSString -> JSRef a -> IO ()++foreign import javascript unsafe "performance.now()"+ now :: IO Double+ getAttribute :: String -> JSRef a -> IO String getAttribute attr e = fromJSString <$> getAttributeRaw (toJSString attr) e +setAttribute :: String -> String -> JSRef a -> IO ()+setAttribute name val = setAttributeRaw (toJSString name) (toJSString val)+ foreign import javascript unsafe "window.requestAnimationFrame($1)" requestAnimationFrame :: JSFun (JSRef Double -> IO ()) -> IO () foreign import javascript unsafe "$1.focus()" focus :: JSRef a -> IO () +data Canvas = Canvas (JSRef ())+ Source+ (IORef JS.Ctx)+ (IORef (Int -> Int -> IO ()))+ (IORef (IO ()))++createCanvas' :: JSRef a -- ^ Canvas element (you can use 'querySelector').+ -> IO (FWGL.Backend.JavaScript.Canvas, Int, Int)+createCanvas' element = + do eventSrc <- source handledEvents element+ ctx <- JS.getCtx element+ ctxRef <- newIORef ctx+ resizeCb <- newIORef $ \_ _ -> return ()+ refreshCb <- newIORef $ return ()+ JS.getExtension ctx $ toJSString "WEBGL_depth_texture"+ vaoExt <- JS.getExtension ctx $+ toJSString "OES_vertex_array_object"+ setProp "vaoExt" vaoExt ctx+ (Just w) <- getProp "clientWidth" element >>= fromJSRef+ (Just h) <- getProp "clientHeight" element >>= fromJSRef+ focus element+ return (Canvas (castRef element) eventSrc ctxRef+ resizeCb refreshCb, w, h)++ where handledEvents = [ MouseUp, MouseDown, MouseMove+ , KeyUp, KeyDown, Resize ]++-- TODO: handle context lost+ instance BackendIO where+ type Canvas = FWGL.Backend.JavaScript.Canvas+ type BackendState = ()+ loadImage url f = asyncCallback1 NeverRetain callback >>= loadImageRaw (toJSString url) where callback img =@@ -74,52 +120,48 @@ forkIO $ loadTextFileRaw (toJSString url) fRight fLeft return () - setup initState draw customInp sigf =- do element <- query $ toJSString "canvas"- eventSrc <- source handledEvents element- ctx <- JS.getCtx element- JS.getExtension ctx $ toJSString "WEBGL_depth_texture"- (Just w) <- getProp "clientWidth" element >>= fromJSRef- (Just h) <- getProp "clientHeight" element >>= fromJSRef- focus element -- ... no- drawStateRef <- initState w h ctx >>= newIORef- initCustom <- customInp- reactStateRef <- reactInit (return $ initInput w h initCustom)- (\ _ _ -> actuate ctx drawStateRef)- sigf- onFrame $ frame reactStateRef eventSrc Nothing- where frame rsf src last crf =- do events <- clear src- custom <- customInp- (Just cur) <- fromJSRef crf- let tm = case last of- Just l -> cur - l- Nothing -> 0- react rsf (tm, Just $ Input events custom)- onFrame $ frame rsf src (Just cur)- - onFrame handler = asyncCallback1 NeverRetain handler+ initBackend = return ()++ createCanvas s _ = querySelector (toJSString s) >>= createCanvas'++ setCanvasSize w h (Canvas e src _ ref _) _ =+ do setAttribute "width" (show w) e+ setAttribute "height" (show h) e+ cb <- readIORef ref+ forkIO $ cb w h+ pushEvent Resize EventData {+ dataFramebufferSize = Just $ (w, h),+ dataPointer = Nothing,+ dataButton = Nothing,+ dataKey = Nothing } src++ setCanvasTitle _ _ _ = return ()++ setCanvasResizeCallback cb (Canvas _ _ _ ref _) _ =+ writeIORef ref cb++ setCanvasRefreshCallback cb (Canvas _ _ _ _ ref) _ =+ writeIORef ref cb++ popInput c (Canvas _ src _ _ _) _ = flip Input c <$> clear src++ getInput c (Canvas _ src _ _ _) _ = flip Input c <$> events src++ drawCanvas act _ (Canvas _ _ ctxRef _ _) _ = readIORef ctxRef >>= act++ safeFork _ = ($)++ -- TODO: block+ refreshLoop t c@(Canvas _ _ _ _ refreshRef) bs =+ do refresh <- readIORef refreshRef+ onFrame $ \_ -> refresh >> refreshLoop t c bs+ where onFrame handler = asyncCallback1 NeverRetain handler >>= requestAnimationFrame - initInput w h = Input $ H.singleton Resize [- EventData {- dataFramebufferSize = Just (w, h),- dataPointer = Nothing,- dataButton = Nothing,- dataKey = Nothing- }]- - actuate ctx ref out = readIORef ref >>=- draw out ctx >>=- -- execDraw (drawBegin >> drawScene s) >>=- writeIORef ref >> return False- handledEvents = [ MouseUp- , MouseDown- , MouseMove- , KeyUp- , KeyDown- , Resize ]+ getTime _ = (/ 1000) <$> now + terminateBackend _ = return ()+ instance GLES where type Ctx = JS.Ctx type GLEnum = Word@@ -137,6 +179,7 @@ type Program = JS.Program type FrameBuffer = JS.FrameBuffer type RenderBuffer = JS.RenderBuffer+ type VertexArrayObject = JS.VertexArrayObject -- type ActiveInfo = JS.ActiveInfo -- type ShaderPrecisionFormat = JS.ShaderPrecisionFormat type Array = JS.ArrayBufferView@@ -151,40 +194,42 @@ noBuffer = JS.noBuffer noTexture = JS.noTexture noArray = JS.noArray+ noVAO = JS.noVAO - encodeM2 (M2 (V2 a1 a2) (V2 b1 b2)) = JS.listToJSArray [ a1, a2, b1, b2]- >>= JS.float32Array+ encodeMat2 (Mat2 (Vec2 a1 a2) (Vec2 b1 b2)) =+ JS.listToJSArray [ a1, a2, b1, b2] >>= JS.float32Array - encodeM3 (M3 (V3 a1 a2 a3)- (V3 b1 b2 b3)- (V3 c1 c2 c3)) = JS.listToJSArray [ a1, a2, a3- , b1, b2, b3- , c1, c2, c3]- >>= JS.float32Array- encodeM4 (M4 (V4 a1 a2 a3 a4)- (V4 b1 b2 b3 b4)- (V4 c1 c2 c3 c4)- (V4 d1 d2 d3 d4) ) = JS.listToJSArray [ a1, a2, a3, a4- , b1, b2, b3, b4- , c1, c2, c3, c4- , d1, d2, d3, d4 ]- >>= JS.float32Array+ encodeMat3 (Mat3 (Vec3 a1 a2 a3)+ (Vec3 b1 b2 b3)+ (Vec3 c1 c2 c3)) = JS.listToJSArray [ a1, a2, a3+ , b1, b2, b3+ , c1, c2, c3]+ >>= JS.float32Array+ encodeMat4 (Mat4 (Vec4 a1 a2 a3 a4)+ (Vec4 b1 b2 b3 b4)+ (Vec4 c1 c2 c3 c4)+ (Vec4 d1 d2 d3 d4) ) =+ JS.listToJSArray [ a1, a2, a3, a4+ , b1, b2, b3, b4+ , c1, c2, c3, c4+ , d1, d2, d3, d4 ]+ >>= JS.float32Array encodeFloats v = JS.listToJSArray v >>= JS.float32View -- TODO: decent implementation- encodeV2s v = JS.toJSArray next (False, v) >>= JS.float32View- where next (False, xs@(V2 x _ : _)) = Just (x, (True, xs))- next (True, V2 _ y : xs) = Just (y, (False, xs))+ encodeVec2s v = JS.toJSArray next (False, v) >>= JS.float32View+ where next (False, xs@(Vec2 x _ : _)) = Just (x, (True, xs))+ next (True, Vec2 _ y : xs) = Just (y, (False, xs)) next (_, []) = Nothing - encodeV3s v = JS.toJSArray next (0, v) >>= JS.float32View- where next (0, xs@(V3 x _ _ : _)) = Just (x, (1, xs))- next (1, xs@(V3 _ y _ : _)) = Just (y, (2, xs))- next (2, V3 _ _ z : xs) = Just (z, (0, xs))+ encodeVec3s v = JS.toJSArray next (0, v) >>= JS.float32View+ where next (0, xs@(Vec3 x _ _ : _)) = Just (x, (1, xs))+ next (1, xs@(Vec3 _ y _ : _)) = Just (y, (2, xs))+ next (2, Vec3 _ _ z : xs) = Just (z, (0, xs)) next (_, []) = Nothing -- TODO- encodeV4s = error "encodeV4s: TODO"+ encodeVec4s = error "encodeVec4s: TODO" encodeUShorts v = JS.listToJSArray v >>= JS.uint16View @@ -195,6 +240,11 @@ next (3, Color _ _ _ w : xs) = Just (w, (0, xs)) next (_, []) = Nothing + newByteArray = fmap castRef . JS.uint8ArraySize++ decodeBytes = (>>= mapM (fmap fromJust . fromJSRef))+ . fromArray . castRef+ glActiveTexture = JS.glActiveTexture glAttachShader = JS.glAttachShader glBindAttribLocation = JS.glBindAttribLocation@@ -202,6 +252,7 @@ glBindFramebuffer = JS.glBindFramebuffer glBindRenderbuffer = JS.glBindRenderbuffer glBindTexture = JS.glBindTexture+ glBindVertexArray = JS.glBindVertexArrayOES glBlendColor = JS.glBlendColor glBlendEquation = JS.glBlendEquation glBlendEquationSeparate = JS.glBlendEquationSeparate@@ -226,6 +277,7 @@ glCreateRenderbuffer = JS.glCreateRenderbuffer glCreateShader = JS.glCreateShader glCreateTexture = JS.glCreateTexture+ glCreateVertexArray = JS.glCreateVertexArrayOES glCullFace = JS.glCullFace glDeleteBuffer = JS.glDeleteBuffer glDeleteFramebuffer = JS.glDeleteFramebuffer@@ -233,6 +285,7 @@ glDeleteRenderbuffer = JS.glDeleteRenderbuffer glDeleteShader = JS.glDeleteShader glDeleteTexture = JS.glDeleteTexture+ glDeleteVertexArray = JS.glDeleteVertexArrayOES glDepthFunc = JS.glDepthFunc glDepthMask = JS.glDepthMask glDepthRange = JS.glDepthRange@@ -275,6 +328,7 @@ glIsRenderbuffer = JS.glIsRenderbuffer glIsShader = JS.glIsShader glIsTexture = JS.glIsTexture+ glIsVertexArray = JS.glIsVertexArrayOES glLineWidth = JS.glLineWidth glLinkProgram = JS.glLinkProgram glPixelStorei = JS.glPixelStorei
FWGL/Backend/JavaScript/Event.hs view
@@ -1,9 +1,10 @@--- TODO: rewrite everything+-- old code module FWGL.Backend.JavaScript.Event ( InputEvent(..), Source, source,+ pushEvent, addEvent, addEvents, events,@@ -35,6 +36,10 @@ addEvents es s return s +pushEvent :: Event -> EventData -> Source -> IO ()+pushEvent e eventData (Source _ map) =+ modifyIORef map $ H.insertWith (flip (++)) e [ eventData ]+ events :: Source -> IO (H.HashMap Event [EventData]) events (Source _ c) = readIORef c @@ -45,8 +50,8 @@ addEvents es s = mapM_ (flip addEvent s) es addEvent :: Event -> Source -> IO ()-addEvent e (Source j c) = asyncCallback1 NeverRetain handler >>=- addHandler j (toJSString $ eventName e)+addEvent e s@(Source j _) = asyncCallback1 NeverRetain handler >>=+ addHandler j (toJSString $ eventName e) where prop p d = getProp p d >>= fromJSRef handler d = do@@ -56,10 +61,15 @@ return $ (,) <$> w <*> h) <*> (do x <- prop "clientX" d y <- prop "clientY" d- return $ (,) <$> x <*> y)+ l <- prop "offsetLeft" j+ t <- prop "offsetTop" j+ return $+ (,) <$> (liftA2 (-) x l)+ <*> (liftA2 (-) y t)+ ) <*> ((getButton <$>) <$> prop "button" d) <*> ((getKey <$>) <$> prop "keyCode" d)- modifyIORef c $ H.insertWith (flip (++)) e [ eventData ]+ pushEvent e eventData s eventName :: Event -> String -- eventName (Other s) = s
FWGL/Backend/JavaScript/WebGL/Raw.hs view
@@ -513,5 +513,21 @@ foreign import javascript unsafe "$1.viewport($2, $3, $4, $5)" glViewport :: Ctx -> Int -> Int -> Int -> Int -> IO () +-- Extensions+ foreign import javascript unsafe "$1.getExtension($2)" getExtension :: Ctx -> JSString -> IO (JSRef a)++-- OES_vertex_array_object++foreign import javascript unsafe "$1.vaoExt.createVertexArrayOES()"+ glCreateVertexArrayOES :: Ctx -> IO VertexArrayObject++foreign import javascript unsafe "$1.vaoExt.bindVertexArrayOES($2)"+ glBindVertexArrayOES :: Ctx -> VertexArrayObject -> IO()++foreign import javascript unsafe "$1.vaoExt.deleteVertexArrayOES($2)"+ glDeleteVertexArrayOES :: Ctx -> VertexArrayObject -> IO()++foreign import javascript unsafe "$1.vaoExt.isVertexArrayOES($2)"+ glIsVertexArrayOES :: Ctx -> VertexArrayObject -> IO Bool
FWGL/Backend/JavaScript/WebGL/Types.hs view
@@ -11,6 +11,7 @@ Buffer, FrameBuffer, RenderBuffer,+ VertexArrayObject, Texture, UniformLocation, ActiveInfo,@@ -21,6 +22,7 @@ int32Array, uint16Array, uint8Array,+ uint8ArraySize, float32View, int32View, uint16View,@@ -29,6 +31,7 @@ listToJSArray, noBuffer, noTexture,+ noVAO, noArray ) where @@ -71,6 +74,9 @@ data RenderBuffer_ type RenderBuffer = JSRef RenderBuffer_ +data VertexArrayObject_+type VertexArrayObject = JSRef VertexArrayObject_+ data Texture_ type Texture = JSRef Texture_ @@ -95,6 +101,9 @@ noTexture :: Texture noTexture = jsNull +noVAO :: VertexArrayObject+noVAO = jsNull+ noArray :: IO ArrayBufferView noArray = return jsNull @@ -134,6 +143,9 @@ foreign import javascript unsafe "$r = new Uint8Array($1);" uint8Array :: JSArray Word8 -> IO Uint8Array++foreign import javascript unsafe "$r = new Uint8Array($1);"+ uint8ArraySize :: Int -> IO Uint8Array foreign import javascript unsafe "$r = $1.getContext(\"webgl\");" getCtx :: JSRef a -> IO Ctx
fwgl-javascript.cabal view
@@ -1,5 +1,5 @@ name: fwgl-javascript-version: 0.1.0.6+version: 0.1.1.0 synopsis: FWGL GHCJS backend description: FWGL GHCJS backend homepage: https://github.com/ziocroc/FWGL@@ -16,6 +16,6 @@ exposed-modules: FWGL.Backend.JavaScript other-modules: FWGL.Backend.JavaScript.WebGL, FWGL.Backend.JavaScript.Event, FWGL.Backend.JavaScript.WebGL.Const, FWGL.Backend.JavaScript.WebGL.Types, FWGL.Backend.JavaScript.WebGL.Raw other-extensions: FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances- build-depends: fwgl > 0.1.2.0 && < 0.2, Yampa, base >=4.7 && <4.9, hashable >=1.2 && <1.3, unordered-containers >=0.2 && <0.3, ghcjs-base+ build-depends: fwgl >= 0.1.3 && < 0.1.4, base >=4.7 && <4.9, hashable >=1.2 && <1.3, unordered-containers >=0.2 && <0.3, ghcjs-base, vect hs-source-dirs: . default-language: Haskell2010