blank-canvas 0.4.0 → 0.5

raw patch · 12 files changed

+1651/−361 lines, 12 filesdep +base64-bytestringdep +colourdep +data-default-classdep −networkdep ~aesondep ~scottydep ~textPVP ok

version bump matches the API change (PVP)

Dependencies added: base64-bytestring, colour, data-default-class

Dependencies removed: network

Dependency ranges changed: aeson, scotty, text, wai-extra

API changes (from Hackage documentation)

Files

• Changelog.md +18/−0
• Graphics/Blank.hs +135/−79
• Graphics/Blank/Canvas.hs +86/−77
• Graphics/Blank/DeviceContext.hs +18/−14
• Graphics/Blank/Events.hs +13/−12
• Graphics/Blank/GHCi.hs +3/−2
• Graphics/Blank/Generated.hs +75/−74
• Graphics/Blank/JavaScript.hs +315/−34
• Graphics/Blank/Style.hs +834/−6
• Graphics/Blank/Utils.hs +86/−5
• blank-canvas.cabal +24/−20
• static/index.html +44/−38

@@ -0,0 +1,18 @@+## 0.5++API changes+ * Using Double rather than Float+ * Generalized saveRestore to be polymorphic++API additions+ * Added sync for forcing synchronization between the server and client+ * Added argument specific variants of drawImage and putImageData.+ * Added ADTs for RepeatDirection, Alignment, Baseline, LineEnds, Corner (previous used Text)+ * Use of the colour(sic) package (Text is still allowed)++Bug fixes:+ * Fixed unicode escapes in strings++Additions:+ * Allow Images to access client-side filesystem+

@@ -15,7 +15,7 @@         , DeviceContext       -- abstact         , send           -- * HTML5 Canvas API-          -- | See <http://www.nihilogic.dk/labs/canvas_sheet/HTML5_Canvas_Cheat_Sheet.pdf> for the JavaScript +          -- | See <http://www.nihilogic.dk/labs/canvas_sheet/HTML5_Canvas_Cheat_Sheet.pdf> for the JavaScript           --   version of this API.         , Canvas        -- abstact           -- ** Canvas element@@ -42,6 +42,8 @@         , lineCap         , lineJoin         , miterLimit+        , LineEndCap(..)+        , LineJoinCorner(..)           -- ** Colors, styles and shadows         , strokeStyle         , fillStyle@@ -53,6 +55,7 @@         , createRadialGradient         , createPattern         , addColorStop+        , RepeatDirection(..)         , CanvasGradient         , CanvasPattern           -- ** Paths@@ -70,12 +73,14 @@         , rect         , isPointInPath           -- ** Text-        , font +        , font         , textAlign         , textBaseline         , fillText         , strokeText         , measureText+        , TextAnchorAlignment(..)+        , TextBaselineAlignment(..)         , TextMetrics(..)           -- ** Rectangles         , clearRect@@ -97,6 +102,8 @@         , with         , myCanvasContext         , deviceCanvasContext+         -- ** Syncing+        , sync          -- ** Debugging         , console_log         , eval@@ -104,7 +111,7 @@          -- ** Drawing Utilities         , module Graphics.Blank.Utils          -- ** Events-        , trigger +        , trigger         , eventQueue         , wait         , flush@@ -115,38 +122,48 @@         , local_only         ) where -import Control.Concurrent-import Control.Concurrent.STM-import Control.Monad-import Control.Exception-import Network.Wai.Handler.Warp (run)-import Network.Wai (Middleware,remoteHost, responseLBS)-import qualified Network.HTTP.Types as H-import Network.Socket (SockAddr(..))-import System.IO.Unsafe (unsafePerformIO)---import System.Mem.StableName-import Web.Scotty (scottyApp, get, file)-import qualified Web.Scotty as Scotty---import Network.Wai.Middleware.RequestLogger -- Used when debugging---import Network.Wai.Middleware.Static-import qualified Web.Scotty.Comet as KC-import Data.Aeson-import Data.Aeson.Types (parse)-import Data.String+import           Control.Concurrent+import           Control.Concurrent.STM+import           Control.Exception+import           Control.Monad+import           Control.Monad.IO.Class++import           Data.Aeson+import           Data.Aeson.Types (parse)+import           Data.List as L+import           Data.Monoid ((<>))+import qualified Data.Set as S+import           Data.String import qualified Data.Text as T-import Data.Text (Text)-import Data.Monoid((<>))+import           Data.Text (Text)+import qualified Data.Text.Lazy as LT -import Graphics.Blank.Events-import Graphics.Blank.DeviceContext-import Graphics.Blank.Canvas-import Graphics.Blank.Generated hiding (fillStyle,strokeStyle)+import qualified Graphics.Blank.Canvas as Canvas+import           Graphics.Blank.Canvas hiding (addColorStop)+import           Graphics.Blank.DeviceContext+import           Graphics.Blank.Events import qualified Graphics.Blank.Generated as Generated+import           Graphics.Blank.Generated hiding (fillStyle, strokeStyle, shadowColor) import qualified Graphics.Blank.JavaScript as JavaScript-import Graphics.Blank.JavaScript hiding (width, height)-import Graphics.Blank.Utils-import Paths_blank_canvas+import           Graphics.Blank.JavaScript hiding (width, height)+import           Graphics.Blank.Utils +import qualified Network.HTTP.Types as H+import           Network.Wai (Middleware, responseLBS)+import           Network.Wai.Middleware.Local+import           Network.Wai.Handler.Warp+-- import           Network.Wai.Middleware.RequestLogger -- Used when debugging+-- import           Network.Wai.Middleware.Static++import           Paths_blank_canvas++import           System.IO.Unsafe (unsafePerformIO)+-- import           System.Mem.StableName++import qualified Web.Scotty as Scotty+import           Web.Scotty (scottyApp, get, file)+import qualified Web.Scotty.Comet as KC+ -- | blankCanvas is the main entry point into blank-canvas. -- A typical invocation would be --@@ -172,17 +189,21 @@    kComet <- KC.kCometPlugin  +   locals :: TVar (S.Set Text) <- atomically $ newTVar S.empty+ --   print dataDir     app <- scottyApp $ do --        middleware logStdoutDev-        sequence_ [ Scotty.middleware ware -                  | ware <- middleware opts +        sequence_ [ Scotty.middleware ware+                  | ware <- middleware opts                   ]         -- use the comet         let kc_opts :: KC.Options             kc_opts = KC.Options { KC.prefix = "/blank", KC.verbose = if debug opts then 3 else 0 } ++         KC.connect kc_opts $ \ kc_doc -> do                 -- register the events we want to watch for                 KC.send kc_doc $ T.unlines@@ -198,18 +219,19 @@                                    atomically $ writeTChan queue event                            _ -> return () -                let cxt0 = DeviceContext kc_doc queue 300 300 1-                -                -- A bit of bootstrapping ++                let cxt0 = DeviceContext kc_doc queue 300 300 1 locals++                -- A bit of bootstrapping                 DeviceAttributes w h dpr <- send cxt0 device                 -- print (DeviceAttributes w h dpr) -                let cxt1 = cxt0 +                let cxt1 = cxt0                          { ctx_width = w                          , ctx_height = h                          , ctx_devicePixelRatio = dpr                          }-                +                 (actions $ cxt1) `catch` \ (e :: SomeException) -> do                         print ("Exception in blank-canvas application:"  :: String)                         print e@@ -219,57 +241,78 @@         get "/jquery.js"        $ file $ dataDir ++ "/static/jquery.js"         get "/jquery-json.js"   $ file $ dataDir ++ "/static/jquery-json.js"         get "/kansas-comet.js"  $ file $ kComet-        sequence_ [ get (fromString ("/" ++ nm)) $ file $ (root opts ++ "/" ++ nm) | nm <- static opts ]++        -- There has to be a better way of doing this, using function, perhaps?+        get (Scotty.regex "^/(.*)$") $ do+          fileName :: Text <- Scotty.param "1"+          db <- liftIO $ atomically $ readTVar $ locals+          if fileName `S.member` db+          then do+            mime <- mimeTypes (T.unpack fileName)+            Scotty.setHeader "Content-Type" $ LT.fromStrict $ mime+            file $ (root opts ++ "/" ++ T.unpack fileName)+          else do+            Scotty.next+         return () -   run (port opts) app ++   runSettings (setPort (port opts)+               $ setTimeout 5+               $ defaultSettings+               ) app+ -- | Sends a set of Canvas commands to the canvas. Attempts -- to common up as many commands as possible. Should not crash.  send :: DeviceContext -> Canvas a -> IO a-send cxt commands = -      send' (deviceCanvasContext cxt) commands id +send cxt commands =+      send' (deviceCanvasContext cxt) commands id   where-      send' :: CanvasContext -> Canvas a -> (String -> String) -> IO a-      send' c (Bind (Return a) k)    cmds = send' c (k a) cmds-      send' c (Bind (Bind m k1) k2)  cmds = send' c (Bind m (\ r -> Bind (k1 r) k2)) cmds-      send' c (Bind (Method cmd) k) cmds = send' c (k ()) (cmds . ((showJS c ++ ".") ++) . shows cmd . (";" ++))-      send' c (Bind (Command cmd) k) cmds = send' c (k ()) (cmds . shows cmd . (";" ++))-      send' c (Bind (Query query) k) cmds = do-              -- send the com-              uq <- atomically $ getUniq-              -- The query function returns a function takes the unique port number of the reply.-              sendToCanvas cxt (cmds . ((show query ++ "(" ++ show uq ++ "," ++ showJS c ++ ");") ++))-              v <- KC.getReply (theComet cxt) uq-              case parse (parseQueryResult query) v of-                Error msg -> fail msg-                Success a -> do-                        send' c (k a) id-      send' c (Bind (With c' m) k) cmds = send' c' (Bind m (With c . k)) cmds-      send' c (Bind MyContext k)   cmds = send' c (k c) cmds+      sendBind :: CanvasContext -> Canvas a -> (a -> Canvas b) -> (String -> String) -> IO b+      sendBind c (Return a) k    cmds = send' c (k a) cmds+      sendBind c (Bind m k1) k2 cmds = sendBind c m (\ r -> Bind (k1 r) k2) cmds+      sendBind c (Method cmd) k cmds = send' c (k ()) (cmds . ((showJS c ++ ".") ++) . shows cmd . (";" ++))+      sendBind c (Command cmd) k cmds = send' c (k ()) (cmds . shows cmd . (";" ++))+      sendBind c (Query query) k cmds = sendQuery c query k cmds+      sendBind c (With c' m) k  cmds = send' c' (Bind m (With c . k)) cmds+      sendBind c MyContext k    cmds = send' c (k c) cmds -      send' _ (With c m)           cmds = send' c m cmds-      send' c MyContext            cmds = send' c (Return c) cmds-      send' _ (Return a)           cmds = do+      sendQuery :: CanvasContext -> Query a -> (a -> Canvas b) -> (String -> String) -> IO b+      sendQuery c query k cmds = do+          case query of+            NewImage url -> do+              let url' = if "/" `T.isPrefixOf` url then T.tail url else url+              atomically $ do+                  db <- readTVar (localFiles cxt)+                  writeTVar (localFiles cxt) $ S.insert url' $ db+            _ -> return ()++          -- send the com+          uq <- atomically $ getUniq+          -- The query function returns a function takes the unique port number of the reply.+          sendToCanvas cxt (cmds . ((show query ++ "(" ++ show uq ++ "," ++ showJS c ++ ");") ++))+          v <- KC.getReply (theComet cxt) uq+          case parse (parseQueryResult query) v of+            Error msg -> fail msg+            Success a -> do+                    send' c (k a) id++++      send' :: CanvasContext -> Canvas a -> (String -> String) -> IO a+-- Most of these can be factored out, except return+      send' c (Bind m k)            cmds = sendBind c m k cmds+      send' _ (With c m)            cmds = send' c m cmds  -- This is a bit of a hack+      send' _ (Return a)            cmds = do               sendToCanvas cxt cmds               return a-      send' c cmd                  cmds = send' c (Bind cmd Return) cmds+      send' c cmd                   cmds = sendBind c cmd Return cmds   local_only :: Middleware-local_only f r k = case remoteHost r of-                   SockAddrInet _  h | h == fromIntegral home-                                    -> f r k-#if !defined(mingw32_HOST_OS) && !defined(_WIN32)-                   SockAddrUnix _   -> f r k-#endif-                   _                ->  k $ responseLBS H.status403-                                                        [("Content-Type", "text/plain")]-							 "local access only"- where-        home :: Integer-        home = 127 + (256 * 256 * 256) * 1+local_only = local $ responseLBS H.status403 [("Content-Type", "text/plain")] "local access only"   {-# NOINLINE uniqVar #-}@@ -282,17 +325,26 @@     writeTVar uniqVar (u + 1)     return u +mimeTypes :: Monad m => FilePath -> m Text+mimeTypes filePath+  | ".jpg" `L.isSuffixOf` filePath = return "image/jpeg"+  | ".png" `L.isSuffixOf` filePath = return "image/png"+  | ".gif" `L.isSuffixOf` filePath = return "image/gif"+  | otherwise = fail $ "do not understand mime type for : " ++ show filePath+ ------------------------------------------------- -data Options = Options +-- TODO: add extra mime types+++data Options = Options         { port   :: Int              -- ^ which port do we issue the blank canvas using         , events :: [EventName]      -- ^ which events does the canvas listen to         , debug  :: Bool             -- ^ turn on debugging (default False)-        , static :: [String]         -- ^ path to images, and other static artifacts         , root   :: String           -- ^ location of the static files (default .)         , middleware :: [Middleware] -- ^ extra middleware(s) to be executed. (default [local_only])         }-        + instance Num Options where     (+) = error "no arithmetic for Blank Canvas Options"     (-) = error "no arithmetic for Blank Canvas Options"@@ -302,7 +354,6 @@     fromInteger n = Options { port = fromInteger n                             , events = []                             , debug = False-                            , static = []                             , root = "."                             , middleware = [local_only]                             }@@ -317,9 +368,14 @@ strokeStyle :: Text -> Canvas () strokeStyle = Generated.strokeStyle +shadowColor :: Text -> Canvas ()+shadowColor = Generated.shadowColor++addColorStop :: (Double, Text) -> CanvasGradient -> Canvas ()+addColorStop = Canvas.addColorStop+ height :: (Image image, Num a) => image -> a height = JavaScript.height  width :: (Image image, Num a) => image -> a width = JavaScript.width-

