shine 0.1.0.0 → 0.2.0.0

raw patch · 8 files changed

+148/−92 lines, 8 filesdep ~basedep ~ghcjs-domdep ~keycodePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base, ghcjs-dom, keycode

API changes (from Hackage documentation)

Files

• ChangeLog.md +12/−0
• README.md +4/−0
• shine.cabal +13/−7
• src/Graphics/Shine.hs +31/−30
• src/Graphics/Shine/Picture.hs +12/−12
• src/Graphics/Shine/Render.hs +26/−17
• tests/everything.hs +20/−26
• tests/simpleInteraction.hs +30/−0

@@ -0,0 +1,12 @@+# Revision history for shine++## 0.1.0.0  -- 2016-04-20++* First version.++## 0.2.0.0  -- 2017-06-23++* Changed WIndow to Document in some places+* Use Double for everything+* Use the new ghcjs-dom types+

@@ -1,8 +1,12 @@ # Shine - Declarative Graphics for the Web +[![Build Status](https://travis-ci.org/fgaz/shine.svg?branch=master)](https://travis-ci.org/fgaz/shine)+ Shine wraps javascript's drawing functions in a declarative API.  Heavily inspired by [gloss](http://gloss.ouroborus.net/).++**demo** (compiled tests) [here](http://fgaz.me/shine/tests)  ## Compiling 

@@ -1,10 +1,10 @@ name: shine-version: 0.1.0.0+version: 0.2.0.0 cabal-version: >=1.8 build-type: Simple license: MIT license-file: LICENSE-copyright: (c) 2016 Francesco Gazzetta+copyright: (c) 2016-2017 Francesco Gazzetta author: Francesco Gazzetta maintainer: Francesco Gazzetta <francygazz@gmail.com> stability: experimental@@ -16,8 +16,8 @@   Heavily inspired by Gloss.   .   Read the README for an overview of the library.-extra-source-files:  README.md-category: Web, Graphics+extra-source-files:  README.md, ChangeLog.md+category: Web, Graphics, Javascript data-dir: ""  source-repository head@@ -31,9 +31,9 @@                      Graphics.Shine.Picture,                      Graphics.Shine.Render     build-depends: base >=4.2 && <5,-                   ghcjs-dom >=0.2 && <0.3,+                   ghcjs-dom >=0.9 && <0.10,                    ghcjs-prim,-                   keycode,+                   keycode >=0.2 && <0.3,                    time,                    mtl,                    transformers@@ -41,8 +41,14 @@     ghc-options: -O2 -Wall   --TODO run this in an actual window-test-suite test-shine+test-suite test-shine-animateeverything     type:       exitcode-stdio-1.0     main-is:    everything.hs+    hs-source-dirs: tests+    build-depends: base, ghcjs-dom, shine++test-suite test-shine-simpleinteraction+    type:       exitcode-stdio-1.0+    main-is:    simpleInteraction.hs     hs-source-dirs: tests     build-depends: base, ghcjs-dom, shine