@@ -2,28 +2,30 @@  module Graphics.Blank.Canvas where -import Graphics.Blank.Events-import Graphics.Blank.JavaScript+import           Control.Applicative+import           Control.Monad (ap, liftM2) -import Data.Aeson (FromJSON(..),Value(..),encode)-import Data.Aeson.Types (Parser, (.:))-import Data.Char (chr)-import Control.Monad (ap, liftM2)-import Control.Applicative-import Data.Monoid+import           Graphics.Blank.Events+import           Graphics.Blank.JavaScript++import           Data.Aeson (FromJSON(..),Value(..),encode)+import           Data.Aeson.Types (Parser, (.:))+import           Data.Char (chr)+ import qualified Data.ByteString.Lazy as DBL+import           Data.Monoid import qualified Data.Text as Text-import Data.Text (Text)+import           Data.Text (Text)   data Canvas :: * -> * where-        Method  :: Method                              -> Canvas ()     -- <context>.<method>-        Command :: Command                             -> Canvas ()     -- <command>-        Query   :: (Show a) => Query a                 -> Canvas a-        With    :: CanvasContext -> Canvas a           -> Canvas a-        MyContext ::                                      Canvas CanvasContext-        Bind    :: Canvas a -> (a -> Canvas b)         -> Canvas b-        Return  :: a                                   -> Canvas a+        Method    :: Method                      -> Canvas ()     -- <context>.<method>+        Command   :: Command                     -> Canvas ()     -- <command>+        Query     :: (Show a) => Query a         -> Canvas a+        With      :: CanvasContext -> Canvas a   -> Canvas a+        MyContext ::                                Canvas CanvasContext+        Bind      :: Canvas a -> (a -> Canvas b) -> Canvas b+        Return    :: a                           -> Canvas a  instance Monad Canvas where         return = Return@@ -40,62 +42,63 @@   mappend = liftM2 mappend   mempty  = return mempty + -- HTML5 Canvas assignments: FillStyle, Font, GlobalAlpha, GlobalCompositeOperation, LineCap, LineJoin, LineWidth, MiterLimit, ShadowBlur, ShadowColor, ShadowOffsetX, ShadowOffsetY, StrokeStyle, TextAlign, TextBaseline data Method         -- regular HTML5 canvas commands-        = Arc (Float,Float,Float,Float,Float,Bool)-        | ArcTo (Float,Float,Float,Float,Float)+        = Arc (Double, Double, Double, Double, Double, Bool)+        | ArcTo (Double, Double, Double, Double, Double)         | BeginPath-        | BezierCurveTo (Float,Float,Float,Float,Float,Float)-        | forall image . Image image => DrawImage (image,[Float]) -- 'drawImage' takes 2, 4 or 8 floats arguments-        | ClearRect (Float,Float,Float,Float)+        | BezierCurveTo (Double, Double, Double, Double, Double, Double)+        | ClearRect (Double, Double, Double, Double)         | Clip         | ClosePath+        | forall image . Image image => DrawImage (image,[Double]) -- drawImage' takes 2, 4, or 8 'Double' arguments. See 'drawImageAt', 'drawImageSize', and 'drawImageCrop' for variants with exact numbers of arguments.         | Fill-        | FillRect (Float,Float,Float,Float)+        | FillRect (Double, Double, Double, Double)         | forall style . Style style => FillStyle style-        | FillText (Text,Float,Float)+        | FillText (Text, Double, Double)         | Font Text-        | GlobalAlpha Float+        | GlobalAlpha Double         | GlobalCompositeOperation Text-        | LineCap Text-        | LineJoin Text-        | LineTo (Float,Float)-        | LineWidth Float-        | MiterLimit Float-        | MoveTo (Float,Float)-        | PutImageData (ImageData,[Float])-        | QuadraticCurveTo (Float,Float,Float,Float)-        | Rect (Float,Float,Float,Float)+        | LineCap LineEndCap+        | LineJoin LineJoinCorner+        | LineTo (Double, Double)+        | LineWidth Double+        | MiterLimit Double+        | MoveTo (Double, Double)+        | PutImageData (ImageData, [Double]) -- 'putImageData' takes 2 or 6 'Double' arguments. See `putImageDataAt' and `putImageDataDirty' for variants with exact numbers of arguments.+        | QuadraticCurveTo (Double, Double, Double, Double)+        | Rect (Double, Double, Double, Double)         | Restore-        | Rotate Float-        | Scale (Float,Float)+        | Rotate Double         | Save-        | SetTransform (Float,Float,Float,Float,Float,Float)+        | Scale (Double, Double)+        | SetTransform (Double, Double, Double, Double, Double, Double)+        | ShadowBlur Double+        | forall canvasColor . CanvasColor canvasColor => ShadowColor canvasColor+        | ShadowOffsetX Double+        | ShadowOffsetY Double         | Stroke-        | StrokeRect (Float,Float,Float,Float)-        | StrokeText (Text,Float,Float)+        | StrokeRect (Double, Double, Double, Double)         | forall style . Style style => StrokeStyle style-        | ShadowBlur Float-        | ShadowColor Text-        | ShadowOffsetX Float-        | ShadowOffsetY Float-        | TextAlign Text-        | TextBaseline Text-        | Transform (Float,Float,Float,Float,Float,Float)-        | Translate (Float,Float)+        | StrokeText (Text,Double, Double)+        | TextAlign TextAnchorAlignment+        | TextBaseline TextBaselineAlignment+        | Transform (Double, Double, Double, Double, Double, Double)+        | Translate (Double, Double)  data Command   = Trigger Event-  | AddColorStop (Float,Text) CanvasGradient+  | forall color . CanvasColor color => AddColorStop (Double, color) CanvasGradient   | forall msg . JSArg msg => Log msg   | Eval Text  instance Show Command where   show (Trigger e) = "Trigger(" ++ map (chr . fromEnum) (DBL.unpack (encode e)) ++ ")"   show (AddColorStop (off,rep) g)-     = showJS g ++ ".addColorStop(" ++ showJS off ++ "," ++ showJS rep ++ ")"-  show (Log msg) = "console.log(" ++ showJS msg ++ ")" +     = showJS g ++ ".addColorStop(" ++ showJS off ++ "," ++ jsStyle rep ++ ")"+  show (Log msg) = "console.log(" ++ showJS msg ++ ")"   show (Eval cmd) = Text.unpack cmd -- no escaping or interpretation  -----------------------------------------------------------------------------@@ -116,7 +119,7 @@ trigger = Command . Trigger  -- | add a Color stop to a Canvas Gradient.-addColorStop :: (Float,Text) -> CanvasGradient -> Canvas ()+addColorStop :: CanvasColor color => (Double, color) -> CanvasGradient -> Canvas () addColorStop (off,rep) = Command . AddColorStop (off,rep)  -- | 'console_log' aids debugging by sending the argument to the browser console.log.@@ -129,22 +132,23 @@  ----------------------------------------------------------------------------- data Query :: * -> * where-        Device                                            :: Query DeviceAttributes-        ToDataURL                                         :: Query Text-        MeasureText          :: Text                      -> Query TextMetrics-        IsPointInPath        :: (Float,Float)             -> Query Bool-        NewImage             :: Text                      -> Query CanvasImage-        CreateLinearGradient :: (Float,Float,Float,Float)             -> Query CanvasGradient-        CreateRadialGradient :: (Float,Float,Float,Float,Float,Float) -> Query CanvasGradient-        CreatePattern        :: Image image => (image,Text) -> Query CanvasPattern-        NewCanvas            :: (Int,Int)                 -> Query CanvasContext-        GetImageData         :: (Float,Float,Float,Float) -> Query ImageData+        Device               ::                                                     Query DeviceAttributes+        ToDataURL            ::                                                     Query Text+        MeasureText          :: Text                                             -> Query TextMetrics+        IsPointInPath        :: (Double, Double)                                 -> Query Bool+        NewImage             :: Text                                             -> Query CanvasImage+        CreateLinearGradient :: (Double, Double, Double, Double)                 -> Query CanvasGradient+        CreateRadialGradient :: (Double, Double, Double, Double, Double, Double) -> Query CanvasGradient+        CreatePattern        :: Image image => (image, RepeatDirection)          -> Query CanvasPattern+        NewCanvas            :: (Int, Int)                                       -> Query CanvasContext+        GetImageData         :: (Double, Double, Double, Double)                 -> Query ImageData+        Sync                 ::                                                     Query () -data DeviceAttributes = DeviceAttributes Int Int Float +data DeviceAttributes = DeviceAttributes Int Int Double         deriving Show-        + -- | The 'width' argument of 'TextMetrics' can trivially be projected out.-data TextMetrics = TextMetrics Float+data TextMetrics = TextMetrics Double         deriving Show  instance Show (Query a) where@@ -155,10 +159,11 @@   show (NewImage url)           = "NewImage(" ++ showJS url ++ ")"   show (CreateLinearGradient (x0,y0,x1,y1)) = "CreateLinearGradient(" ++ showJS x0 ++ "," ++ showJS y0 ++ "," ++ showJS x1 ++ "," ++ showJS y1 ++ ")"   show (CreateRadialGradient (x0,y0,r0,x1,y1,r1)) = "CreateRadialGradient(" ++ showJS x0 ++ "," ++ showJS y0 ++ "," ++ showJS r0 ++ "," ++ showJS x1 ++ "," ++ showJS y1 ++ "," ++ showJS r1 ++ ")"-  show (CreatePattern (img,str)) = "CreatePattern(" ++ jsImage img ++ "," ++ showJS str ++ ")"+  show (CreatePattern (img,dir)) = "CreatePattern(" ++ jsImage img ++ "," ++ jsRepeatDirection dir ++ ")"   show (NewCanvas (x,y))         = "NewCanvas(" ++ showJS x ++ "," ++ showJS y ++ ")"-  show (GetImageData (sx,sy,sw,sh)) +  show (GetImageData (sx,sy,sw,sh))                                  = "GetImageData(" ++ showJS sx ++ "," ++ showJS sy ++ "," ++ showJS sw ++ "," ++ showJS sh ++ ")"+  show Sync                      = "Sync"  -- This is how we take our value to bits parseQueryResult :: Query a -> Value -> Parser a@@ -171,20 +176,21 @@ parseQueryResult (CreateRadialGradient {}) o = CanvasGradient <$> parseJSON o parseQueryResult (CreatePattern {}) o = CanvasPattern <$> parseJSON o parseQueryResult (NewCanvas {}) o = uncurry3 CanvasContext <$> parseJSON o-parseQueryResult (GetImageData {}) (Object o) = ImageData +parseQueryResult (GetImageData {}) (Object o) = ImageData                                          <$> (o .: "width")                                          <*> (o .: "height")                                          <*> (o .: "data")+parseQueryResult (Sync {}) _ = return () -- we just accept anything; empty list sent parseQueryResult _ _ = fail "no parse in blank-canvas server (internal error)"  uncurry3 :: (t0 -> t1 -> t2 -> t3) -> (t0, t1, t2) -> t3-uncurry3 f (a,b,c) = f a b c +uncurry3 f (a,b,c) = f a b c  device :: Canvas DeviceAttributes device = Query Device  -- | Turn the canvas into a png data stream / data URL.--- +-- -- > "data:image/png;base64,iVBORw0KGgo.." -- toDataURL :: () -> Canvas Text@@ -193,29 +199,32 @@ measureText :: Text -> Canvas TextMetrics measureText = Query . MeasureText -isPointInPath :: (Float,Float) -> Canvas Bool+isPointInPath :: (Double, Double) -> Canvas Bool isPointInPath = Query . IsPointInPath --- | 'image' takes a URL (perhaps a data URL), and returns the 'CanvasImage' handle, +-- | 'image' takes a URL (perhaps a data URL), and returns the 'CanvasImage' handle, -- _after_ loading. -- The assumption is you are using local images, so loading should be near instant. newImage :: Text -> Canvas CanvasImage-newImage = Query . NewImage +newImage = Query . NewImage -createLinearGradient :: (Float,Float,Float,Float) -> Canvas CanvasGradient+createLinearGradient :: (Double, Double, Double, Double) -> Canvas CanvasGradient createLinearGradient = Query . CreateLinearGradient -createRadialGradient :: (Float,Float,Float,Float,Float,Float) -> Canvas CanvasGradient+createRadialGradient :: (Double, Double, Double, Double, Double, Double) -> Canvas CanvasGradient createRadialGradient = Query . CreateRadialGradient -createPattern :: (CanvasImage, Text) -> Canvas CanvasPattern+createPattern :: (CanvasImage, RepeatDirection) -> Canvas CanvasPattern createPattern = Query . CreatePattern  -- | Create a new, off-screen canvas buffer. Takes width and height.-newCanvas :: (Int,Int) -> Canvas CanvasContext+newCanvas :: (Int, Int) -> Canvas CanvasContext newCanvas = Query . NewCanvas  -- | Capture ImageDate from the Canvas.-getImageData :: (Float,Float,Float,Float) -> Canvas ImageData-getImageData = Query . GetImageData        +getImageData :: (Double, Double, Double, Double) -> Canvas ImageData+getImageData = Query . GetImageData +-- | Send all commands to the browser, wait for the browser to ack, then continue.+sync :: Canvas ()+sync = Query $ Sync

@@ -1,29 +1,33 @@ {-# LANGUAGE OverloadedStrings #-} module Graphics.Blank.DeviceContext where -import Graphics.Blank.JavaScript-import Control.Concurrent.STM--import qualified Web.Scotty.Comet as KC+import           Control.Concurrent.STM -import Graphics.Blank.Events-import Data.Monoid((<>))+import           Data.Set (Set)+import           Data.Monoid ((<>))+import           Data.Text (Text) import qualified Data.Text as T +import           Graphics.Blank.Events+import           Graphics.Blank.JavaScript++import qualified Web.Scotty.Comet as KC+ -- | 'Context' is our abstact handle into a specific 2d-context inside a browser. -- Note that the JavaScript API concepts of 2D-Context and Canvas -- are conflated in blank-canvas. Therefore, there is no 'getContext' method, -- rather 'getContext' is implied (when using 'send').  data DeviceContext = DeviceContext-        { theComet    :: KC.Document                -- ^ The mechansims for sending commands-        , eventQueue  :: EventQueue                 -- ^ A single (typed) event queue-        , ctx_width   :: !Int-        , ctx_height  :: !Int-        , ctx_devicePixelRatio :: !Float+        { theComet             :: KC.Document     -- ^ The mechansims for sending commands+        , eventQueue           :: EventQueue      -- ^ A single (typed) event queue+        , ctx_width            :: !Int+        , ctx_height           :: !Int+        , ctx_devicePixelRatio :: !Double+        , localFiles           :: TVar (Set Text) -- ^ approved local files         } -instance Image DeviceContext where +instance Image DeviceContext where   jsImage = jsImage . deviceCanvasContext   width  = fromIntegral . ctx_width   height = fromIntegral . ctx_height@@ -36,7 +40,7 @@ --   to use the native devicePixelRatio, and if successful, 'devicePixelRatio' will return a number other than 1. --   You can think of devicePixelRatio as the line width to use to make lines look one pixel wide. -devicePixelRatio ::  DeviceContext -> Float+devicePixelRatio ::  DeviceContext -> Double devicePixelRatio = ctx_devicePixelRatio  -- | internal command to send a message to the canvas.@@ -51,7 +55,7 @@ -- | 'flush' all the current events, returning them all to the user. Never blocks. flush :: DeviceContext -> IO [Event] flush cxt = atomically $ loop-  where loop = do +  where loop = do           b <- isEmptyTChan (eventQueue cxt)           if b then return [] else do                  e <- readTChan (eventQueue cxt)

@@ -1,16 +1,17 @@ {-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-} module Graphics.Blank.Events where +import Control.Applicative ((<|>), (<$>), (<*>))+import Control.Concurrent.STM+ import Data.Aeson (FromJSON(..), Value(..), ToJSON(..)) import Data.Aeson.Types ((.:), (.=), object)-import Control.Applicative((<|>),(<$>),(<*>))-import Control.Concurrent.STM import Data.Text (Text) --- | Basic Event from Browser; see <http://api.jquery.com/category/events/event-object/> for details.+-- | Basic Event from Browser; see <http://api.jquery.com/category/events/> for details. data Event = Event         { eMetaKey :: Bool-        , ePageXY  :: Maybe (Float,Float)+        , ePageXY  :: Maybe (Double, Double)         , eType    :: EventName          -- "Describes the nature of the event." jquery         , eWhich   :: Maybe Int          -- magic code for key presses         }@@ -18,22 +19,22 @@   instance FromJSON Event where-   parseJSON (Object v) = Event <$> ((v .: "eMetaKey")              <|> return False)-                                <*> (Just <$> (v .: "ePageXY")      <|> return Nothing)-                                <*> (v .: "eType")-                                <*> (Just <$> (v .: "eWhich")       <|> return Nothing)+   parseJSON (Object v) = Event <$> ((v .: "metaKey")              <|> return False)+                                <*> (Just <$> (v .: "pageXY")      <|> return Nothing)+                                <*> (v .: "type")+                                <*> (Just <$> (v .: "which")       <|> return Nothing)    parseJSON _ = fail "no parse of Event"      instance ToJSON Event where    toJSON e = object -            $ ((:) ("eMetaKey" .=  eMetaKey e))+            $ ((:) ("metaKey" .=  eMetaKey e))             $ (case ePageXY e of                  Nothing -> id-                 Just (x,y) -> (:) ("ePageXY" .= (x,y)))-            $ ((:) ("eType" .= eType e))+                 Just (x,y) -> (:) ("pageXY" .= (x,y)))+            $ ((:) ("type" .= eType e))             $ (case eWhich e of                  Nothing -> id-                 Just w -> (:) ("eWhich" .= w))+                 Just w -> (:) ("which" .= w))             $ []  -- | 'EventName' mirrors event names from jquery, and use lower case.

@@ -3,10 +3,11 @@ import Control.Concurrent import Control.Concurrent.STM import Control.Monad-import System.IO.Unsafe (unsafePerformIO)  import Graphics.Blank (Options(..),port,send, Canvas, blankCanvas) +import System.IO.Unsafe (unsafePerformIO)+ -- | splitCanvas is the GHCi entry point into blank-canvas. -- A typical invocation would be --@@ -39,6 +40,6 @@  -- common TVar for all ports in use. {-# NOINLINE usedPorts #-}-usedPorts :: TVar [(Int,TMVar (Canvas ()))]+usedPorts :: TVar [(Int, TMVar (Canvas ()))] usedPorts = unsafePerformIO $ newTVarIO [] 

@@ -6,67 +6,63 @@ import Data.Text (Text)  instance Show Method where-  show (Arc (a1,a2,a3,a4,a5,a6)) = "arc(" ++ jsFloat a1 ++ "," ++ jsFloat a2 ++ "," ++ jsFloat a3 ++ "," ++ jsFloat a4 ++ "," ++ jsFloat a5 ++ "," ++ jsBool a6 ++ ")"-  show (ArcTo (a1,a2,a3,a4,a5)) = "arcTo(" ++ jsFloat a1 ++ "," ++ jsFloat a2 ++ "," ++ jsFloat a3 ++ "," ++ jsFloat a4 ++ "," ++ jsFloat a5 ++ ")"+  show (Arc (a1,a2,a3,a4,a5,a6)) = "arc(" ++ jsDouble a1 ++ "," ++ jsDouble a2 ++ "," ++ jsDouble a3 ++ "," ++ jsDouble a4 ++ "," ++ jsDouble a5 ++ "," ++ jsBool a6 ++ ")"+  show (ArcTo (a1,a2,a3,a4,a5)) = "arcTo(" ++ jsDouble a1 ++ "," ++ jsDouble a2 ++ "," ++ jsDouble a3 ++ "," ++ jsDouble a4 ++ "," ++ jsDouble a5 ++ ")"   show BeginPath = "beginPath()"-  show (BezierCurveTo (a1,a2,a3,a4,a5,a6)) = "bezierCurveTo(" ++ jsFloat a1 ++ "," ++ jsFloat a2 ++ "," ++ jsFloat a3 ++ "," ++ jsFloat a4 ++ "," ++ jsFloat a5 ++ "," ++ jsFloat a6 ++ ")"-  show (DrawImage (a1,a2)) = "drawImage(" ++ jsImage a1 ++ "," ++ jsList jsFloat a2 ++ ")"-  show (ClearRect (a1,a2,a3,a4)) = "clearRect(" ++ jsFloat a1 ++ "," ++ jsFloat a2 ++ "," ++ jsFloat a3 ++ "," ++ jsFloat a4 ++ ")"+  show (BezierCurveTo (a1,a2,a3,a4,a5,a6)) = "bezierCurveTo(" ++ jsDouble a1 ++ "," ++ jsDouble a2 ++ "," ++ jsDouble a3 ++ "," ++ jsDouble a4 ++ "," ++ jsDouble a5 ++ "," ++ jsDouble a6 ++ ")"+  show (ClearRect (a1,a2,a3,a4)) = "clearRect(" ++ jsDouble a1 ++ "," ++ jsDouble a2 ++ "," ++ jsDouble a3 ++ "," ++ jsDouble a4 ++ ")"   show Clip = "clip()"   show ClosePath = "closePath()"+  show (DrawImage (a1,a2)) = "drawImage(" ++ jsImage a1 ++ "," ++ jsList jsDouble a2 ++ ")"   show Fill = "fill()"-  show (FillRect (a1,a2,a3,a4)) = "fillRect(" ++ jsFloat a1 ++ "," ++ jsFloat a2 ++ "," ++ jsFloat a3 ++ "," ++ jsFloat a4 ++ ")"+  show (FillRect (a1,a2,a3,a4)) = "fillRect(" ++ jsDouble a1 ++ "," ++ jsDouble a2 ++ "," ++ jsDouble a3 ++ "," ++ jsDouble a4 ++ ")"   show (FillStyle (a1)) = "fillStyle = (" ++ jsStyle a1 ++ ")"-  show (FillText (a1,a2,a3)) = "fillText(" ++ jsText a1 ++ "," ++ jsFloat a2 ++ "," ++ jsFloat a3 ++ ")"+  show (FillText (a1,a2,a3)) = "fillText(" ++ jsText a1 ++ "," ++ jsDouble a2 ++ "," ++ jsDouble a3 ++ ")"   show (Font (a1)) = "font = (" ++ jsText a1 ++ ")"-  show (GlobalAlpha (a1)) = "globalAlpha = (" ++ jsFloat a1 ++ ")"+  show (GlobalAlpha (a1)) = "globalAlpha = (" ++ jsDouble a1 ++ ")"   show (GlobalCompositeOperation (a1)) = "globalCompositeOperation = (" ++ jsText a1 ++ ")"-  show (LineCap (a1)) = "lineCap = (" ++ jsText a1 ++ ")"-  show (LineJoin (a1)) = "lineJoin = (" ++ jsText a1 ++ ")"-  show (LineTo (a1,a2)) = "lineTo(" ++ jsFloat a1 ++ "," ++ jsFloat a2 ++ ")"-  show (LineWidth (a1)) = "lineWidth = (" ++ jsFloat a1 ++ ")"-  show (MiterLimit (a1)) = "miterLimit = (" ++ jsFloat a1 ++ ")"-  show (MoveTo (a1,a2)) = "moveTo(" ++ jsFloat a1 ++ "," ++ jsFloat a2 ++ ")"-  show (PutImageData (a1,a2)) = "putImageData(" ++ jsImageData a1 ++ "," ++ jsList jsFloat a2 ++ ")"-  show (QuadraticCurveTo (a1,a2,a3,a4)) = "quadraticCurveTo(" ++ jsFloat a1 ++ "," ++ jsFloat a2 ++ "," ++ jsFloat a3 ++ "," ++ jsFloat a4 ++ ")"-  show (Rect (a1,a2,a3,a4)) = "rect(" ++ jsFloat a1 ++ "," ++ jsFloat a2 ++ "," ++ jsFloat a3 ++ "," ++ jsFloat a4 ++ ")"+  show (LineCap (a1)) = "lineCap = (" ++ jsLineEndCap a1 ++ ")"+  show (LineJoin (a1)) = "lineJoin = (" ++ jsLineJoinCorner a1 ++ ")"+  show (LineTo (a1,a2)) = "lineTo(" ++ jsDouble a1 ++ "," ++ jsDouble a2 ++ ")"+  show (LineWidth (a1)) = "lineWidth = (" ++ jsDouble a1 ++ ")"+  show (MiterLimit (a1)) = "miterLimit = (" ++ jsDouble a1 ++ ")"+  show (MoveTo (a1,a2)) = "moveTo(" ++ jsDouble a1 ++ "," ++ jsDouble a2 ++ ")"+  show (PutImageData (a1,a2)) = "putImageData(" ++ jsImageData a1 ++ "," ++ jsList jsDouble a2 ++ ")"+  show (QuadraticCurveTo (a1,a2,a3,a4)) = "quadraticCurveTo(" ++ jsDouble a1 ++ "," ++ jsDouble a2 ++ "," ++ jsDouble a3 ++ "," ++ jsDouble a4 ++ ")"+  show (Rect (a1,a2,a3,a4)) = "rect(" ++ jsDouble a1 ++ "," ++ jsDouble a2 ++ "," ++ jsDouble a3 ++ "," ++ jsDouble a4 ++ ")"   show Restore = "restore()"-  show (Rotate (a1)) = "rotate(" ++ jsFloat a1 ++ ")"-  show (Scale (a1,a2)) = "scale(" ++ jsFloat a1 ++ "," ++ jsFloat a2 ++ ")"+  show (Rotate (a1)) = "rotate(" ++ jsDouble a1 ++ ")"   show Save = "save()"-  show (SetTransform (a1,a2,a3,a4,a5,a6)) = "setTransform(" ++ jsFloat a1 ++ "," ++ jsFloat a2 ++ "," ++ jsFloat a3 ++ "," ++ jsFloat a4 ++ "," ++ jsFloat a5 ++ "," ++ jsFloat a6 ++ ")"+  show (Scale (a1,a2)) = "scale(" ++ jsDouble a1 ++ "," ++ jsDouble a2 ++ ")"+  show (SetTransform (a1,a2,a3,a4,a5,a6)) = "setTransform(" ++ jsDouble a1 ++ "," ++ jsDouble a2 ++ "," ++ jsDouble a3 ++ "," ++ jsDouble a4 ++ "," ++ jsDouble a5 ++ "," ++ jsDouble a6 ++ ")"+  show (ShadowBlur (a1)) = "shadowBlur = (" ++ jsDouble a1 ++ ")"+  show (ShadowColor (a1)) = "shadowColor = (" ++ jsCanvasColor a1 ++ ")"+  show (ShadowOffsetX (a1)) = "shadowOffsetX = (" ++ jsDouble a1 ++ ")"+  show (ShadowOffsetY (a1)) = "shadowOffsetY = (" ++ jsDouble a1 ++ ")"   show Stroke = "stroke()"-  show (StrokeRect (a1,a2,a3,a4)) = "strokeRect(" ++ jsFloat a1 ++ "," ++ jsFloat a2 ++ "," ++ jsFloat a3 ++ "," ++ jsFloat a4 ++ ")"-  show (StrokeText (a1,a2,a3)) = "strokeText(" ++ jsText a1 ++ "," ++ jsFloat a2 ++ "," ++ jsFloat a3 ++ ")"+  show (StrokeRect (a1,a2,a3,a4)) = "strokeRect(" ++ jsDouble a1 ++ "," ++ jsDouble a2 ++ "," ++ jsDouble a3 ++ "," ++ jsDouble a4 ++ ")"   show (StrokeStyle (a1)) = "strokeStyle = (" ++ jsStyle a1 ++ ")"-  show (ShadowBlur (a1)) = "shadowBlur = (" ++ jsFloat a1 ++ ")"-  show (ShadowColor (a1)) = "shadowColor = (" ++ jsText a1 ++ ")"-  show (ShadowOffsetX (a1)) = "shadowOffsetX = (" ++ jsFloat a1 ++ ")"-  show (ShadowOffsetY (a1)) = "shadowOffsetY = (" ++ jsFloat a1 ++ ")"-  show (TextAlign (a1)) = "textAlign = (" ++ jsText a1 ++ ")"-  show (TextBaseline (a1)) = "textBaseline = (" ++ jsText a1 ++ ")"-  show (Transform (a1,a2,a3,a4,a5,a6)) = "transform(" ++ jsFloat a1 ++ "," ++ jsFloat a2 ++ "," ++ jsFloat a3 ++ "," ++ jsFloat a4 ++ "," ++ jsFloat a5 ++ "," ++ jsFloat a6 ++ ")"-  show (Translate (a1,a2)) = "translate(" ++ jsFloat a1 ++ "," ++ jsFloat a2 ++ ")"+  show (StrokeText (a1,a2,a3)) = "strokeText(" ++ jsText a1 ++ "," ++ jsDouble a2 ++ "," ++ jsDouble a3 ++ ")"+  show (TextAlign (a1)) = "textAlign = (" ++ jsTextAnchorAlignment a1 ++ ")"+  show (TextBaseline (a1)) = "textBaseline = (" ++ jsTextBaselineAlignment a1 ++ ")"+  show (Transform (a1,a2,a3,a4,a5,a6)) = "transform(" ++ jsDouble a1 ++ "," ++ jsDouble a2 ++ "," ++ jsDouble a3 ++ "," ++ jsDouble a4 ++ "," ++ jsDouble a5 ++ "," ++ jsDouble a6 ++ ")"+  show (Translate (a1,a2)) = "translate(" ++ jsDouble a1 ++ "," ++ jsDouble a2 ++ ")"  -- DSL -arc :: (Float,Float,Float,Float,Float,Bool) -> Canvas ()+arc :: (Double, Double, Double, Double, Double, Bool) -> Canvas () arc = Method . Arc -arcTo :: (Float,Float,Float,Float,Float) -> Canvas ()+arcTo :: (Double, Double, Double, Double, Double) -> Canvas () arcTo = Method . ArcTo  beginPath :: () -> Canvas () beginPath () = Method BeginPath -bezierCurveTo :: (Float,Float,Float,Float,Float,Float) -> Canvas ()+bezierCurveTo :: (Double, Double, Double, Double, Double, Double) -> Canvas () bezierCurveTo = Method . BezierCurveTo --- | 'drawImage' takes 2, 4 or 8 floats arguments-drawImage :: Image image => (image,[Float]) -> Canvas ()-drawImage = Method . DrawImage--clearRect :: (Float,Float,Float,Float) -> Canvas ()+clearRect :: (Double, Double, Double, Double) -> Canvas () clearRect = Method . ClearRect  clip :: () -> Canvas ()@@ -75,102 +71,107 @@ closePath :: () -> Canvas () closePath () = Method ClosePath +-- | drawImage' takes 2, 4, or 8 'Double' arguments. See 'drawImageAt', 'drawImageSize', and 'drawImageCrop' for variants with exact numbers of arguments.+drawImage :: Image image => (image,[Double]) -> Canvas ()+drawImage = Method . DrawImage+ fill :: () -> Canvas () fill () = Method Fill -fillRect :: (Float,Float,Float,Float) -> Canvas ()+fillRect :: (Double, Double, Double, Double) -> Canvas () fillRect = Method . FillRect  fillStyle :: Style style => style -> Canvas () fillStyle = Method . FillStyle -fillText :: (Text,Float,Float) -> Canvas ()+fillText :: (Text, Double, Double) -> Canvas () fillText = Method . FillText  font :: Text -> Canvas () font = Method . Font -globalAlpha :: Float -> Canvas ()+globalAlpha :: Double -> Canvas () globalAlpha = Method . GlobalAlpha  globalCompositeOperation :: Text -> Canvas () globalCompositeOperation = Method . GlobalCompositeOperation -lineCap :: Text -> Canvas ()+lineCap :: LineEndCap -> Canvas () lineCap = Method . LineCap -lineJoin :: Text -> Canvas ()+lineJoin :: LineJoinCorner -> Canvas () lineJoin = Method . LineJoin -lineTo :: (Float,Float) -> Canvas ()+lineTo :: (Double, Double) -> Canvas () lineTo = Method . LineTo -lineWidth :: Float -> Canvas ()+lineWidth :: Double -> Canvas () lineWidth = Method . LineWidth -miterLimit :: Float -> Canvas ()+miterLimit :: Double -> Canvas () miterLimit = Method . MiterLimit -moveTo :: (Float,Float) -> Canvas ()+moveTo :: (Double, Double) -> Canvas () moveTo = Method . MoveTo -putImageData :: (ImageData,[Float]) -> Canvas ()+-- | 'putImageData' takes 2 or 6 'Double' arguments. See `putImageDataAt' and `putImageDataDirty' for variants with exact numbers of arguments.+putImageData :: (ImageData, [Double]) -> Canvas () putImageData = Method . PutImageData -quadraticCurveTo :: (Float,Float,Float,Float) -> Canvas ()+quadraticCurveTo :: (Double, Double, Double, Double) -> Canvas () quadraticCurveTo = Method . QuadraticCurveTo -rect :: (Float,Float,Float,Float) -> Canvas ()+rect :: (Double, Double, Double, Double) -> Canvas () rect = Method . Rect  restore :: () -> Canvas () restore () = Method Restore -rotate :: Float -> Canvas ()+rotate :: Double -> Canvas () rotate = Method . Rotate -scale :: (Float,Float) -> Canvas ()-scale = Method . Scale- save :: () -> Canvas () save () = Method Save -setTransform :: (Float,Float,Float,Float,Float,Float) -> Canvas ()+scale :: (Double, Double) -> Canvas ()+scale = Method . Scale++setTransform :: (Double, Double, Double, Double, Double, Double) -> Canvas () setTransform = Method . SetTransform +shadowBlur :: Double -> Canvas ()+shadowBlur = Method . ShadowBlur++shadowColor :: CanvasColor canvasColor => canvasColor -> Canvas ()+shadowColor = Method . ShadowColor++shadowOffsetX :: Double -> Canvas ()+shadowOffsetX = Method . ShadowOffsetX++shadowOffsetY :: Double -> Canvas ()+shadowOffsetY = Method . ShadowOffsetY+ stroke :: () -> Canvas () stroke () = Method Stroke -strokeRect :: (Float,Float,Float,Float) -> Canvas ()+strokeRect :: (Double, Double, Double, Double) -> Canvas () strokeRect = Method . StrokeRect -strokeText :: (Text,Float,Float) -> Canvas ()-strokeText = Method . StrokeText- strokeStyle :: Style style => style -> Canvas () strokeStyle = Method . StrokeStyle -shadowBlur :: Float -> Canvas ()-shadowBlur = Method . ShadowBlur--shadowColor :: Text -> Canvas ()-shadowColor = Method . ShadowColor--shadowOffsetX :: Float -> Canvas ()-shadowOffsetX = Method . ShadowOffsetX--shadowOffsetY :: Float -> Canvas ()-shadowOffsetY = Method . ShadowOffsetY+strokeText :: (Text,Double, Double) -> Canvas ()+strokeText = Method . StrokeText -textAlign :: Text -> Canvas ()+textAlign :: TextAnchorAlignment -> Canvas () textAlign = Method . TextAlign -textBaseline :: Text -> Canvas ()+textBaseline :: TextBaselineAlignment -> Canvas () textBaseline = Method . TextBaseline -transform :: (Float,Float,Float,Float,Float,Float) -> Canvas ()+transform :: (Double, Double, Double, Double, Double, Double) -> Canvas () transform = Method . Transform -translate :: (Float,Float) -> Canvas ()+translate :: (Double, Double) -> Canvas () translate = Method . Translate 