@@ -24,18 +24,18 @@   playIO ) where -import GHCJS.DOM (webViewGetDomDocument)-import GHCJS.DOM.Document (getBody, getElementById, mouseUp, mouseDown, mouseMove, wheel, keyDown, keyUp)+import GHCJS.DOM.Document (getBody)+import GHCJS.DOM.NonElementParentNode (getElementById) import GHCJS.DOM.EventM (on, mouseButton, mouseCtrlKey, mouseAltKey, mouseShiftKey, mouseMetaKey, mouseOffsetXY, uiKeyCode, event)+import GHCJS.DOM.GlobalEventHandlers (mouseDown, mouseUp, mouseMove, wheel, keyUp, keyDown) import GHCJS.DOM.EventTarget (IsEventTarget) import GHCJS.DOM.WheelEvent (getDeltaX, getDeltaY) import GHCJS.DOM.KeyboardEvent (KeyboardEvent, getCtrlKey, getShiftKey, getAltKey, getMetaKey) import GHCJS.DOM.Element (setInnerHTML) import GHCJS.DOM.HTMLCanvasElement (getContext) import GHCJS.DOM.CanvasRenderingContext2D-import GHCJS.DOM.Types (Window, Element, MouseEvent, IsDocument)+import GHCJS.DOM.Types (JSM, Element, MouseEvent, IsDocument, Document) -import GHCJS.Prim (JSVal) import Web.KeyCode (keyCodeLookup) import Unsafe.Coerce (unsafeCoerce) import Control.Concurrent (threadDelay)@@ -53,14 +53,13 @@  -- | Get a context from a canvas element. toContext :: Element -- ^ this __must__ be a canvas-          -> IO CanvasRenderingContext2D+          -> JSM CanvasRenderingContext2D toContext c = do-    ctx <- getContext (unsafeCoerce c) "2d" :: IO JSVal+    Just ctx <- getContext (unsafeCoerce c) "2d" ["2d"]     return $ unsafeCoerce ctx --how do i get a 2dcontext properly? This works for now. -customAttributesCanvas :: Window -> String -> IO CanvasRenderingContext2D-customAttributesCanvas webView attrs = do-    Just doc <- webViewGetDomDocument webView+customAttributesCanvas :: Document -> String -> JSM CanvasRenderingContext2D+customAttributesCanvas doc attrs = do     Just body <- getBody doc     setInnerHTML body $ Just canvasHtml     Just c <- getElementById doc "canvas"@@ -69,16 +68,16 @@         canvasHtml = "<canvas id=\"canvas\" " ++ attrs ++ " </canvas> "  -- | Create a full screen canvas-fullScreenCanvas :: Window -> IO CanvasRenderingContext2D-fullScreenCanvas webView = customAttributesCanvas webView attributes+fullScreenCanvas :: Document -> JSM CanvasRenderingContext2D+fullScreenCanvas doc = customAttributesCanvas doc attributes   where attributes :: String         attributes = "style=\"border:1px \                      \solid #000000; \                      \top:0px;bottom:0px;left:0px;right:0px;\""  -- | Create a fixed size canvas given the dimensions-fixedSizeCanvas :: Window -> Int -> Int -> IO CanvasRenderingContext2D-fixedSizeCanvas webView x y = customAttributesCanvas webView $ attributes x y+fixedSizeCanvas :: Document -> Int -> Int -> JSM CanvasRenderingContext2D+fixedSizeCanvas doc x y = customAttributesCanvas doc $ attributes x y   where attributes :: Int -> Int -> String         attributes x' y' = "width=\""++ show x' ++ "\" \                            \height=\""++ show y' ++ "\" \@@ -87,24 +86,25 @@  -- | Draws a picture which depends only on the time animate :: CanvasRenderingContext2D -- ^ the context to draw on-        -> Float -- ^ FPS-        -> (Float -> Picture) -- ^ Your drawing function-        -> IO ()+        -> Double -- ^ FPS+        -> (Double -> Picture) -- ^ Your drawing function+        -> JSM () animate ctx fps f = animateIO ctx fps $ return . f  -- | Draws a picture which depends only on the time... and everything else, -- since you can do I/O. animateIO :: CanvasRenderingContext2D -- ^ the context to draw on-          -> Float -- ^ FPS-          -> (Float -> IO Picture) -- ^ Your drawing function-          -> IO ()+          -> Double -- ^ FPS+          -> (Double -> IO Picture) -- ^ Your drawing function+          -> JSM () animateIO ctx fps f = do     initialTime <- getCurrentTime     let loop = do         stamp <- getCurrentTime         -- empty the canvas before drawing         -- MAYBE we need a buffer canvas on which to draw before copying it-        -- on the main canvas to avoid blinking+        -- on the main canvas (using the bitmaprenderer attribute and+        -- an OffscreenCanvas for efficiency) to avoid blinking         clearRect ctx (-10000) (-10000) 20000 20000 --FIXME         setTransform ctx 1 0 0 1 0 0 -- reset transforms (and accumulated errors!).         -- get the Picture and draw it@@ -120,14 +120,14 @@       in         loop -getModifiersMouse :: ReaderT MouseEvent IO Modifiers+getModifiersMouse :: ReaderT MouseEvent JSM Modifiers getModifiersMouse = Modifiers                    <$> fmap toKeyState mouseCtrlKey                    <*> fmap toKeyState mouseAltKey                    <*> fmap toKeyState mouseShiftKey                    <*> fmap toKeyState mouseMetaKey -getModifiersKeyboard :: ReaderT KeyboardEvent IO Modifiers+getModifiersKeyboard :: ReaderT KeyboardEvent JSM Modifiers getModifiersKeyboard = Modifiers                    <$> fmap toKeyState (event >>= getCtrlKey)                    <*> fmap toKeyState (event >>= getAltKey)@@ -138,12 +138,12 @@ play :: (IsEventTarget eventElement, IsDocument eventElement)      => CanvasRenderingContext2D -- ^ the context to draw on      -> eventElement-     -> Float -- ^ FPS+     -> Double -- ^ FPS      -> state -- ^ Initial state      -> (state -> Picture) -- ^ Drawing function      -> (Input -> state -> state) -- ^ Input handling function-     -> (Float -> state -> state) -- ^ Stepping function-     -> IO ()+     -> (Double -> state -> state) -- ^ Stepping function+     -> JSM () play ctx doc fps initialState draw handleInput step =   playIO     ctx@@ -158,12 +158,12 @@ playIO :: (IsEventTarget eventElement, IsDocument eventElement)        => CanvasRenderingContext2D -- ^ the context to draw on        -> eventElement-       -> Float -- ^ FPS+       -> Double -- ^ FPS        -> state -- ^ Initial state        -> (state -> IO Picture) -- ^ Drawing function        -> (Input -> state -> IO state) -- ^ Input handling function-       -> (Float -> state -> IO state) -- ^ Stepping function-       -> IO ()+       -> (Double -> state -> IO state) -- ^ Stepping function+       -> JSM () playIO ctx doc fps initialState draw handleInput step = do     inputM <- newMVar [] -- this will accumulate the inputs     -- setting up event listeners for mouse and keyboard@@ -186,11 +186,11 @@     _ <- on doc keyDown $ do         key <- uiKeyCode         modifiers <- getModifiersKeyboard-        liftIO $ modifyMVar_ inputM $ fmap return (Keyboard (keyCodeLookup key) Down modifiers :) -- :-) :D XD+        liftIO $ modifyMVar_ inputM $ fmap return (Keyboard (keyCodeLookup $ fromIntegral key) Down modifiers :) -- :-) :D XD     _ <- on doc keyUp $ do         key <- uiKeyCode         modifiers <- getModifiersKeyboard-        liftIO $ modifyMVar_ inputM $ fmap return (Keyboard (keyCodeLookup key) Up modifiers :) -- :-) :D XD+        liftIO $ modifyMVar_ inputM $ fmap return (Keyboard (keyCodeLookup $ fromIntegral key) Up modifiers :) -- :-) :D XD     initialTime <- getCurrentTime     -- main loop     let loop state previousTime = do@@ -215,3 +215,4 @@         loop state'' beforeRendering       in         loop initialState initialTime+

@@ -36,21 +36,21 @@              -- | The empty picture. Draws nothing.              Empty              -- | A rectangle from the dimensions-             | Rect Float Float+             | Rect Double Double              -- | Same thing but filled-             | RectF Float Float+             | RectF Double Double              -- | A line from the coordinates of two points-             | Line Float Float Float Float+             | Line Double Double Double Double              -- | A polygon from a list of vertices-             | Polygon [(Float, Float)]+             | Polygon [(Double, Double)]              -- | An arc from the radius, start angle, end angle.              -- If the last parameter is True, the direction is counterclockwise              -- TODO replace with Clockwise | Counterclockwise or remove entirely-             | Arc Float Float Float Bool+             | Arc Double Double Double Bool              -- | A filled circle from the radius-             | CircleF Float-             -- | Draws some text. The float is the max width.-             | Text Font TextAlignment Float String+             | CircleF Double+             -- | Draws some text. The 'Maybe' 'Double' is the optional max width.+             | Text Font TextAlignment (Maybe Double) String              -- | Draws an image              | Image ImageSize ImageData              -- | Draws the second `Picture` over the first@@ -60,18 +60,18 @@              -- color" and override it              | Colored Color Picture              -- | Rotates the Picture (in radians)-             | Rotate Float Picture+             | Rotate Double Picture              -- | Moves the Picture by the given x and y distances-             | Translate Float Float Picture+             | Translate Double Double Picture              -- TODO stroke              deriving (Eq, Show)  -- | A circle from the center coordinates and radius-circle :: Float -> Picture+circle :: Double -> Picture circle r = Arc r 0 (2*3.14) False  -- | Shorthand to draw a series of lines-path :: [(Float,Float)] -> Picture+path :: [(Double, Double)] -> Picture path xs = foldMap (\((x,y),(x',y')) -> Line x y x' y') $ zip xs $ tail xs  -- | 'Picture's are 'Monoid's. The identity is an 'Empty' (completely transparent)