@@ -2,51 +2,75 @@  module Graphics.Blank.JavaScript where -import Data.List-import Data.Word (Word8)-import Numeric-import Data.Text (Text)+import           Control.Applicative +import           Data.Char (isControl, isAscii, ord)+import           Data.Colour+import           Data.Colour.SRGB+import           Data.Default.Class+import           Data.Ix+import           Data.List+import           Data.String+import           Data.Text (Text, unpack)+import           Data.Word (Word8)+ import qualified Data.Vector.Unboxed as V-import Data.Vector.Unboxed (Vector)+import           Data.Vector.Unboxed (Vector) +import           Numeric++import           Text.ParserCombinators.ReadP (skipSpaces, string)+import           Text.ParserCombinators.ReadPrec+import           Text.Read+ ------------------------------------------------------------- --- TODO: close off +-- TODO: close off class Image a where   jsImage :: a -> String   width  :: Num b => a -> b   height :: Num b => a -> b -instance Image CanvasImage where +instance Image CanvasImage where   jsImage = jsCanvasImage-  width  (CanvasImage _ w _) = fromIntegral w +  width  (CanvasImage _ w _) = fromIntegral w   height (CanvasImage _ _ h) = fromIntegral h-  + -- The Image of a canvas is the the canvas context, not the DOM entry, so -- you need to indirect back to the DOM here. instance Image CanvasContext where   jsImage = (++ ".canvas") . jsCanvasContext-  width  (CanvasContext _ w _) = fromIntegral w +  width  (CanvasContext _ w _) = fromIntegral w   height (CanvasContext _ _ h) = fromIntegral h  -- instance Element Video  -- Not supported  ----------------------------------------------------------------------------- --- TODO: close off +-- TODO: close off class Style a where   jsStyle :: a -> String -instance Style Text           where { jsStyle = jsText }-instance Style CanvasGradient where { jsStyle = jsCanvasGradient }-instance Style CanvasPattern  where { jsStyle = jsCanvasPattern }+instance Style Text                 where { jsStyle = jsText }+instance Style CanvasGradient       where { jsStyle = jsCanvasGradient }+instance Style CanvasPattern        where { jsStyle = jsCanvasPattern }+instance Style (Colour Double)      where { jsStyle = jsColour }+instance Style (AlphaColour Double) where { jsStyle = jsAlphaColour } +class Style a => CanvasColor a++jsCanvasColor :: CanvasColor color => color -> String+jsCanvasColor = jsStyle++instance CanvasColor Text+instance CanvasColor (Colour Double)+instance CanvasColor (AlphaColour Double)+ -------------------------------------------------------------  -- | A handle to an offscreen canvas. CanvasContext can not be destroyed. data CanvasContext = CanvasContext Int Int Int- deriving (Show,Eq,Ord)                + deriving (Show,Eq,Ord)  -- | A handle to the Image. CanvasImages can not be destroyed. data CanvasImage = CanvasImage Int Int Int deriving (Show,Eq,Ord)@@ -59,11 +83,173 @@  ------------------------------------------------------------- +-- | The direction in which a 'CanvasPattern' repeats.+data RepeatDirection = Repeat   -- ^ The pattern repeats both horizontally+                                --   and vertically.+                     | RepeatX  -- ^ The pattern repeats only horizontally.+                     | RepeatY  -- ^ The pattern repeats only vertically.+                     | NoRepeat -- ^ The pattern displays only once and+                                --   does not repeat.+  deriving Eq++instance Default RepeatDirection where+  def = Repeat++instance IsString RepeatDirection where+  fromString = read++instance Read RepeatDirection where+  readPrec = parens . lift $ do+      skipSpaces+      (string "repeat"          >> return Repeat)+        <|> (string "repeat-x"  >> return RepeatX)+        <|> (string "repeat-y"  >> return RepeatY)+        <|> (string "no-repeat" >> return NoRepeat)++instance Show RepeatDirection where+  showsPrec _ rd = showString $ case rd of+      Repeat   -> "repeat"+      RepeatX  -> "repeat-x"+      RepeatY  -> "repeat-y"+      NoRepeat -> "no-repeat"++-- | The style of the caps on the endpoints of a line.+data LineEndCap = ButtCap   -- ^ Flat edges+                | RoundCap  -- ^ Semicircular end caps+                | SquareCap -- ^ Square end caps+  deriving Eq++instance Default LineEndCap where+  def = ButtCap++instance IsString LineEndCap where+  fromString = read++instance Read LineEndCap where+  readPrec = parens $ do+      Ident s <- lexP+      case s of+          "butt"   -> return ButtCap  +          "round"  -> return RoundCap +          "square" -> return SquareCap+          _        -> pfail++instance Show LineEndCap where+  showsPrec _ le = showString $ case le of+      ButtCap   -> "butt"+      RoundCap  -> "round"+      SquareCap -> "square"++-- | The style of corner that is created when two lines join.+data LineJoinCorner = BevelCorner -- ^ A filled triangle with a beveled edge+                                  --   connects two lines.+                    | RoundCorner -- ^ A filled arc connects two lines.+                    | MiterCorner -- ^ A filled triangle with a sharp edge+                                  --   connects two lines.+  deriving Eq++instance Default LineJoinCorner where+  def = MiterCorner++instance IsString LineJoinCorner where+  fromString = read++instance Read LineJoinCorner where+  readPrec = parens $ do+      Ident s <- lexP+      case s of+          "bevel" -> return BevelCorner+          "round" -> return RoundCorner+          "miter" -> return MiterCorner+          _       -> pfail++instance Show LineJoinCorner where+  showsPrec _ corner = showString $ case corner of+      BevelCorner -> "bevel"+      RoundCorner -> "round"+      MiterCorner -> "miter"++-- | The anchor point for text in the current 'DeviceContext'.+data TextAnchorAlignment = StartAnchor  -- ^ The text is anchored at either its left edge+                                        --   (if the canvas is left-to-right) or its right+                                        --   edge (if the canvas is right-to-left).+                         | EndAnchor    -- ^ The text is anchored at either its right edge+                                        --   (if the canvas is left-to-right) or its left+                                        --   edge (if the canvas is right-to-left).+                         | CenterAnchor -- ^ The text is anchored in its center.+                         | LeftAnchor   -- ^ The text is anchored at its left edge.+                         | RightAnchor  -- ^ the text is anchored at its right edge.+  deriving Eq++instance Default TextAnchorAlignment where+  def = StartAnchor++instance IsString TextAnchorAlignment where+  fromString = read++instance Read TextAnchorAlignment where+  readPrec = parens $ do+      Ident s <- lexP+      case s of+          "start"  -> return StartAnchor+          "end"    -> return EndAnchor+          "center" -> return CenterAnchor+          "left"   -> return LeftAnchor+          "right"  -> return RightAnchor+          _        -> pfail++instance Show TextAnchorAlignment where+  showsPrec _ align = showString $ case align of+      StartAnchor  -> "start"+      EndAnchor    -> "end"+      CenterAnchor -> "center"+      LeftAnchor   -> "left"+      RightAnchor  -> "right"++-- | The baseline alignment used when drawing text in the current 'DeviceContext'.+--   The baselines are ordered from highest ('Top') to lowest ('Bottom').+data TextBaselineAlignment = TopBaseline+                           | HangingBaseline+                           | MiddleBaseline+                           | AlphabeticBaseline+                           | IdeographicBaseline+                           | BottomBaseline+  deriving (Bounded, Eq, Ix, Ord)++instance Default TextBaselineAlignment where+  def = AlphabeticBaseline++instance IsString TextBaselineAlignment where+  fromString = read++instance Read TextBaselineAlignment where+  readPrec = parens $ do+      Ident s <- lexP+      case s of+          "top"         -> return TopBaseline+          "hanging"     -> return HangingBaseline+          "middle"      -> return MiddleBaseline+          "alphabetic"  -> return AlphabeticBaseline+          "ideographic" -> return IdeographicBaseline+          "bottom"      -> return BottomBaseline+          _             -> pfail++instance Show TextBaselineAlignment where+  showsPrec _ bl = showString $ case bl of+      TopBaseline         -> "top"+      HangingBaseline     -> "hanging"+      MiddleBaseline      -> "middle"+      AlphabeticBaseline  -> "alphabetic"+      IdeographicBaseline -> "ideographic"+      BottomBaseline      -> "bottom"++-------------------------------------------------------------+ -- | 'ImageData' is a transliteration of the JavaScript ImageData, --   There are two 'Int's, and one (unboxed) 'Vector' of 'Word8's. --  width, height, data can be projected from 'ImageData', --  'Vector.length' can be used to find the length.--- +-- --   Note: 'ImageData' lives on the server, not the client.  data ImageData = ImageData !Int !Int !(Vector Word8) deriving (Show, Eq, Ord)@@ -73,32 +259,47 @@ class JSArg a where   showJS :: a -> String -instance JSArg Float where-  showJS a = showFFloat (Just 3) a ""        +instance JSArg (AlphaColour Double) where+  showJS aCol+      | a >= 1    = jsColour rgbCol+      | a <= 0    = jsLiteralString "rgba(0,0,0,0)"+      | otherwise = jsLiteralString $ "rgba("+          ++ show r     ++ ","+          ++ show g     ++ ","+          ++ show b     ++ ","+          ++ jsDouble a ++ ")"+    where+      a         = alphaChannel aCol+      rgbCol    = darken (recip a) $ aCol `over` black+      RGB r g b = toSRGB24 rgbCol -jsFloat :: Float -> String-jsFloat = showJS +jsAlphaColour :: AlphaColour Double -> String+jsAlphaColour = showJS -instance JSArg Int where-  showJS a = show a+instance JSArg Bool where+  showJS True  = "true"+  showJS False = "false" +jsBool :: Bool -> String+jsBool = showJS+ instance JSArg CanvasContext where   showJS (CanvasContext n _ _) = "canvasbuffers[" ++ show n ++ "]"  jsCanvasContext :: CanvasContext -> String-jsCanvasContext = showJS +jsCanvasContext = showJS  instance JSArg CanvasImage where   showJS (CanvasImage n _ _) = "images[" ++ show n ++ "]"  jsCanvasImage :: CanvasImage -> String-jsCanvasImage = showJS +jsCanvasImage = showJS  instance JSArg CanvasGradient where   showJS (CanvasGradient n) = "gradients[" ++ show n ++ "]"  jsCanvasGradient :: CanvasGradient -> String-jsCanvasGradient = showJS +jsCanvasGradient = showJS  instance JSArg CanvasPattern where   showJS (CanvasPattern n) = "patterns[" ++ show n ++ "]"@@ -106,6 +307,18 @@ jsCanvasPattern :: CanvasPattern -> String jsCanvasPattern = showJS +instance JSArg (Colour Double) where+  showJS = jsLiteralString . sRGB24show++jsColour :: Colour Double -> String+jsColour = showJS++instance JSArg Double where+  showJS a = showFFloat (Just 3) a ""++jsDouble :: Double -> String+jsDouble = showJS+ instance JSArg ImageData where   showJS (ImageData w h d) = "ImageData(" ++ show w ++ "," ++ show h ++ ",[" ++ vs ++ "])"      where@@ -114,18 +327,86 @@ jsImageData :: ImageData -> String jsImageData = showJS -instance JSArg Bool where-  showJS True  = "true"-  showJS False = "false"+instance JSArg Int where+  showJS a = show a -jsBool :: Bool -> String-jsBool = showJS+instance JSArg LineEndCap where+  showJS = jsLiteralString . show -instance JSArg Text where -  showJS str = show str+jsLineEndCap :: LineEndCap -> String+jsLineEndCap = showJS +instance JSArg LineJoinCorner where+  showJS = jsLiteralString . show++jsLineJoinCorner :: LineJoinCorner -> String+jsLineJoinCorner = showJS++jsList :: (a -> String) -> [a] -> String+jsList js = concat . intersperse "," . map js++instance JSArg RepeatDirection where+  showJS = jsLiteralString . show++jsRepeatDirection :: RepeatDirection -> String+jsRepeatDirection = showJS++instance JSArg Text where+  showJS = jsLiteralString . unpack+ jsText :: Text -> String jsText = showJS -jsList :: (a -> String) -> [a] -> String-jsList js = concat . intersperse "," . map js +instance JSArg TextAnchorAlignment where+  showJS = jsLiteralString . show++jsTextAnchorAlignment :: TextAnchorAlignment -> String+jsTextAnchorAlignment = showJS++instance JSArg TextBaselineAlignment where+  showJS = jsLiteralString . show++jsTextBaselineAlignment :: TextBaselineAlignment -> String+jsTextBaselineAlignment = showJS++-- The following was from our Sunroof compiler.+-- -------------------------------------------------------------+-- String Conversion Utilities: Haskell -> JS+-- -------------------------------------------------------------++-- | Transform a Haskell string into a string representing a JS string literal.+jsLiteralString :: String -> String+jsLiteralString = jsQuoteString . jsEscapeString++-- | Add quotes to a string.+jsQuoteString :: String -> String+jsQuoteString s = "\"" ++ s ++ "\""++-- | Transform a character to a string that represents its JS+--   unicode escape sequence.+jsUnicodeChar :: Char -> String+jsUnicodeChar c =+  let hex = showHex (ord c) ""+  in ('\\':'u': replicate (4 - length hex) '0') ++ hex++-- | Correctly replace Haskell characters by the JS escape sequences.+jsEscapeString :: String -> String+jsEscapeString [] = []+jsEscapeString (c:cs) = case c of+  -- Backslash has to remain backslash in JS.+  '\\' -> '\\' : '\\' : jsEscapeString cs+  -- Special control sequences.+  '\0' -> jsUnicodeChar '\0' ++ jsEscapeString cs -- Ambigous with numbers+  '\a' -> jsUnicodeChar '\a' ++ jsEscapeString cs -- Non JS+  '\b' -> '\\' : 'b' : jsEscapeString cs+  '\f' -> '\\' : 'f' : jsEscapeString cs+  '\n' -> '\\' : 'n' : jsEscapeString cs+  '\r' -> '\\' : 'r' : jsEscapeString cs+  '\t' -> '\\' : 't' : jsEscapeString cs+  '\v' -> '\\' : 'v' : jsEscapeString cs+  '\"' -> '\\' : '\"' : jsEscapeString cs+  '\'' -> '\\' : '\'' : jsEscapeString cs+  -- Non-control ASCII characters can remain as they are.+  c' | not (isControl c') && isAscii c' -> c' : jsEscapeString cs+  -- All other non ASCII signs are escaped to unicode.+  c' -> jsUnicodeChar c' ++ jsEscapeString cs

@@ -1,13 +1,841 @@--- | These are overloaded versions of 'strokeStyle' and 'fillStyle'.- module Graphics.Blank.Style -        ( strokeStyle+        ( -- * Overloaded versions of 'Canvas' functions+          strokeStyle         , fillStyle-        , Style+        , shadowColor+        , addColorStop+        , Style(..)+        , CanvasColor+          -- * 'CanvasColor' creation+        , Alpha+        , Percentage+        , rgb+        , rgbPercent+        , rgba+        , rgbaPercent+        , hsl+        , hsla+          -- * @colour@ reexports+        , readColourName+        , aliceblue+        , antiquewhite+        , aqua+        , aquamarine+        , azure+        , beige+        , bisque+        , black+        , blanchedalmond+        , blue+        , blueviolet+        , brown+        , burlywood+        , cadetblue+        , chartreuse+        , chocolate+        , coral+        , cornflowerblue+        , cornsilk+        , crimson+        , cyan+        , darkblue+        , darkcyan+        , darkgoldenrod+        , darkgray+        , darkgreen+        , darkgrey+        , darkkhaki+        , darkmagenta+        , darkolivegreen+        , darkorange+        , darkorchid+        , darkred+        , darksalmon+        , darkseagreen+        , darkslateblue+        , darkslategray+        , darkslategrey+        , darkturquoise+        , darkviolet+        , deeppink+        , deepskyblue+        , dimgray+        , dimgrey+        , dodgerblue+        , firebrick+        , floralwhite+        , forestgreen+        , fuchsia+        , gainsboro+        , ghostwhite+        , gold+        , goldenrod+        , gray+        , green+        , grey+        , greenyellow+        , honeydew+        , hotpink+        , indianred+        , indigo+        , ivory+        , khaki+        , lavender+        , lavenderblush+        , lawngreen+        , lemonchiffon+        , lightblue+        , lightcoral+        , lightcyan+        , lightgoldenrodyellow+        , lightgray+        , lightgreen+        , lightgrey+        , lightpink+        , lightsalmon+        , lightseagreen+        , lightskyblue+        , lightslategray+        , lightslategrey+        , lightsteelblue+        , lightyellow+        , lime+        , limegreen+        , linen+        , magenta+        , maroon+        , mediumaquamarine+        , mediumblue+        , mediumorchid+        , mediumpurple+        , mediumseagreen+        , mediumslateblue+        , mediumspringgreen+        , mediumturquoise+        , mediumvioletred+        , midnightblue+        , mintcream+        , mistyrose+        , moccasin+        , navajowhite+        , navy+        , oldlace+        , olive+        , olivedrab+        , orange+        , orangered+        , orchid+        , palegoldenrod+        , palegreen+        , paleturquoise+        , palevioletred+        , papayawhip+        , peachpuff+        , peru+        , pink+        , plum+        , powderblue+        , purple+        , red+        , rosybrown+        , royalblue+        , saddlebrown+        , salmon+        , sandybrown+        , seagreen+        , seashell+        , sienna+        , silver+        , skyblue+        , slateblue+        , slategray+        , slategrey+        , snow+        , springgreen+        , steelblue+        , tan+        , teal+        , thistle+        , tomato+        , turquoise+        , violet+        , wheat+        , white+        , whitesmoke+        , yellow+        , yellowgreen+        , rebeccapurple+        , transparent         ) where -import Graphics.Blank.Generated-import Graphics.Blank.JavaScript+import qualified Data.Colour as Colour+import           Data.Colour hiding (black, transparent)+import qualified Data.Colour.Names as Names+import           Data.Colour.RGBSpace+import qualified Data.Colour.RGBSpace.HSL as HSL+import           Data.Colour.SRGB+import           Data.Word +import           Graphics.Blank.Canvas+import           Graphics.Blank.Generated+import           Graphics.Blank.JavaScript +import           Prelude hiding (tan) +-- |+-- A value ranging from 0.0 to 1.0. A color with an alpha value of 0.0 is 'transparent',+-- and a color with an alpha value of 1.0 is opaque.+type Alpha = Double++-- | A value ranging from 0.0 to 100.0.+type Percentage = Double++-- |+-- Specifies a 'Colour' by its red, green, and blue components, where each component+-- is an integer between 0 and 255.+rgb :: Word8 -> Word8 -> Word8 -> Colour Double+rgb = sRGB24++-- |+-- Specifies a 'Colour' by its red, green, and blue components, where each component+-- is given by a percentage of 255.+rgbPercent :: Percentage -> Percentage -> Percentage -> Colour Double+rgbPercent r g b = sRGB (r/100) (g/100) (b/100)++-- |+-- Specifies an 'AlphaColour' by its RGB components and an alpha value.+-- +-- @+-- 'rgba' r g b 0.0 = 'transparent'+-- @+rgba :: Word8 -> Word8 -> Word8 -> Alpha -> AlphaColour Double+rgba r g b = withOpacity $ rgb r g b++-- |+-- Specifies an 'AlphaColour' by its RGB component percentages and an alpha value.+-- +-- @+-- 'rgbaPercent' r g b 0.0 = 'transparent'+-- @+rgbaPercent :: Percentage -> Percentage -> Percentage -> Alpha -> AlphaColour Double+rgbaPercent r g b = withOpacity $ rgbPercent r g b++-- |+-- Specifies a 'Colour' by its hue (which ranges from 0° to 360°), saturation, and+-- value.+hsl :: Int -> Percentage -> Percentage -> Colour Double+hsl h s l = uncurryRGB sRGB $ HSL.hsl (realToFrac h) (s/100) (l/100)++-- |+-- Specifies an 'AlphaColour' by its HSV values and an alpha value.+-- +-- @+-- 'hsla' h s v 0.0 = 'transparent'+-- @+hsla :: Int -> Percentage -> Percentage -> Alpha -> AlphaColour Double+hsla h s l = withOpacity $ hsl h s l++-- |+-- Takes a string naming a 'Colour' (must be all lowercase) and returns it. Fails if+-- the name is not recognized.+readColourName :: Monad m => String -> m (Colour Double)+readColourName "rebeccapurple" = return rebeccapurple+readColourName name            = Names.readColourName name++-- | @#F0F8FF@, @rgb(240, 248, 255)@, @hsl(208, 100%, 97%)@+aliceblue :: Colour Double+aliceblue = Names.aliceblue++-- | @#FAEBD7@, @rgb(250, 235, 215)@, @hsl(34, 78%, 91%)@+antiquewhite :: Colour Double+antiquewhite = Names.antiquewhite++-- | @#00FFFF@, @rgb(0, 255, 255)@, @hsl(180, 100%, 50%)@. Same as 'cyan'.+aqua :: Colour Double+aqua = Names.aqua++-- | @#7FFFD4@, @rgb(127, 255, 212)@, @hsl(160, 100%, 75%)@+aquamarine :: Colour Double+aquamarine = Names.aquamarine++-- | @#F0FFFF@, @rgb(240, 255, 255)@, @hsl(180, 100%, 97%)@+azure :: Colour Double+azure = Names.azure++-- | @#F5F5DC@, @rgb(245, 245, 220)@, @hsl(60, 56%, 91%)@+beige :: Colour Double+beige = Names.beige++-- | @#FFE4C4@, @rgb(255, 228, 196)@, @hsl(33, 100%, 88%)@+bisque :: Colour Double+bisque = Names.bisque++-- | @#000000@, @rgb(0, 0, 0)@, @hsl(0, 0%, 0%)@+black :: Colour Double+black = Colour.black++-- | @#FFEBCD@, @rgb(255, 235, 205)@, @hsl(36, 100%, 90%)@+blanchedalmond :: Colour Double+blanchedalmond = Names.blanchedalmond++-- | @#0000FF@, @rgb(0, 0, 255)@, @hsl(240, 100%, 50%)@+blue :: Colour Double+blue = Names.blue++-- | @#8A2BE2@, @rgb(138, 43, 226)@, @hsl(271, 76%, 53%)@+blueviolet :: Colour Double+blueviolet = Names.blueviolet++-- | @#A52A2A@, @rgb(165, 42, 42)@, @hsl(0, 59%, 41%)@+brown :: Colour Double+brown = Names.brown++-- | @#DEB887@, @rgb(222, 184, 135)@, @hsl(34, 57%, 70%)@+burlywood :: Colour Double+burlywood = Names.burlywood++-- | @#5F9EA0@, @rgb(95, 158, 160)@, @hsl(182, 25%, 50%)@+cadetblue :: Colour Double+cadetblue = Names.cadetblue++-- | @#7FFF00@, @rgb(127, 255, 0)@, @hsl(90, 100%, 50%)@+chartreuse :: Colour Double+chartreuse = Names.chartreuse++-- | @#D2691E@, @rgb(210, 105, 30)@, @hsl(25, 75%, 47%)@+chocolate :: Colour Double+chocolate = Names.chocolate++-- | @#FF7F50@, @rgb(255, 127, 80)@, @hsl(16, 100%, 66%)@+coral :: Colour Double+coral = Names.coral++-- | @#6495ED@, @rgb(100, 149, 237)@, @hsl(219, 79%, 66%)@+cornflowerblue :: Colour Double+cornflowerblue = Names.cornflowerblue++-- | @#FFF8DC@, @rgb(255, 248, 220)@, @hsl(48, 100%, 93%)@+cornsilk :: Colour Double+cornsilk = Names.cornsilk++-- | @#DC143C@, @rgb(220, 20, 60)@, @hsl(348, 83%, 58%)@+crimson :: Colour Double+crimson = Names.crimson++-- | @#00FFFF@, @rgb(0, 255, 255)@, @hsl(180, 100%, 50%)@. Same as 'aqua'.+cyan :: Colour Double+cyan = Names.cyan++-- | @#00008B@, @rgb(0, 0, 139)@, @hsl(240, 100%, 27%)@+darkblue :: Colour Double+darkblue = Names.darkblue++-- | @#008B8B@, @rgb(0, 139, 139)@, @hsl(180, 100%, 27%)@+darkcyan :: Colour Double+darkcyan = Names.darkcyan++-- | @#B8860B@, @rgb(184, 134, 11)@, @hsl(43, 89%, 38%)@+darkgoldenrod :: Colour Double+darkgoldenrod = Names.darkgoldenrod++-- | @#A9A9A9@, @rgb(169, 169, 169)@, @hsl(0, 0%, 66%)@. Same as 'darkgrey'.+darkgray :: Colour Double+darkgray = Names.darkgray++-- | @#006400@, @rgb(0, 100, 0)@, @hsl(120, 100%, 20%)@+darkgreen :: Colour Double+darkgreen = Names.darkgreen++-- | @#A9A9A9@, @rgb(169, 169, 169)@, @hsl(0, 0%, 66%)@. Same as 'darkgray'.+darkgrey :: Colour Double+darkgrey = Names.darkgrey++-- | @#BDB76B@, @rgb(189, 183, 107)@, @hsl(56, 38%, 58%)@+darkkhaki :: Colour Double+darkkhaki = Names.darkkhaki++-- | @#8B008B@, @rgb(139, 0, 139)@, @hsl(300, 100%, 27%)@+darkmagenta :: Colour Double+darkmagenta = Names.darkmagenta++-- | @#556B2F@, @rgb(85, 107, 47)@, @hsl(82, 39%, 30%)@+darkolivegreen :: Colour Double+darkolivegreen = Names.darkolivegreen++-- | @#FF8C00@, @rgb(255, 140, 0)@, @hsl(33, 100%, 50%)@+darkorange :: Colour Double+darkorange = Names.darkorange++-- | @#9932CC@, @rgb(153, 50, 204)@, @hsl(280, 61%, 50%)@+darkorchid :: Colour Double+darkorchid = Names.darkorchid++-- | @#8B0000@, @rgb(139, 0, 0)@, @hsl(0, 100%, 27%)@+darkred :: Colour Double+darkred = Names.darkred++-- | @#E9967A@, @rgb(233, 150, 122)@, @hsl(15, 72%, 70%)@+darksalmon :: Colour Double+darksalmon = Names.darksalmon++-- | @#8FBC8F@, @rgb(143, 188, 143)@, @hsl(120, 25%, 65%)@+darkseagreen :: Colour Double+darkseagreen = Names.darkseagreen++-- | @#483D8B@, @rgb(72, 61, 139)@, @hsl(248, 39%, 39%)@+darkslateblue :: Colour Double+darkslateblue = Names.darkslateblue++-- | @#2F4F4F@, @rgb(47, 79, 79)@, @hsl(180, 25%, 25%)@. Same as 'darkslategrey'.+darkslategray :: Colour Double+darkslategray = Names.darkslategray++-- | @#2F4F4F@, @rgb(47, 79, 79)@, @hsl(180, 25%, 25%)@. Same as 'darkslategray'.+darkslategrey :: Colour Double+darkslategrey = Names.darkslategrey++-- | @#00CED1@, @rgb(0, 206, 209)@, @hsl(181, 100%, 41%)@+darkturquoise :: Colour Double+darkturquoise = Names.darkturquoise++-- | @#9400D3@, @rgb(148, 0, 211)@, @hsl(282, 100%, 41%)@+darkviolet :: Colour Double+darkviolet = Names.darkviolet++-- | @#FF1493@, @rgb(255, 20, 147)@, @hsl(328, 100%, 54%)@+deeppink :: Colour Double+deeppink = Names.deeppink++-- | @#00BFFF@, @rgb(0, 191, 255)@, @hsl(195, 100%, 50%)@+deepskyblue :: Colour Double+deepskyblue = Names.deepskyblue++-- | @#696969@, @rgb(105, 105, 105)@, @hsl(0, 0%, 41%)@. Same as 'darkgrey'.+dimgray :: Colour Double+dimgray = Names.dimgray++-- | @#696969@, @rgb(105, 105, 105)@, @hsl(0, 0%, 41%)@. Same as 'darkgray'.+dimgrey :: Colour Double+dimgrey = Names.dimgrey++-- | @#1E90FF@, @rgb(30, 144, 255)@, @hsl(210, 100%, 56%)@+dodgerblue :: Colour Double+dodgerblue = Names.dodgerblue++-- | @#B22222@, @rgb(178, 34, 34)@, @hsl(0, 68%, 42%)@+firebrick :: Colour Double+firebrick = Names.firebrick++-- | @#FFFAF0@, @rgb(255, 250, 240)@, @hsl(40, 100%, 97%)@+floralwhite :: Colour Double+floralwhite = Names.floralwhite++-- | @#228B22@, @rgb(34, 139, 34)@, @hsl(120, 61%, 34%)@+forestgreen :: Colour Double+forestgreen = Names.forestgreen++-- | @#FF00FF@, @rgb(255, 0, 255)@, @hsl(300, 100%, 50%)@. Same as 'magenta'.+fuchsia :: Colour Double+fuchsia = Names.fuchsia++-- | @#DCDCDC@, @rgb(220, 220, 220)@, @hsl(0, 0%, 86%)@+gainsboro :: Colour Double+gainsboro = Names.gainsboro++-- | @#F8F8FF@, @rgb(248, 248, 255)@, @hsl(240, 100%, 99%)@+ghostwhite :: Colour Double+ghostwhite = Names.ghostwhite++-- | @#FFD700@, @rgb(255, 215, 0)@, @hsl(51, 100%, 50%)@+gold :: Colour Double+gold = Names.gold++-- | @#DAA520@, @rgb(218, 165, 32)@, @hsl(43, 74%, 49%)@+goldenrod :: Colour Double+goldenrod = Names.goldenrod++-- | @#808080@, @rgb(128, 128, 128)@, @hsl(0, 0%, 50%)@. Same as 'grey'.+gray :: Colour Double+gray = Names.gray++-- | @#008000@, @rgb(0, 128, 0)@, @hsl(120, 100%, 25%)@+green :: Colour Double+green = Names.green++-- | @#808080@, @rgb(128, 128, 128)@, @hsl(0, 0%, 50%)@. Same as 'gray'.+grey :: Colour Double+grey = Names.grey++-- | @#ADFF2F@, @rgb(173, 255, 47)@, @hsl(84, 100%, 59%)@+greenyellow :: Colour Double+greenyellow = Names.greenyellow++-- | @#F0FFF0@, @rgb(240, 255, 240)@, @hsl(120, 100%, 97%)@+honeydew :: Colour Double+honeydew = Names.honeydew++-- | @#FF69B4@, @rgb(255, 105, 180)@, @hsl(330, 100%, 71%)@+hotpink :: Colour Double+hotpink = Names.hotpink++-- | @#CD5C5C@, @rgb(205, 92, 92)@, @hsl(0, 53%, 58%)@+indianred :: Colour Double+indianred = Names.indianred++-- | @#4B0082@, @rgb(75, 0, 130)@, @hsl(275, 100%, 25%)@+indigo :: Colour Double+indigo = Names.indigo++-- | @#FFFFF0@, @rgb(255, 255, 240)@, @hsl(60, 100%, 97%)@+ivory :: Colour Double+ivory = Names.ivory++-- | @#F0E68C@, @rgb(240, 230, 140)@, @hsl(54, 77%, 75%)@+khaki :: Colour Double+khaki = Names.khaki++-- | @#E6E6FA@, @rgb(230, 230, 250)@, @hsl(240, 67%, 94%)@+lavender :: Colour Double+lavender = Names.lavender++-- | @#FFF0F5@, @rgb(255, 240, 245)@, @hsl(340, 100%, 97%)@+lavenderblush :: Colour Double+lavenderblush = Names.lavenderblush++-- | @#7CFC00@, @rgb(124, 252, 0)@, @hsl(90, 100%, 49%)@+lawngreen :: Colour Double+lawngreen = Names.lawngreen++-- | @#FFFACD@, @rgb(255, 250, 205)@, @hsl(54, 100%, 90%)@+lemonchiffon :: Colour Double+lemonchiffon = Names.lemonchiffon++-- | @#ADD8E6@, @rgb(173, 216, 230)@, @hsl(195, 53%, 79%)@+lightblue :: Colour Double+lightblue = Names.lightblue++-- | @#F08080@, @rgb(240, 128, 128)@, @hsl(0, 79%, 72%)@+lightcoral :: Colour Double+lightcoral = Names.lightcoral++-- | @#E0FFFF@, @rgb(224, 255, 255)@, @hsl(180, 100%, 94%)@+lightcyan :: Colour Double+lightcyan = Names.lightcyan++-- | @#FAFAD2@, @rgb(250, 250, 210)@, @hsl(60, 80%, 90%)@+lightgoldenrodyellow :: Colour Double+lightgoldenrodyellow = Names.lightgoldenrodyellow++-- | @#D3D3D3@, @rgb(211, 211, 211)@, @hsl(0, 0%, 83%)@. Same as 'lightgrey'.+lightgray :: Colour Double+lightgray = Names.lightgray++-- | @#90EE90@, @rgb(144, 238, 144)@, @hsl(120, 73%, 75%)@+lightgreen :: Colour Double+lightgreen = Names.lightgreen++-- | @#D3D3D3@, @rgb(211, 211, 211)@, @hsl(0, 0%, 83%)@. Same as 'lightgrey'.+lightgrey :: Colour Double+lightgrey = Names.lightgrey++-- | @#FFB6C1@, @rgb(255, 182, 193)@, @hsl(351, 100%, 86%)@+lightpink :: Colour Double+lightpink = Names.lightpink++-- | @#FFA07A@, @rgb(255, 160, 122)@, @hsl(17, 100%, 74%)@+lightsalmon :: Colour Double+lightsalmon = Names.lightsalmon++-- | @#20B2AA@, @rgb(32, 178, 170)@, @hsl(177, 70%, 41%)@+lightseagreen :: Colour Double+lightseagreen = Names.lightseagreen++-- | @#87CEFA@, @rgb(135, 206, 250)@, @hsl(203, 92%, 75%)@+lightskyblue :: Colour Double+lightskyblue = Names.lightskyblue++-- | @#778899@, @rgb(119, 136, 153)@, @hsl(210, 14%, 53%)@. Same as 'lightslategrey'.+lightslategray :: Colour Double+lightslategray = Names.lightslategray++-- | @#778899@, @rgb(119, 136, 153)@, @hsl(210, 14%, 53%)@. Same as 'lightslategray'.+lightslategrey :: Colour Double+lightslategrey = Names.lightslategrey++-- | @#B0C4DE@, @rgb(176, 196, 222)@, @hsl(214, 41%, 78%)@+lightsteelblue :: Colour Double+lightsteelblue = Names.lightsteelblue++-- | @#FFFFE0@, @rgb(255, 255, 224)@, @hsl(60, 100%, 94%)@+lightyellow :: Colour Double+lightyellow = Names.lightyellow++-- | @#00FF00@, @rgb(0, 255, 0)@, @hsl(120, 100%, 50%)@+lime :: Colour Double+lime = Names.lime++-- | @#32CD32@, @rgb(50, 205, 50)@, @hsl(120, 61%, 50%)@+limegreen :: Colour Double+limegreen = Names.limegreen++-- | @#FAF0E6@, @rgb(250, 240, 230)@, @hsl(30, 67%, 94%)@+linen :: Colour Double+linen = Names.linen++-- | @#FF00FF@, @rgb(255, 0, 255)@, @hsl(300, 100%, 50%)@. Same as 'fuchsia'.+magenta :: Colour Double+magenta = Names.magenta++-- | @#800000@, @rgb(128, 0, 0)@, @hsl(0, 100%, 25%)@+maroon :: Colour Double+maroon = Names.maroon++-- | @#66CDAA@, @rgb(102, 205, 170)@, @hsl(160, 51%, 60%)@+mediumaquamarine :: Colour Double+mediumaquamarine = Names.mediumaquamarine++-- | @#0000CD@, @rgb(0, 0, 205)@, @hsl(240, 100%, 40%)@+mediumblue :: Colour Double+mediumblue = Names.mediumblue++-- | @#BA55D3@, @rgb(186, 85, 211)@, @hsl(288, 59%, 58%)@+mediumorchid :: Colour Double+mediumorchid = Names.mediumorchid++-- | @#9370DB@, @rgb(147, 112, 219)@, @hsl(260, 60%, 65%)@+mediumpurple :: Colour Double+mediumpurple = Names.mediumpurple++-- | @#3CB371@, @rgb(60, 179, 113)@, @hsl(147, 50%, 47%)@+mediumseagreen :: Colour Double+mediumseagreen = Names.mediumseagreen++-- | @#7B68EE@, @rgb(123, 104, 238)@, @hsl(249, 80%, 67%)@+mediumslateblue :: Colour Double+mediumslateblue = Names.mediumslateblue++-- | @#00FA9A@, @rgb(0, 250, 154)@, @hsl(157, 100%, 49%)@+mediumspringgreen :: Colour Double+mediumspringgreen = Names.mediumspringgreen++-- | @#48D1CC@, @rgb(72, 209, 204)@, @hsl(178, 60%, 55%)@+mediumturquoise :: Colour Double+mediumturquoise = Names.turquoise++-- | @#C71585@, @rgb(199, 21, 133)@, @hsl(322, 81%, 43%)@+mediumvioletred :: Colour Double+mediumvioletred = Names.mediumvioletred++-- | @#191970@, @rgb(25, 25, 112)@, @hsl(240, 64%, 27%)@+midnightblue :: Colour Double+midnightblue = Names.midnightblue++-- | @#F5FFFA@, @rgb(245, 255, 250)@, @hsl(150, 100%, 98%)@+mintcream :: Colour Double+mintcream = Names.mintcream++-- | @#FFE4E1@, @rgb(255, 228, 225)@, @hsl(6, 100%, 94%)@+mistyrose :: Colour Double+mistyrose = Names.mistyrose++-- | @#FFE4B5@, @rgb(255, 228, 181)@, @hsl(38, 100%, 85%)@+moccasin :: Colour Double+moccasin = Names.moccasin++-- | @#FFDEAD@, @rgb(255, 222, 173)@, @hsl(36, 100%, 84%)@+navajowhite :: Colour Double+navajowhite = Names.navajowhite++-- | @#000080@, @rgb(0, 0, 128)@, @hsl(240, 100%, 25%)@+navy :: Colour Double+navy = Names.navy++-- | @#FDF5E6@, @rgb(253, 245, 230)@, @hsl(39, 85%, 95%)@+oldlace :: Colour Double+oldlace = Names.oldlace++-- | @#808000@, @rgb(128, 128, 0)@, @hsl(60, 100%, 25%)@+olive :: Colour Double+olive = Names.olive++-- | @#6B8E23@, @rgb(107, 142, 35)@, @hsl(80, 60%, 35%)@+olivedrab :: Colour Double+olivedrab = Names.olivedrab++-- | @#FFA500@, @rgb(255, 165, 0)@, @hsl(39, 100%, 50%)@+orange :: Colour Double+orange = Names.orange++-- | @#FF4500@, @rgb(255, 69, 0)@, @hsl(16, 100%, 50%)@+orangered :: Colour Double+orangered = Names.orangered++-- | @#DA70D6@, @rgb(218, 112, 214)@, @hsl(302, 59%, 65%)@+orchid :: Colour Double+orchid = Names.orchid++-- | @#EEE8AA@, @rgb(238, 232, 170)@, @hsl(55, 67%, 80%)@+palegoldenrod :: Colour Double+palegoldenrod = Names.palegoldenrod++-- | @#98FB98@, @rgb(152, 251, 152)@, @hsl(120, 93%, 79%)@+palegreen :: Colour Double+palegreen = Names.palegreen++-- | @#AFEEEE@, @rgb(175, 238, 238)@, @hsl(180, 65%, 81%)@+paleturquoise :: Colour Double+paleturquoise = Names.paleturquoise++-- | @#DB7093@, @rgb(219, 112, 147)@, @hsl(340, 60%, 65%)@+palevioletred :: Colour Double+palevioletred = Names.palevioletred++-- | @#FFEFD5@, @rgb(255, 239, 213)@, @hsl(37, 100%, 92%)@+papayawhip :: Colour Double+papayawhip = Names.papayawhip++-- | @#FFDAB9@, @rgb(255, 218, 185)@, @hsl(28, 100%, 86%)@+peachpuff :: Colour Double+peachpuff = Names.peachpuff++-- | @#CD853F@, @rgb(205, 133, 63)@, @hsl(30, 59%, 53%)@+peru :: Colour Double+peru = Names.peru++-- | @#FFC0CB@, @rgb(255, 192, 203)@, @hsl(350, 100%, 88%)@+pink :: Colour Double+pink = Names.pink++-- | @#DDA0DD@, @rgb(221, 160, 221)@, @hsl(300, 47%, 75%)@+plum :: Colour Double+plum = Names.plum++-- | @#B0E0E6@, @rgb(176, 224, 230)@, @hsl(187, 52%, 80%)@+powderblue :: Colour Double+powderblue = Names.powderblue++-- | @#800080@, @rgb(128, 0, 128)@, @hsl(300, 100%, 25%)@+purple :: Colour Double+purple = Names.purple++-- | @#FF0000@, @rgb(255, 0, 0)@, @hsl(0, 100%, 50%)@+red :: Colour Double+red = Names.red++-- | @#BC8F8F@, @rgb(188, 143, 143)@, @hsl(0, 25%, 65%)@+rosybrown :: Colour Double+rosybrown = Names.rosybrown++-- | @#4169E1@, @rgb(65, 105, 225)@, @hsl(225, 73%, 57%)@+royalblue :: Colour Double+royalblue = Names.royalblue++-- | @#8B4513@, @rgb(139, 69, 19)@, @hsl(25, 76%, 31%)@+saddlebrown :: Colour Double+saddlebrown = Names.saddlebrown++-- | @#FA8072@, @rgb(250, 128, 114)@, @hsl(6, 93%, 71%)@+salmon :: Colour Double+salmon = Names.salmon++-- | @#F4A460@, @rgb(244, 164, 96)@, @hsl(28, 87%, 67%)@+sandybrown :: Colour Double+sandybrown = Names.sandybrown++-- | @#2E8B57@, @rgb(46, 139, 87)@, @hsl(146, 50%, 36%)@+seagreen :: Colour Double+seagreen = Names.seagreen++-- | @#FFF5EE@, @rgb(255, 245, 238)@, @hsl(25, 100%, 97%)@+seashell :: Colour Double+seashell = Names.seashell++-- | @#A0522D@, @rgb(160, 82, 45)@, @hsl(19, 56%, 40%)@+sienna :: Colour Double+sienna = Names.sienna++-- | @#C0C0C0@, @rgb(192, 192, 192)@, @hsl(0, 0%, 75%)@+silver :: Colour Double+silver = Names.silver++-- | @#87CEEB@, @rgb(135, 206, 235)@, @hsl(197, 71%, 73%)@+skyblue :: Colour Double+skyblue = Names.skyblue++-- | @#6A5ACD@, @rgb(106, 90, 205)@, @hsl(248, 53%, 58%)@+slateblue :: Colour Double+slateblue = Names.slateblue++-- | @#708090@, @rgb(112, 128, 144)@, @hsl(210, 13%, 50%)@. Same as 'slategrey'.+slategray :: Colour Double+slategray = Names.slategray++-- | @#708090@, @rgb(112, 128, 144)@, @hsl(210, 13%, 50%)@. Same as 'slategray'.+slategrey :: Colour Double+slategrey = Names.slategrey++-- | @#FFFAFA@, @rgb(255, 250, 250)@, @hsl(0, 100%, 99%)@+snow :: Colour Double+snow = Names.snow++-- | @#00FF7F@, @rgb(0, 255, 127)@, @hsl(150, 100%, 50%)@+springgreen :: Colour Double+springgreen = Names.springgreen++-- | @#4682B4@, @rgb(70, 130, 180)@, @hsl(207, 44%, 49%)@+steelblue :: Colour Double+steelblue = Names.steelblue++-- | @#D2B48C@, @rgb(210, 180, 140)@, @hsl(34, 44%, 69%)@+tan :: Colour Double+tan = Names.tan++-- | @#008080@, @rgb(0, 128, 128)@, @hsl(180, 100%, 25%)@+teal :: Colour Double+teal = Names.teal++-- | @#D8BFD8@, @rgb(216, 191, 216)@, @hsl(300, 24%, 80%)@+thistle :: Colour Double+thistle = Names.thistle++-- | @#FF6347@, @rgb(255, 99, 71)@, @hsl(9, 100%, 64%)@+tomato :: Colour Double+tomato = Names.tomato++-- | @#40E0D0@, @rgb(64, 224, 208)@, @hsl(174, 72%, 56%)@+turquoise :: Colour Double+turquoise = Names.turquoise++-- | @#EE82EE@, @rgb(238, 130, 238)@, @hsl(300, 76%, 72%)@+violet :: Colour Double+violet = Names.violet++-- | @#F5DEB3@, @rgb(245, 222, 179)@, @hsl(39, 77%, 83%)@+wheat :: Colour Double+wheat = Names.wheat++-- | @#FFFFFF@, @rgb(255, 255, 255)@, @hsl(0, 100%, 100%)@+white :: Colour Double+white = Names.white++-- | @#F5F5F5@, @rgb(245, 245, 245)@, @hsl(0, 0%, 96%)@+whitesmoke :: Colour Double+whitesmoke = Names.whitesmoke++-- | @#FFFF00@, @rgb(255, 255, 0)@, @hsl(60, 100%, 50%)@+yellow :: Colour Double+yellow = Names.yellow++-- | @#9ACD32@, @rgb(154, 205, 50)@, @hsl(80, 61%, 50%)@+yellowgreen :: Colour Double+yellowgreen = Names.yellowgreen++-- | @#663399@, @rgb(102, 51, 153)@, @hsl(270, 50%, 40%)@+rebeccapurple :: Colour Double+rebeccapurple = sRGB24 102 51 153++-- |+-- This 'AlphaColour' is entirely transparent and has no associated+-- color channel (i.e., @rgba(0, 0, 0, 0.0)@ or @hsla(0, 0%, 0%, 0.0)@).+transparent :: AlphaColour Double+transparent = Colour.transparent

@@ -1,9 +1,18 @@+{-# LANGUAGE OverloadedStrings #-} module Graphics.Blank.Utils where +import Data.ByteString.Base64  -- Not sure why to use this, vs this *.URL version. This one works, though.+import qualified Data.ByteString as B+import Data.Monoid+import Data.Text(Text)+import qualified Data.Text as Text+import Data.Text.Encoding (decodeUtf8, encodeUtf8)+ import Graphics.Blank.Canvas import Graphics.Blank.Generated import Graphics.Blank.JavaScript + -- | Clear the screen. Restores the default transformation matrix. clearCanvas :: Canvas () clearCanvas = do@@ -12,13 +21,13 @@   clearRect (0,0,width me,height me)  -- | Wrap a canvas computation in 'save' / 'restore'.-saveRestore :: Canvas () -> Canvas ()+saveRestore :: Canvas a -> Canvas a saveRestore m = do     save ()-    m+    r <- m     restore ()-    -    +    return r+ infixr 0 #  -- | The @#@-operator is the Haskell analog to the @.@-operator@@ -26,6 +35,78 @@ -- -- > grd # addColorStop(0, "#8ED6FF"); -----   This can be seen as equivalent of @document.addColorStop(0, "#8ED6FF")@.+--   This can be seen as equivalent of @grd.addColorStop(0, "#8ED6FF")@. (#) :: a -> (a -> Canvas b) -> Canvas b (#) obj act = act obj++-- | Read a file, and generate a data URL.+--+-- >  url <- readDataURL "image/png" "image/foo.png"+--+readDataURL :: Text -> FilePath -> IO Text+readDataURL mime_type filePath = do+	    dat <- B.readFile filePath+	    return $ "data:" <> mime_type <> ";base64," <> decodeUtf8 (encode dat)++-- | Find the mime type for a data URL.+--+-- > > dataURLMimeType "data:image/png;base64,iVBORw..."+-- > "image/png"+--+dataURLMimeType :: Text -> Text+dataURLMimeType txt+    | dat /= "data" = error "dataURLMimeType: no 'data:'"+    | not (Text.null rest0) && not (Text.null rest2) = mime_type+    | otherwise = error "dataURLMimeType: bad parse"+ where+   (dat,rest0)       = Text.span (/= ':') txt+   Just (_,rest1)    = Text.uncons rest0+   (mime_type,rest2) = Text.span (/= ';') rest1++-- | Write a data URL to a given file.++writeDataURL :: FilePath -> Text -> IO ()+writeDataURL fileName+             = B.writeFile fileName+             . decodeLenient+             . encodeUtf8+             . Text.tail+             . Text.dropWhile (/= ',')++-- | Draws an image onto the canvas at the given x- and y-coordinates.+drawImageAt :: Image image => (image, Double, Double) -> Canvas ()+drawImageAt (img, dx, dy) = Method $ DrawImage (img, [dx, dy])++-- | Acts like 'drawImageAt', but with two extra 'Double' arguments. The third and fourth+--   'Double's specify the width and height of the image, respectively.+drawImageSize :: Image image => (image, Double, Double, Double, Double) -> Canvas ()+drawImageSize (img, dx, dy, dw, dh) = Method $ DrawImage (img, [dx, dy, dw, dh])++-- | Acts like 'drawImageSize', but with four extra 'Double' arguments before the arguments+--   of 'drawImageSize'. The first and second 'Double's specify the x- and y-coordinates at+--   which the image begins to crop. The third and fourth 'Double's specify the width and+--   height of the cropped image.+-- +-- @+-- 'drawImageCrop' img 0 0 dw dh dx dy dw dh = 'drawImageSize' = dx dy dw dh+-- @+drawImageCrop :: Image image => (image, Double, Double, Double, Double, Double, Double, Double, Double) -> Canvas ()+drawImageCrop (img, sx, sy, sw, sh, dx, dy, dw, dh)+  = Method $ DrawImage (img, [sx, sy, sw, sh, dx, dy, dw, dh])++-- | Writes 'ImageData' to the canvas at the given x- and y-coordinates.+putImageDataAt :: (ImageData, Double, Double) -> Canvas ()+putImageDataAt (imgData, dx, dy) = Method $ PutImageData (imgData, [dx, dy])++-- | Acts like 'putImageDataDirty', but with four extra 'Double' arguments that specify+--   which region of the 'ImageData' (the dirty rectangle) should be drawn. The third+--   and fourth 'Double's specify the dirty rectangle's x- and y- coordinates, and the+--   fifth and sixth 'Double's specify the dirty rectangle's width and height.+--   +-- @+-- 'putImageDataDirty' imgData dx dy 0 0 w h = 'putImageDataAt' imgData dx dy+--   where (w, h) = case imgData of ImageData w' h' _ -> (w', h')+-- @+putImageDataDirty :: (ImageData, Double, Double, Double, Double, Double, Double) -> Canvas ()+putImageDataDirty (imgData, dx, dy, dirtyX, dirtyY, dirtyWidth, dirtyHeight)+  = Method $ PutImageData (imgData, [dx, dy, dirtyX, dirtyY, dirtyWidth, dirtyHeight])

@@ -1,5 +1,5 @@ Name:                blank-canvas-Version:             0.4.0+Version:             0.5 Synopsis:            HTML5 Canvas Graphics Library  Description:      blank-canvas is a Haskell binding to the complete@@ -11,7 +11,7 @@                   images.                   .                   @-                     &#123;-# LANGUAGE OverloadedStrings #-&#125;+		     &#123;-&#35; LANGUAGE OverloadedStrings &#35;-&#125;                      module Main where                      import Graphics.Blank                     -- import the blank canvas                      .@@ -30,7 +30,7 @@ 		  . License:             BSD3 License-file:        LICENSE-Author:              Andy Gill+Author:              Andy Gill and Ryan Scott Maintainer:          andygill@ku.edu Copyright:           Copyright (c) 2014 The University of Kansas Homepage:            https://github.com/ku-fpg/blank-canvas/wiki@@ -39,14 +39,16 @@ Build-type:          Simple Stability:           beta Extra-source-files:  README.md+            	     Changelog.md Cabal-version:       >= 1.10 data-files:     static/index.html     static/jquery.js     static/jquery-json.js + Library-  Exposed-modules:     Graphics.Blank, +  Exposed-modules:     Graphics.Blank,                        Graphics.Blank.GHCi,                        Graphics.Blank.Style   other-modules:       Graphics.Blank.Canvas,@@ -58,25 +60,27 @@                        Paths_blank_canvas    default-language:    Haskell2010-  build-depends:       base             >= 4.3.1        && < 4.8,-                       bytestring       == 0.10.*,-                       aeson            == 0.7.*,-                       containers       == 0.5.*,-                       kansas-comet     == 0.3.*,-                       scotty           == 0.8.*,-                       http-types       == 0.8.*,-                       text             >= 1.1          && < 1.2,-                       network          >= 2.4          && < 2.6,-                       transformers     >= 0.3          && < 0.5,-                       wai              == 3.*,-                       wai-extra        == 3.*,-                       warp             == 3.*,-                       stm              >= 2.2          && < 2.5,-                       vector           >= 0.10         && < 0.11+  build-depends:       aeson              >= 0.7   && < 0.9,+                       base64-bytestring  == 1.0.*,+                       base               >= 4.3.1 && < 4.8,+                       bytestring         == 0.10.*,+                       colour             >= 2.2   && < 3.0,+                       containers         == 0.5.*,+                       data-default-class == 0.0.*,+                       http-types         == 0.8.*,+                       kansas-comet       == 0.3.*,+                       scotty             >= 0.8   && < 0.10,+                       stm                >= 2.2   && < 2.5,+                       text               >= 1.1   && < 1.3,+                       transformers       >= 0.3   && < 0.5,+                       wai                == 3.*,+                       wai-extra          >= 3.0.1 && < 3.1,+                       warp               == 3.*,+                       vector             >= 0.10  && < 0.11    GHC-options:  -Wall -fno-warn-orphans -fno-warn-warnings-deprecations+  GHC-prof-options:  -Wall -fno-warn-orphans -fno-warn-warnings-deprecations -auto-all -fsimpl-tick-factor=100000  source-repository head   type:     git   location: git://github.com/ku-fpg/blank-canvas.git-

@@ -43,9 +43,9 @@             }             function ToDataURL(u,c) {                 $.kc.reply(u,c.canvas.toDataURL());-                            +             }-            function NewImage(src) { +            function NewImage(src) {                 return function (u,c) {                     var img = new Image();                     var count = images.push(img);@@ -54,52 +54,52 @@                     };                     img.onerror = function() { alert("Image " + src + " not found.\nAdd as a static file to fix this."); };                     img.src = src;-                }        +                }             } -            function CreateLinearGradient(x0,y0,x1,y1) { +            function CreateLinearGradient(x0,y0,x1,y1) {                 return function (u,c) {                     var count = gradients.push(c.createLinearGradient(x0,y0,x1,y1));                     $.kc.reply(u,count - 1);-                }        +                }             } -            function CreateRadialGradient(x0,y0,r0,x1,y1,r1) { +            function CreateRadialGradient(x0,y0,r0,x1,y1,r1) {                 return function (u,c) {                     var count = gradients.push(c.createRadialGradient(x0,y0,r0,x1,y1,r1));                     $.kc.reply(u,count - 1);-                }        +                }             } -            function CreatePattern(img,src) { +            function CreatePattern(img,src) {                 return function (u,c) {                     var count = patterns.push(c.createPattern(img,src));                     $.kc.reply(u,count - 1);-                }        +                }             } -            function MeasureText(txt) { +            function MeasureText(txt) {                 return function (u,c) {-                    $.kc.reply(u,c.measureText(txt));-                }        +                    $.kc.reply(u,{ width: c.measureText(txt).width });+                }             }-            function IsPointInPath(x,y) { +            function IsPointInPath(x,y) {                 return function (u,c) {                     $.kc.reply(u,c.isPointInPath(x,y));-                }        +                }             } -            function NewCanvas(w,h) { +            function NewCanvas(w,h) {                 return function (u,c) {                     var canvas = document.createElement('canvas');                     canvas.width = w;                     canvas.height = h;                     var count = canvasbuffers.push(canvas.getContext("2d"));-                    $.kc.reply(u,[count - 1,w,h]);              -                }        +                    $.kc.reply(u,[count - 1,w,h]);+                }             } -            function GetImageData(sx,sy,sw,sh) { +            function GetImageData(sx,sy,sw,sh) {                 return function (u,c) {                     var img = c.getImageData(sx,sy,sw,sh);                     var arr = [];@@ -110,25 +110,31 @@                                  , height: img.height                                  , data: arr                                  });-                }        +                }             } -            function Trigger(e) { -                $.kc.event({ eMetaKey: e.eMetaKey,-                             ePageXY : e.ePageXY,-                             eType   : e.eType,-                             eWhich  : e.eWhich-                            });+            function Sync(u,c) {+                $.kc.reply(u,[]);             }++            function Trigger(e) {+		var o = {};+		o.metaKey = e.metaKey;+                o.type    = e.type;+		if (e.pageXY != undefined) { +	            o.pageXY = e.pageXY; +  	        }+		if (e.pageX != undefined && e.pageY != undefined) {+		    o.pageXY = [e.pageX,e.pageY];+                }+                if (e.which != undefined) { +                    o.which = e.which; +                }+                $.kc.event(o);+            }             function register(name) {-                $(document).bind(name,function (e){-                        $.kc.event({ eMetaKey: e.metaKey,-                                     ePageXY : [e.pageX,e.pageY],-                                     eType   : e.type,-                                     eWhich  : e.which-                                    });-                });-            }  +                $(document).bind(name,Trigger);+            }             function redraw() {                 $.ajax({ url: "/canvas/" + session,                          type: "GET",@@ -136,10 +142,10 @@                          success: function success() {                                  redraw();                          }-                         }); +                         });              }-             -             function ImageData(w,h,dat) { ++             function ImageData(w,h,dat) {                 var imgData = canvasbuffers[0].createImageData(w,h);                 for(var i = 0;i < dat.length;i ++) {                    imgData.data[i] = dat[i];@@ -169,8 +175,8 @@                 $("#canvas").replaceWith(                             '<canvas id="canvas" width="' + (w * myDevicePixelRatio) + '" height="' + (h * myDevicePixelRatio) +                             '" style="border: black solid ' + b + 'px; padding: 0px; margin: 0px"></canvas>');-                $("#canvas").css("width",w + "px");            -                $("#canvas").css("height",h + "px");            +                $("#canvas").css("width",w + "px");+                $("#canvas").css("height",h + "px");                 c = getContext("2d");                 canvasbuffers.push(c);                 $.kc.connect("/blank");