@@ -14,8 +14,9 @@  import GHCJS.DOM.HTMLImageElement (getWidth, getHeight) import GHCJS.DOM.CanvasRenderingContext2D+import GHCJS.DOM.CanvasPath import GHCJS.DOM.Enums (CanvasWindingRule (CanvasWindingRuleNonzero))-import GHCJS.DOM.Types (CanvasStyle (..))+import GHCJS.DOM.Types (JSM, CanvasStyle (..))  import GHCJS.Prim (toJSString) import Data.List (intercalate)@@ -25,7 +26,7 @@   -- | Renders a picture on a 2D context.-render :: CanvasRenderingContext2D -> Picture -> IO ()+render :: CanvasRenderingContext2D -> Picture -> JSM () render _ Empty = return () render ctx (Line x y x' y') = do     moveTo ctx x y@@ -34,45 +35,49 @@ render ctx (Rect x y) = do     rect ctx (-x/2) (-y/2) x y     stroke ctx-render ctx (RectF x y) = fillRect ctx (-x/2) (-y/2) x y+render ctx (RectF x' y') = fillRect ctx (-x/2) (-y/2) x y+  where x = realToFrac x'+        y = realToFrac y' render ctx (Polygon ((x,y):pts)) = do     beginPath ctx     moveTo ctx x y     mapM_ (uncurry (lineTo ctx)) pts     closePath ctx-    fill ctx CanvasWindingRuleNonzero+    fill ctx $ Just CanvasWindingRuleNonzero --MAYBE Nothing render ctx (Polygon []) = render ctx Empty render ctx (Arc r a b direction) = do     beginPath ctx     arc ctx 0 0 r a b direction     stroke ctx-render ctx (CircleF r) = do+render ctx (CircleF r') = do     save ctx     render ctx $ circle r-    clip ctx CanvasWindingRuleNonzero+    clip ctx $ Just CanvasWindingRuleNonzero --MAYBE Nothing     render ctx $ RectF (r*2) (r*2)     restore ctx-render ctx (Text font align width txt) = do+  where r = realToFrac r'+render ctx (Text font align width' txt) = do     setFont ctx font     setTextAlign ctx $ case align of LeftAlign -> "left"                                      CenterAlign -> "center"                                      RightAlign -> "rignt"     fillText ctx txt 0 0 width+  where width = realToFrac <$> width' render ctx (Image size (ImageData img)) =     case size of       Original -> do           x <- ((/(-2)) . realToFrac) <$> getWidth img           y <- ((/(-2)) . realToFrac) <$> getHeight img-          drawImage ctx (Just img) x y+          drawImage ctx img x y       (Stretched w h) -> do           let (x, y) = (-w/2, -h/2)-          drawImageScaled ctx (Just img) x y w h+          drawImageScaled ctx img x y w h       (Clipped a b c d) -> do           let (x, y) = (-c/2, -d/2)-          drawImagePart ctx (Just img) a b c d x y c d+          drawImagePart ctx img a b c d x y c d       (ClippedStretched a b c d e f) -> do           let (x, y) = (-e/2, -f/2)-          drawImagePart ctx (Just img) a b c d x y e f+          drawImagePart ctx img a b c d x y e f render ctx (Over a b) = do     render ctx a     render ctx b@@ -101,19 +106,23 @@                    ++ intercalate "," [show r, show g, show b, show a]                    ++ ")"     let color = toJSString colorString-    setFillStyle ctx $ Just $ CanvasStyle color-    setStrokeStyle ctx $ Just $ CanvasStyle color+    setFillStyle ctx $ CanvasStyle color+    setStrokeStyle ctx $ CanvasStyle color     render ctx pic     -- set the color back to black     let black = toJSString "#000000"-    setFillStyle ctx $ Just $ CanvasStyle black-    setStrokeStyle ctx $ Just $ CanvasStyle black-render ctx (Rotate angle pic) = do+    setFillStyle ctx $ CanvasStyle black+    setStrokeStyle ctx $ CanvasStyle black+render ctx (Rotate angle' pic) = do     rotate ctx angle     render ctx pic     --setTransform ctx 1 0 0 1 0 0 --not ok: prevents Rotate composition     rotate ctx (-angle)-render ctx (Translate x y pic) = do+  where angle = realToFrac angle'+render ctx (Translate x' y' pic) = do     translate ctx x y     render ctx pic     translate ctx (-x) (-y)+  where x = realToFrac x'+        y = realToFrac y'+

@@ -1,12 +1,22 @@+{-# LANGUAGE CPP #-}+ import Graphics.Shine-import Graphics.Shine.Input import Graphics.Shine.Image import Graphics.Shine.Picture -import GHCJS.DOM (webViewGetDomDocument, runWebGUI)+import GHCJS.DOM (currentDocumentUnchecked) -myPic :: ImageData ->  Float -> Picture-myPic img x =+#if defined(ghcjs_HOST_OS)+run :: a -> a+run = id+#elif defined(MIN_VERSION_jsaddle_wkwebview)+import Language.Javascript.JSaddle.WKWebView (run)+#else+import Language.Javascript.JSaddle.WebKitGTK (run)+#endif++animation :: ImageData -> Double -> Picture+animation img x =     Translate (75+x'/2) 15 (RectF (150+x') 30)     <> Colored (Color 255 0 0 1.0) (Translate 15 (75+x'/2) $ Rect 30 (150+x'))     <> Colored (Color 200 200 0 1.0) (Translate 660 30 $ RectF 120 60)@@ -26,28 +36,12 @@                         , (30,140)                         , (-120,80)                         ]))-    <> Translate 600 500 (Text "20px Sans" CenterAlign 300 "The quick brown fox jumps over the lazy dog")+    <> Translate 600 500 (Text "20px Sans" CenterAlign (Just 300) "The quick brown fox jumps over the lazy dog")   where x' = sin (x*3) *100 +100 -myAnimation :: IO ()-myAnimation = runWebGUI $ \ webView -> do-    ctx <- fixedSizeCanvas webView 800 600-    img <- makeImage "httpS://placehold.it/200x70/afa"-    animate ctx 30 $ myPic img--myGame :: IO ()-myGame = runWebGUI $ \ webView -> do-    ctx <- fixedSizeCanvas webView 800 600-    Just doc <- webViewGetDomDocument webView-    play ctx doc 30 initialState draw handleInput step-  where-    initialState = False-    draw False = Empty-    draw True = RectF 300 300-    handleInput (MouseBtn BtnLeft Down _) = const True-    handleInput (MouseBtn BtnLeft Up _) = const False-    handleInput _ = id-    step _ = id- main :: IO ()-main = myAnimation --or myGame+main = run $ do+    doc <- currentDocumentUnchecked+    ctx <- fixedSizeCanvas doc 800 600+    img <- makeImage "httpS://placehold.it/200x70/afa"+    animate ctx 30 $ animation img

@@ -0,0 +1,30 @@+{-# LANGUAGE CPP #-}++import Graphics.Shine+import Graphics.Shine.Input+import Graphics.Shine.Picture++import GHCJS.DOM (currentDocumentUnchecked)++#if defined(ghcjs_HOST_OS)+run :: a -> a+run = id+#elif defined(MIN_VERSION_jsaddle_wkwebview)+import Language.Javascript.JSaddle.WKWebView (run)+#else+import Language.Javascript.JSaddle.WebKitGTK (run)+#endif++main :: IO ()+main = run $ do+    doc <- currentDocumentUnchecked+    ctx <- fixedSizeCanvas doc 800 600+    play ctx doc 30 initialState draw handleInput step+  where+    initialState = False+    draw False = Empty+    draw True = RectF 300 300+    handleInput (MouseBtn BtnLeft Down _) = const True+    handleInput (MouseBtn BtnLeft Up _) = const False+    handleInput _ = id+    step _ = id