blank-canvas 0.5 → 0.6

raw patch · 76 files changed

+5012/−766 lines, 76 filesdep +base-compatdep +blank-canvasdep +directorydep ~aesondep ~basedep ~colourPVP ok

version bump matches the API change (PVP)

Dependencies added: base-compat, blank-canvas, directory, mime-types, process, shake, text-show, time, unix

Dependency ranges changed: aeson, base, colour, data-default-class, http-types, kansas-comet, scotty, transformers, vector

API changes (from Hackage documentation)

Files

• Changelog.md +19/−0
• Graphics/Blank.hs +230/−100
• Graphics/Blank/Canvas.hs +219/−82
• Graphics/Blank/Cursor.hs +63/−0
• Graphics/Blank/DeviceContext.hs +21/−16
• Graphics/Blank/Events.hs +20/−18
• Graphics/Blank/Font.hs +86/−0
• Graphics/Blank/GHCi.hs +14/−3
• Graphics/Blank/Generated.hs +387/−50
• Graphics/Blank/JavaScript.hs +387/−224
• Graphics/Blank/Parser.hs +82/−0
• Graphics/Blank/Style.hs +202/−192
• Graphics/Blank/Types.hs +19/−0
• Graphics/Blank/Types/CSS.hs +155/−0
• Graphics/Blank/Types/Cursor.hs +337/−0
• Graphics/Blank/Types/Font.hs +679/−0
• Graphics/Blank/Utils.hs +9/−12
• LICENSE +1/−1
• README.md +1/−1
• blank-canvas.cabal +120/−35
• static/index.html +40/−32
• wiki-suite/Arc.hs +29/−0
• wiki-suite/Bezier_Curve.hs +20/−0
• wiki-suite/Bounce.hs +67/−0
• wiki-suite/Circle.hs +24/−0
• wiki-suite/Clipping_Region.hs +55/−0
• wiki-suite/Color_Fill.hs +28/−0
• wiki-suite/Color_Square.hs +22/−0
• wiki-suite/Custom_Shape.hs +26/−0
• wiki-suite/Custom_Transform.hs +28/−0
• wiki-suite/Draw_Canvas.hs +20/−0
• wiki-suite/Draw_Device.hs +19/−0
• wiki-suite/Draw_Image.hs +16/−0
• wiki-suite/Favicon.hs +37/−0
• wiki-suite/Font_Size_and_Style.hs +15/−0
• wiki-suite/Get_Image_Data_URL.hs +31/−0
• wiki-suite/Global_Alpha.hs +25/−0
• wiki-suite/Global_Composite_Operations.hs +70/−0
• wiki-suite/Grayscale.hs +33/−0
• wiki-suite/Image_Crop.hs +16/−0
• wiki-suite/Image_Loader.hs +18/−0
• wiki-suite/Image_Size.hs +16/−0
• wiki-suite/Is_Point_In_Path.hs +29/−0
• wiki-suite/Key_Read.hs +52/−0
• wiki-suite/Line.hs +17/−0
• wiki-suite/Line_Cap.hs +23/−0
• wiki-suite/Line_Color.hs +18/−0
• wiki-suite/Line_Join.hs +39/−0
• wiki-suite/Line_Width.hs +17/−0
• wiki-suite/Linear_Gradient.hs +22/−0
• wiki-suite/Load_Image_Data_URL.hs +17/−0
• wiki-suite/Load_Image_Data_URL_2.hs +15/−0
• wiki-suite/Main.hs +298/−0
• wiki-suite/Miter_Limit.hs +32/−0
• wiki-suite/Path.hs +27/−0
• wiki-suite/Pattern.hs +19/−0
• wiki-suite/Quadratic_Curve.hs +20/−0
• wiki-suite/Radial_Gradient.hs +22/−0
• wiki-suite/Rectangle.hs +20/−0
• wiki-suite/Red_Line.hs +17/−0
• wiki-suite/Rotate_Transform.hs +20/−0
• wiki-suite/Rotating_Square.hs +36/−0
• wiki-suite/Rounded_Corners.hs +29/−0
• wiki-suite/Scale_Transform.hs +20/−0
• wiki-suite/Semicircle.hs +21/−0
• wiki-suite/Shadow.hs +20/−0
• wiki-suite/Square.hs +49/−0
• wiki-suite/Text_Align.hs +19/−0
• wiki-suite/Text_Baseline.hs +20/−0
• wiki-suite/Text_Color.hs +16/−0
• wiki-suite/Text_Metrics.hs +28/−0
• wiki-suite/Text_Stroke.hs +17/−0
• wiki-suite/Text_Wrap.hs +34/−0
• wiki-suite/Tic_Tac_Toe.hs +132/−0
• wiki-suite/Translate_Transform.hs +18/−0
• wiki-suite/Wiki.hs +123/−0

@@ -1,3 +1,22 @@+### 0.6+API changes+ * The `(#)` function had its type generalized from `a -> (a -> Canvas b) -> Canvas b` to `a -> (a -> b) -> b`. This allows it to be used with font length units.+ * Added more type synonyms (`Interval`, `Degrees`, `Radians`, etc.) to more clearly indicate what functions expect constrained values.+ * `showbJS` (formerly `showJS`) and `jsStyle` now return a text `Builder` instead of a `String`. This change was introduced as part of a larger `blank-canvas` refactoring to increase performance. See the `Data.Text.Lazy.Builder` module from the `text` package for more details on how to use `Builder`s.++API additions+ * A new ADT for `Font`s has been added in `Graphics.Blank.Font` that can be used in place of `Text`. For example, `"30pt Calibri"` is equivalent to `(defFont "Calibri") { fontSize = 30 # pt }`.+ * A generalized `font` function of type `CanvasFont canvasFont => canvasFont -> Canvas ()` was added to `Graphics.Blank.Font` that can accept a `Text` or `Font` argument. The `font` function in `Graphics.Blank` remains of type `Text -> Canvas ()`.+ * Added a `cursor` function to change the browser cursor. Also added the `Graphics.Blank.Cursor` module containing a generalized `cursor` function that uses a `Cursor` ADT instead of `Text`.+ * Added `Bounded`, `Enum`, `Eq`, `Ix`, `Ord`, and `Show` instances for more data types+ * Added support for more MIME types via the `mime-types` library`++Additions+ * Allowed building with `base-4.8.0.0`++Other+ * Require `scotty` >= 0.10 and `kansas-comet` >= 0.4+ ## 0.5  API changes

@@ -1,23 +1,35 @@-{-# LANGUAGE OverloadedStrings, TemplateHaskell, GADTs, KindSignatures, CPP, BangPatterns, ScopedTypeVariables #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-} --- | blank-canvas is a Haskell binding to the complete HTML5 Canvas---   API. blank-canvas allows Haskell users to write, in Haskell,---   interactive images onto their web browsers. blank-canvas gives---   the users a single full-window canvas, and provides many---   well-documented functions for rendering images.+{-|+Module:      Graphics.Blank+Copyright:   (C) 2014-2015, The University of Kansas+License:     BSD-style (see the file LICENSE)+Maintainer:  Andy Gill+Stability:   Beta+Portability: GHC +@blank-canvas@ is a Haskell binding to the complete+<https://developer.mozilla.org/en-US/docs/Web/API/Canvas_API HTML5 Canvas API>.+@blank-canvas@ allows Haskell users to write, in Haskell,+interactive images onto their web browsers. @blank-canvas@ gives+the users a single full-window canvas, and provides many+well-documented functions for rendering images.+-} module Graphics.Blank         (-         -- * Starting blank-canvas+         -- * Starting @blank-canvas@           blankCanvas         , Options(..)           -- ** 'send'ing to the Graphics 'DeviceContext'         , DeviceContext       -- abstact         , send           -- * HTML5 Canvas API-          -- | See <http://www.nihilogic.dk/labs/canvas_sheet/HTML5_Canvas_Cheat_Sheet.pdf> for the JavaScript+          -- | See <https://developer.mozilla.org/en-US/docs/Web/API/Canvas_API> for the JavaScript           --   version of this API.-        , Canvas        -- abstact+        , Canvas        -- abstract           -- ** Canvas element         , height         , width@@ -43,7 +55,11 @@         , lineJoin         , miterLimit         , LineEndCap(..)+        , butt+        , square         , LineJoinCorner(..)+        , bevel+        , miter           -- ** Colors, styles and shadows         , strokeStyle         , fillStyle@@ -56,6 +72,10 @@         , createPattern         , addColorStop         , RepeatDirection(..)+        , repeat_+        , repeatX+        , repeatY+        , noRepeat         , CanvasGradient         , CanvasPattern           -- ** Paths@@ -80,7 +100,18 @@         , strokeText         , measureText         , TextAnchorAlignment(..)+        , start+        , end+        , center+        , left+        , right         , TextBaselineAlignment(..)+        , top+        , hanging+        , middle+        , alphabetic+        , ideographic+        , bottom         , TextMetrics(..)           -- ** Rectangles         , clearRect@@ -90,10 +121,19 @@         , getImageData         , putImageData         , ImageData(..)-        -- * blank-canvas Extensions+          -- * Type information+        , Alpha+        , Degrees+        , Interval+        , Percentage+        , Radians+        , RoundProperty(..)+        -- * @blank-canvas@ Extensions         -- ** Reading from 'Canvas'         , newImage         , CanvasImage -- abstract+        , newAudio+        , CanvasAudio          -- ** 'DeviceContext' attributes         , devicePixelRatio          -- ** 'CanvasContext', and off-screen Canvas.@@ -118,6 +158,8 @@         , Event(..)         , EventName         , EventQueue+        -- ** Cursor manipulation+        , cursor         -- ** Middleware         , local_only         ) where@@ -125,30 +167,33 @@ import           Control.Concurrent import           Control.Concurrent.STM import           Control.Exception-import           Control.Monad+import           Control.Monad (forever) import           Control.Monad.IO.Class  import           Data.Aeson import           Data.Aeson.Types (parse) import           Data.List as L+import qualified Data.Map as M (lookup) import           Data.Monoid ((<>)) import qualified Data.Set as S-import           Data.String import qualified Data.Text as T import           Data.Text (Text)+import           Data.Text.Encoding (decodeUtf8) import qualified Data.Text.Lazy as LT  import qualified Graphics.Blank.Canvas as Canvas-import           Graphics.Blank.Canvas hiding (addColorStop)+import           Graphics.Blank.Canvas hiding (addColorStop, cursor) import           Graphics.Blank.DeviceContext import           Graphics.Blank.Events import qualified Graphics.Blank.Generated as Generated-import           Graphics.Blank.Generated hiding (fillStyle, strokeStyle, shadowColor)+import           Graphics.Blank.Generated hiding (fillStyle, font, strokeStyle, shadowColor) import qualified Graphics.Blank.JavaScript as JavaScript import           Graphics.Blank.JavaScript hiding (width, height)+import           Graphics.Blank.Types import           Graphics.Blank.Utils  import qualified Network.HTTP.Types as H+import           Network.Mime (defaultMimeMap, fileNameExtensions) import           Network.Wai (Middleware, responseLBS) import           Network.Wai.Middleware.Local import           Network.Wai.Handler.Warp@@ -157,14 +202,18 @@  import           Paths_blank_canvas +import           Prelude.Compat+ import           System.IO.Unsafe (unsafePerformIO) -- import           System.Mem.StableName +import           TextShow (Builder, showb, showt, singleton)+ 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.+-- | 'blankCanvas' is the main entry point into @blank-canvas@. -- A typical invocation would be -- -- >{-# LANGUAGE OverloadedStrings #-}@@ -181,61 +230,61 @@ -- >                stroke() -- > - blankCanvas :: Options -> (DeviceContext -> IO ()) -> IO () blankCanvas opts actions = do    dataDir <- getDataDir     kComet <- KC.kCometPlugin -    locals :: TVar (S.Set Text) <- atomically $ newTVar S.empty  --   print dataDir +   -- use the comet+   let kc_opts :: KC.Options+       kc_opts = KC.Options { KC.prefix = "/blank", KC.verbose = if debug opts then 3 else 0 }++   connectApp <- KC.connect kc_opts $ \ kc_doc -> do+       -- register the events we want to watch for+       KC.send kc_doc $ T.unlines+          [ "register(" <> showt nm <> ");"+          | nm <- events opts+          ]+       +       queue <- atomically newTChan+       _ <- forkIO $ forever $ do+               val <- atomically $ readTChan $ KC.eventQueue $ kc_doc+               case fromJSON val of+                  Success (event :: Event) -> do+                          atomically $ writeTChan queue event+                  _ -> return ()+       +       +       let cxt0 = DeviceContext kc_doc queue 300 300 1 locals False+       +       -- A bit of bootstrapping+       DeviceAttributes w h dpr <- send cxt0 device+       -- print (DeviceAttributes w h dpr)+       +       let cxt1 = cxt0+                { ctx_width = w+                , ctx_height = h+                , ctx_devicePixelRatio = dpr+                , weakRemoteMonad = weak opts+                }+       +       (actions $ cxt1) `catch` \ (e :: SomeException) -> do+               print ("Exception in blank-canvas application:" :: String)+               print e+               throw e+    app <- scottyApp $ do --        middleware logStdoutDev         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-                   [ "register(" <> T.pack(show nm) <> ");"-                   | nm <- events opts-                   ]--                queue <- atomically newTChan-                _ <- forkIO $ forever $ do-                        val <- atomically $ readTChan $ KC.eventQueue $ kc_doc-                        case fromJSON val of-                           Success (event :: Event) -> do-                                   atomically $ writeTChan queue event-                           _ -> return ()---                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-                         { ctx_width = w-                         , ctx_height = h-                         , ctx_devicePixelRatio = dpr-                         }--                (actions $ cxt1) `catch` \ (e :: SomeException) -> do-                        print ("Exception in blank-canvas application:"  :: String)-                        print e-                        throw e+        connectApp          get "/"                 $ file $ dataDir ++ "/static/index.html"         get "/jquery.js"        $ file $ dataDir ++ "/static/jquery.js"@@ -248,7 +297,7 @@           db <- liftIO $ atomically $ readTVar $ locals           if fileName `S.member` db           then do-            mime <- mimeTypes (T.unpack fileName)+            let mime = mimeType fileName             Scotty.setHeader "Content-Type" $ LT.fromStrict $ mime             file $ (root opts ++ "/" ++ T.unpack fileName)           else do@@ -256,53 +305,74 @@          return () --    runSettings (setPort (port opts)                $ setTimeout 5                $ defaultSettings                ) app --- | Sends a set of Canvas commands to the canvas. Attempts+-- | 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 _   (Return a) = return a+send cxt (Bind m k)          | weakRemoteMonad cxt = send cxt m >>= send cxt . k+send cxt (With c (Bind m k)) | weakRemoteMonad cxt = send cxt (With c m) >>= send cxt . With c . k+send cxt (With _ (With c m)) | weakRemoteMonad cxt = send cxt (With c m)+send cxt commands = send' (deviceCanvasContext cxt) commands mempty   where-      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+      sendBind :: CanvasContext -> Canvas a -> (a -> Canvas b) -> Builder -> 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 <> jsCanvasContext c <> singleton '.' <> showb cmd <> singleton ';')+      sendBind c (Command cmd)   k cmds = send' c (k ()) (cmds <> showb cmd <> singleton ';')+      sendBind c (Function func) k cmds = sendFunc c func k cmds+      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 -      sendQuery :: CanvasContext -> Query a -> (a -> Canvas b) -> (String -> String) -> IO b+      sendFunc :: CanvasContext -> Function a -> (a -> Canvas b) -> Builder -> IO b+      sendFunc c q@(CreateLinearGradient _) k cmds = sendGradient c q k cmds+      sendFunc c q@(CreateRadialGradient _) k cmds = sendGradient c q k cmds+      sendFunc c q@(CreatePattern        _) k cmds = sendPattern  c q k cmds++      sendGradient :: CanvasContext -> Function a -> (CanvasGradient -> Canvas b) -> Builder -> IO b+      sendGradient c q k cmds = do+        gId <- atomically getUniq+        send' c (k $ CanvasGradient gId) $ cmds <> "var gradient_"+            <> showb gId     <> " = "   <> jsCanvasContext c+            <> singleton '.' <> showb q <> singleton ';'++      sendPattern :: CanvasContext -> Function a -> (CanvasPattern -> Canvas b) -> Builder -> IO b+      sendPattern c q k cmds = do+        pId <- atomically getUniq+        send' c (k $ CanvasPattern pId) $ cmds <> "var pattern_"+            <> showb pId     <> " = "   <> jsCanvasContext c+            <> singleton '.' <> showb q <> singleton ';'++      fileQuery :: Text -> IO ()+      fileQuery 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++      sendQuery :: CanvasContext -> Query a -> (a -> Canvas b) -> Builder -> 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+            NewImage url -> fileQuery url+            NewAudio url -> fileQuery url             _ -> 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 ++ ");") ++))+          sendToCanvas cxt $ cmds <> showb query <> singleton '(' <> showb uq <> singleton ',' <> jsCanvasContext 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--+            Success a -> send' c (k a) mempty -      send' :: CanvasContext -> Canvas a -> (String -> String) -> IO a--- Most of these can be factored out, except return+      send' :: CanvasContext -> Canvas a -> Builder -> 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@@ -310,7 +380,6 @@               return a       send' c cmd                   cmds = sendBind c cmd Return cmds - local_only :: Middleware local_only = local $ responseLBS H.status403 [("Content-Type", "text/plain")] "local access only" @@ -325,24 +394,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+mimeType :: Text -> Text+mimeType filePath = go $ fileNameExtensions filePath+  where+    go [] = error $ "do not understand mime type for : " ++ show filePath+    go (e:es) = case M.lookup e defaultMimeMap of+                     Nothing -> go es+                     Just mt -> decodeUtf8 mt  ------------------------------------------------- --- TODO: add extra mime types--+-- | Additional @blank-canvas@ settings. The defaults can be used by creating+-- 'Options' as a 'Num'. For example, @'blankCanvas' 3000@ uses the default 'Options'+-- on port 3000. 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)-        , root   :: String           -- ^ location of the static files (default .)-        , middleware :: [Middleware] -- ^ extra middleware(s) to be executed. (default [local_only])+        { port   :: Int              -- ^ On which port do we issue @blank-canvas@?+        , events :: [EventName]      -- ^ To which events does the canvas listen? Default: @[]@+        , debug  :: Bool             -- ^ Turn on debugging. Default: @False@+        , root   :: String           -- ^ Location of the static files. Default: @\".\"@+        , middleware :: [Middleware] -- ^ Extra middleware(s) to be executed. Default: @['local_only']@+        , weak       :: Bool         -- ^ use a weak monad, which may help debugging (default False)         }  instance Num Options where@@ -356,26 +427,85 @@                             , debug = False                             , root = "."                             , middleware = [local_only]+                            , weak = False                             } - ---------------------------------------------------- This is the monomorphic version, to stop "ambiguous" errors.+-- These are monomorphic versions of functions defined to curb type ambiguity errors. +-- | Sets the color used to fill a drawing (@\"black\"@ by default).+--+-- ==== __Examples__+--+-- @+-- 'fillStyle' \"red\"+-- 'fillStyle' \"#00FF00\"+-- @ fillStyle :: Text -> Canvas () fillStyle = Generated.fillStyle +-- | Sets the text context's font properties.+--+-- ==== __Examples__+--+-- @+-- 'font' \"40pt \'Gill Sans Extrabold\'\"+-- 'font' \"80% sans-serif\"+-- 'font' \"bold italic large serif\"+-- @+font :: Text -> Canvas ()+font = Generated.font++-- | Sets the color used for strokes (@\"black\"@ by default).+--+-- ==== __Examples__+--+-- @+-- 'strokeStyle' \"red\"+-- 'strokeStyle' \"#00FF00\"+-- @ strokeStyle :: Text -> Canvas () strokeStyle = Generated.strokeStyle +-- | Sets the color used for shadows.+--+-- ==== __Examples__+--+-- @+-- 'shadowColor' \"red\"+-- 'shadowColor' \"#00FF00\"+-- @ shadowColor :: Text -> Canvas () shadowColor = Generated.shadowColor -addColorStop :: (Double, Text) -> CanvasGradient -> Canvas ()+-- | Adds a color and stop position in a 'CanvasGradient'. A stop position is a+-- number between 0.0 and 1.0 that represents the position between start and stop+-- in a gradient.+--+-- ==== __Example__+--+-- @+-- grd <- 'createLinearGradient'(0, 0, 10, 10)+-- grd # 'addColorStop'(0, \"red\")+-- @+addColorStop :: (Interval, Text) -> CanvasGradient -> Canvas () addColorStop = Canvas.addColorStop +-- | Change the canvas cursor to the specified URL or keyword.+--+-- ==== __Examples__+--+-- @+-- cursor \"url(image.png), default\"+-- cursor \"crosshair\"+-- @+cursor :: Text -> Canvas ()+cursor = Canvas.cursor++-- | The height of an 'Image' in pixels. height :: (Image image, Num a) => image -> a height = JavaScript.height +-- | The width of an 'Image' in pixels. width :: (Image image, Num a) => image -> a width = JavaScript.width

@@ -1,27 +1,47 @@-{-# LANGUAGE TemplateHaskell, GADTs, KindSignatures, ScopedTypeVariables, OverloadedStrings, FlexibleInstances, OverlappingInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}  module Graphics.Blank.Canvas where -import           Control.Applicative import           Control.Monad (ap, liftM2) -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.Lazy.Builder+import           Data.Text.Lazy.Encoding (decodeUtf8) +import           Graphics.Blank.Events+import           Graphics.Blank.JavaScript+import           Graphics.Blank.Types+import           Graphics.Blank.Types.Cursor+import           Graphics.Blank.Types.Font +import           Prelude.Compat++import           TextShow+import           TextShow.TH (deriveTextShow)++data DeviceAttributes = DeviceAttributes Int Int Double deriving Show+$(deriveTextShow ''DeviceAttributes)++-- | The 'width' argument of 'TextMetrics' can trivially be projected out.+data TextMetrics = TextMetrics Double deriving Show+$(deriveTextShow ''TextMetrics)++-----------------------------------------------------------------------------+ data Canvas :: * -> * where         Method    :: Method                      -> Canvas ()     -- <context>.<method>         Command   :: Command                     -> Canvas ()     -- <command>-        Query     :: (Show a) => Query a         -> Canvas a+        Function  :: TextShow a => Function a    -> Canvas a+        Query     :: TextShow a => Query a       -> Canvas a         With      :: CanvasContext -> Canvas a   -> Canvas a         MyContext ::                                Canvas CanvasContext         Bind      :: Canvas a -> (a -> Canvas b) -> Canvas b@@ -42,11 +62,10 @@   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 (Double, Double, Double, Double, Double, Bool)+        = Arc (Double, Double, Double, Radians, Radians, Bool)         | ArcTo (Double, Double, Double, Double, Double)         | BeginPath         | BezierCurveTo (Double, Double, Double, Double, Double, Double)@@ -58,8 +77,8 @@         | FillRect (Double, Double, Double, Double)         | forall style . Style style => FillStyle style         | FillText (Text, Double, Double)-        | Font Text-        | GlobalAlpha Double+        | forall canvasFont . CanvasFont canvasFont => Font canvasFont+        | GlobalAlpha Alpha         | GlobalCompositeOperation Text         | LineCap LineEndCap         | LineJoin LineJoinCorner@@ -71,9 +90,9 @@         | QuadraticCurveTo (Double, Double, Double, Double)         | Rect (Double, Double, Double, Double)         | Restore-        | Rotate Double+        | Rotate Radians         | Save-        | Scale (Double, Double)+        | Scale (Interval, Interval)         | SetTransform (Double, Double, Double, Double, Double, Double)         | ShadowBlur Double         | forall canvasColor . CanvasColor canvasColor => ShadowColor canvasColor@@ -90,17 +109,21 @@  data Command   = Trigger Event-  | forall color . CanvasColor color => AddColorStop (Double, color) CanvasGradient+  | forall color . CanvasColor color => AddColorStop (Interval, 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 ++ "," ++ jsStyle rep ++ ")"-  show (Log msg) = "console.log(" ++ showJS msg ++ ")"-  show (Eval cmd) = Text.unpack cmd -- no escaping or interpretation+  showsPrec p = showsPrec p . FromTextShow +instance TextShow Command where+  showb (Trigger e) = "Trigger(" <> (fromLazyText . decodeUtf8 $ encode e) <> singleton ')'+  showb (AddColorStop (off,rep) g) = jsCanvasGradient g <> ".addColorStop("+         <> jsDouble off <> singleton ',' <> jsCanvasColor rep+         <> singleton ')'+  showb (Log msg) = "console.log(" <> showbJS msg <> singleton ')'+  showb (Eval cmd) = fromText cmd -- no escaping or interpretation+ -----------------------------------------------------------------------------  -- | 'with' runs a set of canvas commands in the context@@ -108,21 +131,30 @@ with :: CanvasContext -> Canvas a -> Canvas a with = With --- | 'myCanvasContext' returns the current 'CanvasContent'.+-- | 'myCanvasContext' returns the current 'CanvasContext'. myCanvasContext :: Canvas CanvasContext myCanvasContext = MyContext  ----------------------------------------------------------------------------- --- | trigger a specific named event, please.+-- | Triggers a specific named event. trigger :: Event -> Canvas () trigger = Command . Trigger --- | add a Color stop to a Canvas Gradient.-addColorStop :: CanvasColor color => (Double, color) -> CanvasGradient -> Canvas ()+-- | Adds a color and stop position in a 'CanvasGradient'. A stop position is a+-- number between 0.0 and 1.0 that represents the position between start and stop+-- in a gradient.+--+-- ==== __Example__+--+-- @+-- grd <- 'createLinearGradient'(0, 0, 10, 10)+-- grd # 'addColorStop'(0, 'red')+-- @+addColorStop :: CanvasColor color => (Interval, color) -> CanvasGradient -> Canvas () addColorStop (off,rep) = Command . AddColorStop (off,rep) --- | 'console_log' aids debugging by sending the argument to the browser console.log.+-- | 'console_log' aids debugging by sending the argument to the browser @console.log@. console_log :: JSArg msg => msg -> Canvas () console_log = Command . Log @@ -131,100 +163,205 @@ eval = Command . Eval  ------------------------------------------------------------------------------data Query :: * -> * where-        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 Double-        deriving Show+data Function :: * -> * where+  CreateLinearGradient :: (Double,Double,Double,Double)               -> Function CanvasGradient+  CreateRadialGradient :: (Double,Double,Double,Double,Double,Double) -> Function CanvasGradient+  CreatePattern        :: Image image => (image, RepeatDirection)     -> Function CanvasPattern --- | The 'width' argument of 'TextMetrics' can trivially be projected out.-data TextMetrics = TextMetrics Double-        deriving Show +instance Show (Function a) where+  showsPrec p = showsPrec p . FromTextShow++instance TextShow (Function a) where+  showb (CreateLinearGradient (x0,y0,x1,y1)) = "createLinearGradient("+        <> jsDouble x0 <> singleton ',' <> jsDouble y0 <> singleton ','+        <> jsDouble x1 <> singleton ',' <> jsDouble y1 <> singleton ')'+  showb (CreateRadialGradient (x0,y0,r0,x1,y1,r1)) = "createRadialGradient("+        <> jsDouble x0 <> singleton ',' <> jsDouble y0 <> singleton ',' <> jsDouble r0 <> singleton ','+        <> jsDouble x1 <> singleton ',' <> jsDouble y1 <> singleton ',' <> jsDouble r1 <> singleton ')'+  showb (CreatePattern (img,dir)) = "createPattern("+        <> jsImage img <> singleton ',' <> jsRepeatDirection dir <> singleton ')'++-----------------------------------------------------------------------------++data Query :: * -> * where+        Device               ::                                            Query DeviceAttributes+        ToDataURL            ::                                            Query Text+        MeasureText          :: Text                                    -> Query TextMetrics+        IsPointInPath        :: (Double, Double)                        -> Query Bool+        NewImage             :: Text                                    -> Query CanvasImage+        NewAudio             :: Text                                    -> Query CanvasAudio+        NewCanvas            :: (Int, Int)                              -> Query CanvasContext+        GetImageData         :: (Double, Double, Double, Double)        -> Query ImageData+        Cursor               :: CanvasCursor cursor => cursor           -> Query ()+        Sync                 ::                                            Query ()+ instance Show (Query a) where-  show Device                   = "Device"-  show ToDataURL                = "ToDataURL"-  show (MeasureText txt)        = "MeasureText(" ++ showJS txt ++ ")"-  show (IsPointInPath (x,y))    = "IsPointInPath(" ++ showJS x ++ "," ++ showJS y ++ ")"-  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,dir)) = "CreatePattern(" ++ jsImage img ++ "," ++ jsRepeatDirection dir ++ ")"-  show (NewCanvas (x,y))         = "NewCanvas(" ++ showJS x ++ "," ++ showJS y ++ ")"-  show (GetImageData (sx,sy,sw,sh))-                                 = "GetImageData(" ++ showJS sx ++ "," ++ showJS sy ++ "," ++ showJS sw ++ "," ++ showJS sh ++ ")"-  show Sync                      = "Sync"+  showsPrec p = showsPrec p . FromTextShow +instance TextShow (Query a) where+  showb Device                       = "Device"+  showb ToDataURL                    = "ToDataURL"+  showb (MeasureText txt)            = "MeasureText(" <> jsText txt <> singleton ')'+  showb (IsPointInPath (x,y))        = "IsPointInPath(" <> jsDouble x <> singleton ','+                                                        <> jsDouble y <> singleton ')'+  showb (NewImage url')              = "NewImage(" <> jsText url' <> singleton ')'+  showb (NewAudio txt)               = "NewAudio(" <> jsText txt  <> singleton ')'++  showb (NewCanvas (x,y))            = "NewCanvas(" <> jsInt x <> singleton ','+                                                    <> jsInt y <> singleton ')'+  showb (GetImageData (sx,sy,sw,sh)) = "GetImageData(" <> jsDouble sx <> singleton ','+                                                       <> jsDouble sy <> singleton ','+                                                       <> jsDouble sw <> singleton ','+                                                       <> jsDouble sh <> singleton ')'+  showb (Cursor cur)                 = "Cursor(" <> jsCanvasCursor cur <> singleton ')'+  showb Sync                         = "Sync"+ -- This is how we take our value to bits parseQueryResult :: Query a -> Value -> Parser a-parseQueryResult (Device {}) o    = uncurry3 DeviceAttributes <$> parseJSON o-parseQueryResult (ToDataURL {}) o = parseJSON o-parseQueryResult (MeasureText {}) (Object v) = TextMetrics <$> v .: "width"-parseQueryResult (IsPointInPath {}) o        = parseJSON o-parseQueryResult (NewImage {}) o             = uncurry3 CanvasImage <$> parseJSON o-parseQueryResult (CreateLinearGradient {}) o = CanvasGradient <$> parseJSON o-parseQueryResult (CreateRadialGradient {}) o = CanvasGradient <$> parseJSON o-parseQueryResult (CreatePattern {}) o = CanvasPattern <$> parseJSON o-parseQueryResult (NewCanvas {}) o = uncurry3 CanvasContext <$> parseJSON o+parseQueryResult (Device {}) o                = uncurry3 DeviceAttributes <$> parseJSON o+parseQueryResult (ToDataURL {}) o             = parseJSON o+parseQueryResult (MeasureText {}) (Object v)  = TextMetrics <$> v .: "width"+parseQueryResult (IsPointInPath {}) o         = parseJSON o+parseQueryResult (NewImage {}) o              = uncurry3 CanvasImage <$> parseJSON o+parseQueryResult (NewAudio {}) o              = uncurry CanvasAudio <$> parseJSON o+parseQueryResult (NewCanvas {}) o             = uncurry3 CanvasContext <$> parseJSON o 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)"+                                           <$> (o .: "width")+                                           <*> (o .: "height")+                                           <*> (o .: "data")+parseQueryResult (Cursor {}) _                = return ()+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 :: (a -> b -> c -> d) -> (a, b, c) -> d 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.+-- | Turn the canvas into a PNG data stream / data URL. -- -- > "data:image/png;base64,iVBORw0KGgo.." -- toDataURL :: () -> Canvas Text toDataURL () = Query ToDataURL +-- | Queries the measured width of the text argument.+--+-- ==== __Example__+--+-- @+-- 'TextMetrics' w <- 'measureText' \"Hello, World!\"+-- @ measureText :: Text -> Canvas TextMetrics measureText = Query . MeasureText +-- | @'isPointInPath'(x, y)@ queries whether point @(x, y)@ is within the current path.+--+-- ==== __Example__+--+-- @+-- 'rect'(10, 10, 100, 100)+-- 'stroke'()+-- b <- 'isPointInPath'(10, 10) -- b == True+-- @ isPointInPath :: (Double, Double) -> Canvas Bool isPointInPath = Query . IsPointInPath --- | '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' takes a URL (perhaps a data URL), and returns the 'CanvasImage' handle+-- /after/ loading.+-- If you are using local images, loading should be near instant. newImage :: Text -> Canvas CanvasImage newImage = Query . NewImage +-- | 'newAudio' takes an URL to an audio file and returs the 'CanvasAudio' handle+-- /after/ loading.+-- If you are using local audio files, loading should be near instant.+newAudio :: Text -> Canvas CanvasAudio+newAudio = Query . NewAudio++-- | @'createLinearGradient'(x0, y0, x1, y1)@ creates a linear gradient along a line,+-- which can be used to fill other shapes.+--+-- * @x0@ is the starting x-coordinate of the gradient+--+-- * @y0@ is the starting y-coordinate of the gradient+--+-- * @x1@ is the ending y-coordinate of the gradient+--+-- * @y1@ is the ending y-coordinate of the gradient+--+-- ==== __Example__+--+-- @+-- grd <- 'createLinearGradient'(0, 0, 10, 10)+-- grd # 'addColorStop'(0, \"blue\")+-- grd # 'addColorStop'(1, \"red\")+-- 'fillStyle' grd+-- @ createLinearGradient :: (Double, Double, Double, Double) -> Canvas CanvasGradient-createLinearGradient = Query . CreateLinearGradient+createLinearGradient = Function . CreateLinearGradient +-- | @'createRadialGradient'(x0, y0, r0, x1, y1, r1)@ creates a radial gradient given+-- by the coordinates of two circles, which can be used to fill other shapes.+--+-- * @x0@ is the x-axis of the coordinate of the start circle+--+-- * @y0@ is the y-axis of the coordinate of the start circle+--+-- * @r0@ is the radius of the start circle+--+-- * @x1@ is the x-axis of the coordinate of the end circle+--+-- * @y1@ is the y-axis of the coordinate of the end circle+--+-- * @r1@ is the radius of the end circle+--+-- ==== __Example__+--+-- @+-- grd <- 'createRadialGradient'(100,100,100,100,100,0)+-- grd # 'addColorStop'(0, \"blue\")+-- grd # 'addColorStop'(1, \"red\")+-- 'fillStyle' grd+-- @ createRadialGradient :: (Double, Double, Double, Double, Double, Double) -> Canvas CanvasGradient-createRadialGradient = Query . CreateRadialGradient+createRadialGradient = Function . CreateRadialGradient +-- | Creates a pattern using a 'CanvasImage' and a 'RepeatDirection'.+--+-- ==== __Example__+--+-- @+-- img <- newImage \"cat.jpg\"+-- pat <- 'createPattern'(img, 'repeatX')+-- 'fillStyle' pat+-- @ createPattern :: (CanvasImage, RepeatDirection) -> Canvas CanvasPattern-createPattern = Query . CreatePattern+createPattern = Function . CreatePattern --- | Create a new, off-screen canvas buffer. Takes width and height.+-- | Create a new, off-screen canvas buffer. Takes width and height as arguments. newCanvas :: (Int, Int) -> Canvas CanvasContext newCanvas = Query . NewCanvas --- | Capture ImageDate from the Canvas.+-- | @'getImageData'(x, y, w, h)@ capture 'ImageData' from the rectangle with+-- upper-left corner @(x, y)@, width @w@, and height @h@. getImageData :: (Double, Double, Double, Double) -> Canvas ImageData getImageData = Query . GetImageData --- | Send all commands to the browser, wait for the browser to ack, then continue.+-- | Change the canvas cursor to the specified URL or keyword. +--+-- ==== __Examples__+--+-- @+-- cursor $ 'url' \"image.png\" 'default_'+-- cursor 'crosshair'+-- @+cursor :: CanvasCursor cursor => cursor -> Canvas ()+cursor = Query . Cursor++-- | Send all commands to the browser, wait for the browser to act, then continue. sync :: Canvas ()-sync = Query $ Sync+sync = Query Sync

@@ -0,0 +1,63 @@+{-|+Module:      Graphics.Blank.Cursor+Copyright:   (C) 2014-2015, The University of Kansas+License:     BSD-style (see the file LICENSE)+Maintainer:  Andy Gill+Stability:   Beta+Portability: GHC++This module exposes an overloaded version of the 'cursor' function that can accept+a 'Cursor' ADT argument. This may be of interest if you desire stronger type safety+than @Text@-based cursors provide.++Note that this module's 'cursor' function conflicts with @cursor@ from+"Graphics.Blank". Make sure to hide @cursor@ from "Graphics.Blank" if you use+'cursor' from this module.+-}+module Graphics.Blank.Cursor (+      -- * Overloaded 'cursor'+      cursor+    , CanvasCursor(..)+      -- Cursors+    , Cursor(..)+    , auto+    , default_+    , none+    , contextMenu+    , help+    , pointer+    , progress+    , wait+    , cell+    , crosshair+    , text+    , verticalText+    , alias+    , copy+    , move+    , noDrop+    , notAllowed+    , allScroll+    , colResize+    , rowResize+    , nResize+    , eResize+    , sResize+    , wResize+    , neResize+    , nwResize+    , seResize+    , swResize+    , ewResize+    , nsResize+    , neswResize+    , nwseResize+    , zoomIn+    , zoomOut+    , grab+    , grabbing+    , url+    ) where++import Graphics.Blank.Canvas (cursor)+import Graphics.Blank.Types.Cursor

@@ -6,25 +6,29 @@ 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+import           TextShow (Builder, toText) --- | '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').+import qualified Web.Scotty.Comet as KC +-- | 'DeviceContext' is the abstract handle into a specific 2D context inside a browser.+-- Note that the JavaScript API concepts of+-- @<https://developer.mozilla.org/en-US/docs/Web/API/CanvasRenderingContext2D CanvasRenderingContext2D>@ and+-- @<https://developer.mozilla.org/en-US/docs/Web/API/HTMLCanvasElement HTMLCanvasElement>@+-- are conflated in @blank-canvas@. Therefore, there is no+-- @<https://developer.mozilla.org/en-US/docs/Web/API/HTMLCanvasElement/getContext getContext()>@ method;+-- rather, @getContext()@ is implied (when using 'send'). data DeviceContext = DeviceContext-        { theComet             :: KC.Document     -- ^ The mechansims for sending commands+        { theComet             :: KC.Document     -- ^ The mechanisms 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+        , weakRemoteMonad      :: Bool            -- ^ use a weak remote monad for debugging         }  instance Image DeviceContext where@@ -35,20 +39,21 @@ deviceCanvasContext :: DeviceContext -> CanvasContext deviceCanvasContext cxt = CanvasContext 0 (ctx_width cxt) (ctx_height cxt) --- ** 'devicePixelRatio' returns the Device Pixel Ratio as used. Typically, the browser ignore devicePixelRatio in the canvas,---   which can make fine details and text look fuzzy. Using the query "?hd" on the URL, blank-canvas attempts---   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' returns the device's pixel ratio as used. Typically, the+-- browser ignores @devicePixelRatio@ in the canvas, which can make fine details+-- and text look fuzzy. Using the query @?hd@ on the URL, @blank-canvas@ attempts+-- 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 -> Double devicePixelRatio = ctx_devicePixelRatio --- | internal command to send a message to the canvas.-sendToCanvas :: DeviceContext -> ShowS -> IO ()+-- | Internal command to send a message to the canvas.+sendToCanvas :: DeviceContext -> Builder -> IO () sendToCanvas cxt cmds = do-        KC.send (theComet cxt) $ "try{" <> T.pack (cmds "}catch(e){alert('JavaScript Failure: '+e.message);}")+        KC.send (theComet cxt) . toText $ "try{" <> cmds <> "}catch(e){alert('JavaScript Failure: '+e.message);}" --- | wait for any event. blocks.+-- | Wait for any event. Blocks. wait :: DeviceContext -> IO Event wait c = atomically $ readTChan (eventQueue c) 

@@ -1,22 +1,37 @@-{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-} module Graphics.Blank.Events where -import Control.Applicative ((<|>), (<$>), (<*>))+import Control.Applicative import Control.Concurrent.STM  import Data.Aeson (FromJSON(..), Value(..), ToJSON(..)) import Data.Aeson.Types ((.:), (.=), object) import Data.Text (Text) --- | Basic Event from Browser; see <http://api.jquery.com/category/events/> for details.+import TextShow.TH (deriveTextShow)++-- | 'EventName' mirrors event names from jQuery, and uses lowercase.+-- Possible named events+-- +-- * @keypress@, @keydown@, @keyup@+-- * @mouseDown@, @mouseenter@, @mousemove@, @mouseout@, @mouseover@, @mouseup@+type EventName = Text++-- | 'EventQueue' is an STM channel ('TChan') of 'Event's.+-- Intentionally, 'EventQueue' is not abstract.+type EventQueue = TChan Event++-- | Basic event from browser. See <http://api.jquery.com/category/events/> for details. data Event = Event         { eMetaKey :: Bool         , ePageXY  :: Maybe (Double, Double)         , eType    :: EventName          -- "Describes the nature of the event." jquery         , eWhich   :: Maybe Int          -- magic code for key presses         }-        deriving (Show)-+        deriving (Eq, Ord, Show)+$(deriveTextShow ''Event)  instance FromJSON Event where    parseJSON (Object v) = Event <$> ((v .: "metaKey")              <|> return False)@@ -36,16 +51,3 @@                  Nothing -> id                  Just w -> (:) ("which" .= w))             $ []---- | 'EventName' mirrors event names from jquery, and use lower case.---   Possible named events------     * keypress, keydown, keyup---     * mouseDown, mouseenter, mousemove, mouseout, mouseover, mouseup--- -type EventName = Text---- | EventQueue is a STM channel ('TChan') of 'Event's.--- Intentionally, 'EventQueue' is not abstract.-type EventQueue = TChan Event-

@@ -0,0 +1,86 @@+{-|+Module:      Graphics.Blank.Font+Copyright:   (C) 2014-2015, The University of Kansas+License:     BSD-style (see the file LICENSE)+Maintainer:  Andy Gill+Stability:   Beta+Portability: GHC++This module exposes an overloaded version of the 'font' function that can accept+a 'Font' ADT argument. This may be of interest if you desire stronger type safety+than @Text@-based fonts provide.++Note that this module's 'font' function conflicts with @font@ from "Graphics.Blank".+Make sure to hide @font@ from "Graphics.Blank" if you use 'font' from this module.+-}+module Graphics.Blank.Font+    ( -- * Overloaded 'font'+      font+    , CanvasFont(..)+      -- * @font@+    , Font(..)+    , defFont+    , caption+    , icon+    , menu+    , messageBox+    , smallCaption+    , statusBar+    -- * @font-style@+    , FontStyle(..)+    , italic+    , oblique+    -- * @font-variant@+    , FontVariant(..)+    , smallCaps+    -- * @font-weight@+    , FontWeight(..)+    , bold+    , bolder+    , lighter+    -- * @font-size@+    , FontSize(..)+    , xxSmall+    , xSmall+    , small+    , medium+    , large+    , xLarge+    , xxLarge+    , larger+    , smaller+    -- * @line-height@+    , LineHeight(..)+    -- * @font-family@+    , FontFamily(..)+    , serif+    , sansSerif+    , monospace+    , cursive+    , fantasy+    -- * Normal values+    , NormalProperty(..)+    -- * Lengths+    , Length(..)+    , LengthProperty(..)+    , em+    , ex+    , ch+    , rem_+    , vh+    , vw+    , vmin+    , vmax+    , px+    , mm+    , cm+    , in_+    , pt+    , pc+    -- * Percentages+    , PercentageProperty(..)+    ) where++import Graphics.Blank.Generated (font)+import Graphics.Blank.Types.CSS+import Graphics.Blank.Types.Font

@@ -1,3 +1,14 @@+{-|+Module:      Graphics.Blank.GHCi+Copyright:   (C) 2014-2015, The University of Kansas+License:     BSD-style (see the file LICENSE)+Maintainer:  Andy Gill+Stability:   Beta+Portability: GHC++The GHCi entry point for @blank-canvas@. Useful for sending multiple+commands to the same port.+-} module Graphics.Blank.GHCi (splatCanvas) where          import Control.Concurrent@@ -8,15 +19,15 @@  import System.IO.Unsafe (unsafePerformIO) --- | splitCanvas is the GHCi entry point into blank-canvas.+-- | splitCanvas is the GHCi entry point into @blank-canvas@. -- A typical invocation would be---+--  -- >GHCi> import Graphics.Blank -- >GHCi> import Graphics.Blank.GHCi -- > -- >-- Adding commands to the canvas buffer -- >GHCi> splatCanvas 3000 $ ( .. canvas commands .. )---+--  -- The system remembers if it has been called on a specific port before, -- and if so, uses the previous session. 

@@ -1,73 +1,192 @@+{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Graphics.Blank.Generated where -import Graphics.Blank.Canvas-import Graphics.Blank.JavaScript-import Data.Text (Text)+import           Data.Monoid ((<>))+import           Data.Text (Text) +import           Graphics.Blank.Canvas+import           Graphics.Blank.JavaScript+import           Graphics.Blank.Types+import           Graphics.Blank.Types.Font++import           TextShow (TextShow(..), FromTextShow(..), showb, singleton)+ instance Show Method where-  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(" ++ 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(" ++ jsDouble a1 ++ "," ++ jsDouble a2 ++ "," ++ jsDouble a3 ++ "," ++ jsDouble a4 ++ ")"-  show (FillStyle (a1)) = "fillStyle = (" ++ jsStyle a1 ++ ")"-  show (FillText (a1,a2,a3)) = "fillText(" ++ jsText a1 ++ "," ++ jsDouble a2 ++ "," ++ jsDouble a3 ++ ")"-  show (Font (a1)) = "font = (" ++ jsText a1 ++ ")"-  show (GlobalAlpha (a1)) = "globalAlpha = (" ++ jsDouble a1 ++ ")"-  show (GlobalCompositeOperation (a1)) = "globalCompositeOperation = (" ++ jsText a1 ++ ")"-  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(" ++ jsDouble a1 ++ ")"-  show Save = "save()"-  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(" ++ jsDouble a1 ++ "," ++ jsDouble a2 ++ "," ++ jsDouble a3 ++ "," ++ jsDouble a4 ++ ")"-  show (StrokeStyle (a1)) = "strokeStyle = (" ++ jsStyle a1 ++ ")"-  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 ++ ")"+  showsPrec p = showsPrec p . FromTextShow +instance TextShow Method where+  showb (Arc (a1,a2,a3,a4,a5,a6)) = "arc("+         <> jsDouble a1 <> singleton ',' <> jsDouble a2 <> singleton ','+         <> jsDouble a3 <> singleton ',' <> jsDouble a4 <> singleton ','+         <> jsDouble a5 <> singleton ',' <> jsBool a6   <> singleton ')'+  showb (ArcTo (a1,a2,a3,a4,a5)) = "arcTo("+         <> jsDouble a1 <> singleton ',' <> jsDouble a2 <> singleton ',' <> jsDouble a3 <> singleton ','+         <> jsDouble a4 <> singleton ',' <> jsDouble a5 <> singleton ')'+  showb BeginPath = "beginPath()"+  showb (BezierCurveTo (a1,a2,a3,a4,a5,a6)) = "bezierCurveTo("+         <> jsDouble a1 <> singleton ',' <> jsDouble a2 <> singleton ','+         <> jsDouble a3 <> singleton ',' <> jsDouble a4 <> singleton ','+         <> jsDouble a5 <> singleton ',' <> jsDouble a6 <> singleton ')'+  showb (ClearRect (a1,a2,a3,a4)) = "clearRect("+         <> jsDouble a1 <> singleton ',' <> jsDouble a2 <> singleton ','+         <> jsDouble a3 <> singleton ',' <> jsDouble a4 <> singleton ')'+  showb Clip = "clip()"+  showb ClosePath = "closePath()"+  showb (DrawImage (a1,a2)) = "drawImage(" <> jsImage a1 <> singleton ',' <> jsList jsDouble a2 <> singleton ')'+  showb Fill = "fill()"+  showb (FillRect (a1,a2,a3,a4)) = "fillRect("+         <> jsDouble a1 <> singleton ',' <> jsDouble a2 <> singleton ','+         <> jsDouble a3 <> singleton ',' <> jsDouble a4 <> singleton ')'+  showb (FillStyle (a1)) = "fillStyle = (" <> jsStyle a1 <> singleton ')'+  showb (FillText (a1,a2,a3)) = "fillText(" <> jsText a1 <> singleton ',' <> jsDouble a2 <> singleton ',' <> jsDouble a3 <> singleton ')'+  showb (Font (a1)) = "font = (" <> jsCanvasFont a1 <> singleton ')'+  showb (GlobalAlpha (a1)) = "globalAlpha = (" <> jsDouble a1 <> singleton ')'+  showb (GlobalCompositeOperation (a1)) = "globalCompositeOperation = (" <> jsText a1 <> singleton ')'+  showb (LineCap (a1)) = "lineCap = (" <> jsLineEndCap a1 <> singleton ')'+  showb (LineJoin (a1)) = "lineJoin = (" <> jsLineJoinCorner a1 <> singleton ')'+  showb (LineTo (a1,a2)) = "lineTo(" <> jsDouble a1 <> singleton ',' <> jsDouble a2 <> singleton ')'+  showb (LineWidth (a1)) = "lineWidth = (" <> jsDouble a1 <> singleton ')'+  showb (MiterLimit (a1)) = "miterLimit = (" <> jsDouble a1 <> singleton ')'+  showb (MoveTo (a1,a2)) = "moveTo(" <> jsDouble a1 <> singleton ',' <> jsDouble a2 <> singleton ')'+  showb (PutImageData (a1,a2)) = "putImageData(" <> jsImageData a1 <> singleton ',' <> jsList jsDouble a2 <> singleton ')'+  showb (QuadraticCurveTo (a1,a2,a3,a4)) = "quadraticCurveTo("+         <> jsDouble a1 <> singleton ',' <> jsDouble a2 <> singleton ','+         <> jsDouble a3 <> singleton ',' <> jsDouble a4 <> singleton ')'+  showb (Rect (a1,a2,a3,a4)) = "rect("+         <> jsDouble a1 <> singleton ',' <> jsDouble a2 <> singleton ','+         <> jsDouble a3 <> singleton ',' <> jsDouble a4 <> singleton ')'+  showb Restore = "restore()"+  showb (Rotate (a1)) = "rotate(" <> jsDouble a1 <> singleton ')'+  showb Save = "save()"+  showb (Scale (a1,a2)) = "scale(" <> jsDouble a1 <> singleton ',' <> jsDouble a2 <> singleton ')'+  showb (SetTransform (a1,a2,a3,a4,a5,a6)) = "setTransform("+         <> jsDouble a1 <> singleton ',' <> jsDouble a2 <> singleton ','+         <> jsDouble a3 <> singleton ',' <> jsDouble a4 <> singleton ','+         <> jsDouble a5 <> singleton ',' <> jsDouble a6 <> singleton ')'+  showb (ShadowBlur (a1)) = "shadowBlur = (" <> jsDouble a1 <> singleton ')'+  showb (ShadowColor (a1)) = "shadowColor = (" <> jsCanvasColor a1 <> singleton ')'+  showb (ShadowOffsetX (a1)) = "shadowOffsetX = (" <> jsDouble a1 <> singleton ')'+  showb (ShadowOffsetY (a1)) = "shadowOffsetY = (" <> jsDouble a1 <> singleton ')'+  showb Stroke = "stroke()"+  showb (StrokeRect (a1,a2,a3,a4)) = "strokeRect("+         <> jsDouble a1 <> singleton ',' <> jsDouble a2 <> singleton ','+         <> jsDouble a3 <> singleton ',' <> jsDouble a4 <> singleton ')'+  showb (StrokeStyle (a1)) = "strokeStyle = (" <> jsStyle a1 <> singleton ')'+  showb (StrokeText (a1,a2,a3)) = "strokeText(" <> jsText a1 <> singleton ',' <> jsDouble a2 <> singleton ',' <> jsDouble a3 <> singleton ')'+  showb (TextAlign (a1)) = "textAlign = (" <> jsTextAnchorAlignment a1 <> singleton ')'+  showb (TextBaseline (a1)) = "textBaseline = (" <> jsTextBaselineAlignment a1 <> singleton ')'+  showb (Transform (a1,a2,a3,a4,a5,a6)) = "transform("+         <> jsDouble a1 <> singleton ',' <> jsDouble a2 <> singleton ','+         <> jsDouble a3 <> singleton ',' <> jsDouble a4 <> singleton ','+         <> jsDouble a5 <> singleton ',' <> jsDouble a6 <> singleton ')'+  showb (Translate (a1,a2)) = "translate(" <> jsDouble a1 <> singleton ',' <> jsDouble a2 <> singleton ')'+ -- DSL -arc :: (Double, Double, Double, Double, Double, Bool) -> Canvas ()+-- | @'arc'(x, y, r, sAngle, eAngle, cc)@ creates a circular arc, where+-- +-- * @x@ is the x-coordinate of the center of the circle+-- +-- * @y@ is the y-coordinate of the center of the circle+-- +-- * @r@ is the radius of the circle on which the arc is drawn+-- +-- * @sAngle@ is the starting angle (where @0@ at the 3 o'clock position of the circle)+-- +-- * @eAngle@ is the ending angle+-- +-- * @cc@ is the arc direction, where @True@ indicates counterclockwise and+--   @False@ indicates clockwise.+arc :: (Double, Double, Double, Radians, Radians, Bool) -> Canvas () arc = Method . Arc +-- | @'arcTo'(x1, y1, x2, y2, r)@ creates an arc between two tangents,+-- specified by two control points and a radius.+-- +-- * @x1@ is the x-coordinate of the first control point+-- +-- * @y1@ is the y-coordinate of the first control point+-- +-- * @x2@ is the x-coordinate of the second control point+-- +-- * @y2@ is the y-coordinate of the second control point+-- +-- * @r@ is the arc's radius arcTo :: (Double, Double, Double, Double, Double) -> Canvas () arcTo = Method . ArcTo +-- | Begins drawing a new path. This will empty the current list of subpaths.+--+-- ==== __Example__+-- +-- @+-- 'beginPath'()+-- 'moveTo'(20, 20)+-- 'lineTo'(200, 20)+-- 'stroke'()+-- @ beginPath :: () -> Canvas () beginPath () = Method BeginPath +-- | @'bezierCurveTo'(cp1x, cp1y, cp2x, cp2y x, y)@ adds a cubic Bézier curve to the path+-- (whereas 'quadraticCurveTo' adds a quadratic Bézier curve).+-- +-- * @cp1x@ is the x-coordinate of the first control point+-- +-- * @cp1y@ is the y-coordinate of the first control point+-- +-- * @cp2x@ is the x-coordinate of the second control point+-- +-- * @cp2y@ is the y-coordinate of the second control point+-- +-- * @x@ is the x-coordinate of the end point+-- +-- * @y@ is the y-coordinate of the end point bezierCurveTo :: (Double, Double, Double, Double, Double, Double) -> Canvas () bezierCurveTo = Method . BezierCurveTo +-- | @'clearRect'(x, y, w, h)@ clears all pixels within the rectangle with upper-left+-- corner @(x, y)@, width @w@, and height @h@ (i.e., sets the pixels to transparent black).+--+-- ==== __Example__+-- +-- @+-- 'fillStyle' \"red\"+-- 'fillRect'(0, 0, 300, 150)+-- 'clearRect'(20, 20, 100, 50)+-- @ clearRect :: (Double, Double, Double, Double) -> Canvas () clearRect = Method . ClearRect +-- | Turns the path currently being built into the current clipping path.+-- Anything drawn after 'clip' is called will only be visible if inside the new+-- clipping path. +--+-- ==== __Example__+-- +-- @+-- 'rect'(50, 20, 200, 120)+-- 'stroke'()+-- 'clip'()+-- 'fillStyle' \"red\"+-- 'fillRect'(0, 0, 150, 100)+-- @ clip :: () -> Canvas () clip () = Method Clip +-- | Creates a path from the current point back to the start, to close it.+--+-- ==== __Example__+-- +-- @+-- 'beginPath'()+-- 'moveTo'(20, 20)+-- 'lineTo'(200, 20)+-- 'lineTo'(120, 120)+-- 'closePath'()+-- 'stroke'()+-- @ closePath :: () -> Canvas () closePath () = Method ClosePath @@ -75,42 +194,130 @@ drawImage :: Image image => (image,[Double]) -> Canvas () drawImage = Method . DrawImage +-- | Fills the current path with the current 'fillStyle'.+--+-- ==== __Example__+-- +-- @+-- 'rect'(10, 10, 100, 100)+-- 'fill'()+-- @ fill :: () -> Canvas () fill () = Method Fill +-- | @'fillRect'(x, y, w, h)@ draws a filled rectangle with upper-left+-- corner @(x, y)@, width @w@, and height @h@ using the current 'fillStyle'.+--+-- ==== __Example__+-- +-- @+-- 'fillStyle' \"red\"+-- 'fillRect'(0, 0, 300, 150)+-- @ fillRect :: (Double, Double, Double, Double) -> Canvas () fillRect = Method . FillRect +-- | Sets the color, gradient, or pattern used to fill a drawing ('black' by default).+--+-- ==== __Examples__+-- +-- @+-- 'fillStyle' 'red'+-- +-- grd <- 'createLinearGradient'(0, 0, 10, 10)+-- 'fillStyle' grd+-- +-- img <- 'newImage' \"/myImage.jpg\"+-- pat <- 'createPattern'(img, 'Repeat')+-- 'fillStyle' pat+-- @ fillStyle :: Style style => style -> Canvas () fillStyle = Method . FillStyle +-- | @'fillText'(t, x, y)@ fills the text @t@ at position @(x, y)@+-- using the current 'fillStyle'.+--+-- ==== __Example__+-- +-- @+-- 'font' \"48px serif\"+-- 'fillText'(\"Hello, World!\", 50, 100)+-- @ fillText :: (Text, Double, Double) -> Canvas () fillText = Method . FillText -font :: Text -> Canvas ()+-- | Sets the text context's font properties.+--+-- ==== __Examples__+-- +-- @+-- 'font' ('defFont' "Gill Sans Extrabold") { 'fontSize' = 40 # 'pt' }+-- 'font' ('defFont' 'sansSerif') { 'fontSize' = 80 # 'percent' }+-- 'font' ('defFont' 'serif') {+--     'fontWeight' = 'bold'+--   , 'fontStyle'  = 'italic'+--   , 'fontSize'   = 'large'+-- }+-- @+font :: CanvasFont canvasFont => canvasFont -> Canvas () font = Method . Font -globalAlpha :: Double -> Canvas ()+-- | Set the alpha value that is applied to shapes before they are drawn onto the canvas.+globalAlpha :: Alpha -> Canvas () globalAlpha = Method . GlobalAlpha +-- | Sets how new shapes should be drawn over existing shapes.+--+-- ==== __Examples__+-- +-- @+-- 'globalCompositeOperation' \"source-over\"+-- 'globalCompositeOperation' \"destination-atop\"+-- @ globalCompositeOperation :: Text -> Canvas () globalCompositeOperation = Method . GlobalCompositeOperation +-- | Sets the 'LineEndCap' to use when drawing the endpoints of lines. lineCap :: LineEndCap -> Canvas () lineCap = Method . LineCap +-- | Sets the 'LineJoinCorner' to use when drawing two connected lines. lineJoin :: LineJoinCorner -> Canvas () lineJoin = Method . LineJoin +-- | @'lineTo'(x, y)@ connects the last point in the subpath to the given @(x, y)@+-- coordinates (without actually drawing it).+--+-- ==== __Example__+-- +-- @+-- 'beginPath'()+-- 'moveTo'(50, 50)+-- 'lineTo'(200, 50)+-- 'stroke'()+-- @ lineTo :: (Double, Double) -> Canvas () lineTo = Method . LineTo +-- | Sets the thickness of lines in pixels (@1.0@ by default). lineWidth :: Double -> Canvas () lineWidth = Method . LineWidth +-- | Sets the maximum miter length (@10.0@ by default) to use when the+-- 'lineWidth' is 'miter'. miterLimit :: Double -> Canvas () miterLimit = Method . MiterLimit +-- | @'moveTo'(x, y)@ moves the starting point of a new subpath to the given @(x, y)@ coordinates.+--+-- ==== __Example__+-- +-- @+-- 'beginPath'()+-- 'moveTo'(50, 50)+-- 'lineTo'(200, 50)+-- 'stroke'()+-- @ moveTo :: (Double, Double) -> Canvas () moveTo = Method . MoveTo @@ -118,60 +325,190 @@ putImageData :: (ImageData, [Double]) -> Canvas () putImageData = Method . PutImageData +-- | @'quadraticCurveTo'(cpx, cpy, x, y)@ adds a quadratic Bézier curve to the path+-- (whereas 'bezierCurveTo' adds a cubic Bézier curve).+-- +-- * @cpx@ is the x-coordinate of the control point+-- +-- * @cpy@ is the y-coordinate of the control point+-- +-- * @x@ is the x-coordinate of the end point+-- +-- * @y@ is the y-coordinate of the end point quadraticCurveTo :: (Double, Double, Double, Double) -> Canvas () quadraticCurveTo = Method . QuadraticCurveTo +-- | @'rect'(x, y, w, h)@ creates a rectangle with an upper-left corner at position+-- @(x, y)@, width @w@, and height @h@ (where width and height are in pixels).+--+-- ==== __Example__+-- +-- @+-- 'rect'(10, 10, 100, 100)+-- 'fill'()+-- @ rect :: (Double, Double, Double, Double) -> Canvas () rect = Method . Rect +-- | Restores the most recently saved canvas by popping the top entry off of the+-- drawing state stack. If there is no state, do nothing. restore :: () -> Canvas () restore () = Method Restore -rotate :: Double -> Canvas ()+-- | Applies a rotation transformation to the canvas. When you call functions+-- such as 'fillRect' after 'rotate', the drawings will be rotated clockwise by+-- the angle given to 'rotate' (in radians).+--+-- ==== __Example__+-- +-- @+-- 'rotate' ('pi'/2)        -- Rotate the canvas 90°+-- 'fillRect'(0, 0, 20, 10) -- Draw a 10x20 rectangle+-- @+rotate :: Radians -> Canvas () rotate = Method . Rotate +-- | Saves the entire canvas by pushing the current state onto a stack. save :: () -> Canvas () save () = Method Save -scale :: (Double, Double) -> Canvas ()+-- | Applies a scaling transformation to the canvas units, where the first argument+-- is the percent to scale horizontally, and the second argument is the percent to+-- scale vertically. By default, one canvas unit is one pixel.+--+-- ==== __Examples__+-- +-- @+-- 'scale'(0.5, 0.5)        -- Halve the canvas units+-- 'fillRect'(0, 0, 20, 20) -- Draw a 10x10 square+-- 'scale'(-1, 1)           -- Flip the context horizontally+-- @+scale :: (Interval, Interval) -> Canvas () scale = Method . Scale +-- | Resets the canvas's transformation matrix to the identity matrix,+-- then calls 'transform' with the given arguments. setTransform :: (Double, Double, Double, Double, Double, Double) -> Canvas () setTransform = Method . SetTransform +-- | Sets the blur level for shadows (@0.0@ by default). shadowBlur :: Double -> Canvas () shadowBlur = Method . ShadowBlur +-- | Sets the color used for shadows.+--+-- ==== __Examples__+-- +-- @+-- 'shadowColor' 'red'+-- 'shadowColor' $ 'rgb' 0 255 0+-- @ shadowColor :: CanvasColor canvasColor => canvasColor -> Canvas () shadowColor = Method . ShadowColor +-- | Sets the horizontal distance that a shadow will be offset (@0.0@ by default). shadowOffsetX :: Double -> Canvas () shadowOffsetX = Method . ShadowOffsetX +-- | Sets the vertical distance that a shadow will be offset (@0.0@ by default). shadowOffsetY :: Double -> Canvas () shadowOffsetY = Method . ShadowOffsetY +-- | Draws the current path's strokes with the current 'strokeStyle' ('black' by default).+--+-- ==== __Example__+-- +-- @+-- 'rect'(10, 10, 100, 100)+-- 'stroke'()+-- @ stroke :: () -> Canvas () stroke () = Method Stroke +-- | @'strokeRect'(x, y, w, h)@ draws a rectangle (no fill) with upper-left+-- corner @(x, y)@, width @w@, and height @h@ using the current 'strokeStyle'.+--+-- ==== __Example__+-- +-- @+-- 'strokeStyle' \"red\"+-- 'strokeRect'(0, 0, 300, 150)+-- @ strokeRect :: (Double, Double, Double, Double) -> Canvas () strokeRect = Method . StrokeRect +-- | Sets the color, gradient, or pattern used for strokes.+--+-- ==== __Examples__+-- +-- @+-- 'strokeStyle' 'red'+-- +-- grd <- 'createLinearGradient'(0, 0, 10, 10)+-- 'strokeStyle' grd+-- +-- img <- 'newImage' \"/myImage.jpg\"+-- pat <- 'createPattern'(img, 'Repeat')+-- 'strokeStyle' pat+-- @ strokeStyle :: Style style => style -> Canvas () strokeStyle = Method . StrokeStyle +-- | @'strokeText'(t, x, y)@ draws text @t@ (with no fill) at position @(x, y)@+-- using the current 'strokeStyle'.+--+-- ==== __Example__+-- +-- @+-- 'font' \"48px serif\"+-- 'strokeText'(\"Hello, World!\", 50, 100)+-- @ strokeText :: (Text,Double, Double) -> Canvas () strokeText = Method . StrokeText +-- | Sets the 'TextAnchorAlignment' to use when drawing text. textAlign :: TextAnchorAlignment -> Canvas () textAlign = Method . TextAlign +-- | Sets the 'TextBaselineAlignment' to use when drawing text. textBaseline :: TextBaselineAlignment -> Canvas () textBaseline = Method . TextBaseline +-- | Applies a transformation by multiplying a matrix to the canvas's+-- current transformation. If @'transform'(a, b, c, d, e, f)@ is called, the matrix+-- +-- @+-- ( a c e )+-- ( b d f )+-- ( 0 0 1 )+-- @+-- +-- is multiplied by the current transformation. The parameters are:+-- +-- * @a@ is the horizontal scaling+-- +-- * @b@ is the horizontal skewing+-- +-- * @c@ is the vertical skewing+-- +-- * @d@ is the vertical scaling+-- +-- * @e@ is the horizontal movement+-- +-- * @f@ is the vertical movement transform :: (Double, Double, Double, Double, Double, Double) -> Canvas () transform = Method . Transform +-- | Applies a translation transformation by remapping the origin (i.e., the (0,0)+-- position) on the canvas. When you call functions such as 'fillRect' after+-- 'translate', the values passed to 'translate' are added to the x- and+-- y-coordinate values. +--+-- ==== __Example__+-- +-- @+-- 'translate'(20, 20)+-- 'fillRect'(0, 0, 40, 40) -- Draw a 40x40 square, starting in position (20, 20)+-- @ translate :: (Double, Double) -> Canvas () translate = Method . Translate-

@@ -1,55 +1,115 @@-{-# LANGUAGE FlexibleInstances, OverlappingInstances #-}-+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-} module Graphics.Blank.JavaScript where -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.Monoid ((<>)) import           Data.List import           Data.String-import           Data.Text (Text, unpack)+import           Data.Text (Text)+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Builder as B (singleton)+import qualified Data.Vector.Unboxed as V+import           Data.Vector.Unboxed (Vector, toList) import           Data.Word (Word8) -import qualified Data.Vector.Unboxed as V-import           Data.Vector.Unboxed (Vector)+import           Graphics.Blank.Parser -import           Numeric+import           Prelude.Compat -import           Text.ParserCombinators.ReadP (skipSpaces, string)-import           Text.ParserCombinators.ReadPrec-import           Text.Read+import           Text.ParserCombinators.ReadP (choice, skipSpaces)+import           Text.ParserCombinators.ReadPrec (lift)+import           Text.Read (Read(..), parens, readListPrecDefault) +import           TextShow+import           TextShow.Data.Floating (showbFFloat)+import           TextShow.Data.Integral (showbHex)+import           TextShow.TH (deriveTextShow)+ ------------------------------------------------------------- --- TODO: close off+-- | A handle to an offscreen canvas. 'CanvasContext' cannot be destroyed.+data CanvasContext = CanvasContext Int Int Int deriving (Eq, Ord, Show)+$(deriveTextShow ''CanvasContext)++-- | A handle to a canvas image. 'CanvasImage's cannot be destroyed.+data CanvasImage = CanvasImage Int Int Int     deriving (Eq, Ord, Show)+$(deriveTextShow ''CanvasImage)++-- | A handle to the a canvas gradient. 'CanvasGradient's cannot be destroyed.+newtype CanvasGradient = CanvasGradient Int    deriving (Eq, Ord, Show)+$(deriveTextShow ''CanvasGradient)++-- | A handle to a canvas pattern. 'CanvasPattern's cannot be destroyed.+newtype CanvasPattern = CanvasPattern Int      deriving (Eq, Ord, Show)+$(deriveTextShow ''CanvasPattern)++-- | A handle to a canvas audio. 'CanvasAudio's cannot be destroyed.+data CanvasAudio = CanvasAudio !Int !Double    deriving (Eq, Ord, Show)+$(deriveTextShow ''CanvasAudio)++-------------------------------------------------------------++-- | 'ImageData' is a transliteration of JavaScript's+-- @<https://developer.mozilla.org/en-US/docs/Web/API/ImageData ImageData>@.+-- 'ImageData' consists of two 'Int's and one (unboxed) 'Vector' of 'Word8's.+-- @width@, @height@, and @data@ can be projected from 'ImageData',+-- 'Vector.length' can be used to find the @data@ length.+--+-- Note: 'ImageData' lives on the server, not the client.++data ImageData = ImageData !Int !Int !(Vector Word8) deriving (Eq, Ord, Show)++-- Defined manually to avoid an orphan T.Show (Vector a) instance+instance TextShow ImageData where+    showbPrec p (ImageData w h d) = showbParen (p > 10) $+        "ImageData " <> showbPrec 11 w <> showbSpace+                     <> showbPrec 11 h <> showbSpace+                     <> showbUnaryWith showbPrec "fromList" 11 (toList d)++-------------------------------------------------------------++-- | Class for JavaScript objects that represent images (including the canvas itself). class Image a where-  jsImage :: a -> String-  width  :: Num b => a -> b-  height :: Num b => a -> b+    jsImage :: a -> Builder+    width  :: Num b => a -> b+    height :: Num b => a -> b  instance Image CanvasImage where-  jsImage = jsCanvasImage-  width  (CanvasImage _ w _) = fromIntegral w-  height (CanvasImage _ _ h) = fromIntegral h+    jsImage = jsCanvasImage+    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-  height (CanvasContext _ _ h) = fromIntegral h+    jsImage = (<> ".canvas") . jsCanvasContext+    width  (CanvasContext _ w _) = fromIntegral w+    height (CanvasContext _ _ h) = fromIntegral h +class Audio a where+    jsAudio  :: a -> Builder+    duration :: Fractional b => a -> b++instance Audio CanvasAudio where+  jsAudio                    = jsCanvasAudio+  duration (CanvasAudio _ d) = realToFrac d+ -- instance Element Video  -- Not supported  ----------------------------------------------------------------------------- --- TODO: close off+-- | A data type that can represent a style. That is, something with one or more+-- colors. class Style a where-  jsStyle :: a -> String+    -- | Convert a value into a JavaScript string representing a style value.+    jsStyle :: a -> Builder  instance Style Text                 where { jsStyle = jsText } instance Style CanvasGradient       where { jsStyle = jsCanvasGradient }@@ -57,9 +117,10 @@ instance Style (Colour Double)      where { jsStyle = jsColour } instance Style (AlphaColour Double) where { jsStyle = jsAlphaColour } +-- | A 'Style' containing exactly one color. class Style a => CanvasColor a -jsCanvasColor :: CanvasColor color => color -> String+jsCanvasColor :: CanvasColor color => color -> Builder jsCanvasColor = jsStyle  instance CanvasColor Text@@ -68,30 +129,31 @@  ------------------------------------------------------------- --- | A handle to an offscreen canvas. CanvasContext can not be destroyed.-data CanvasContext = CanvasContext Int Int Int- deriving (Show,Eq,Ord)---- | A handle to the Image. CanvasImages can not be destroyed.-data CanvasImage = CanvasImage Int Int Int deriving (Show,Eq,Ord)---- | A handle to the CanvasGradient. CanvasGradients can not be destroyed.-newtype CanvasGradient = CanvasGradient Int deriving (Show,Eq,Ord)---- | A handle to the CanvasPattern. CanvasPatterns can not be destroyed.-newtype CanvasPattern = CanvasPattern Int deriving (Show,Eq,Ord)---------------------------------------------------------------- -- | The direction in which a 'CanvasPattern' repeats. data RepeatDirection = Repeat   -- ^ The pattern repeats both horizontally-                                --   and vertically.+                                --   and vertically (default).                      | RepeatX  -- ^ The pattern repeats only horizontally.                      | RepeatY  -- ^ The pattern repeats only vertically.                      | NoRepeat -- ^ The pattern displays only once and                                 --   does not repeat.-  deriving Eq+  deriving (Bounded, Enum, Eq, Ix, Ord) +-- | Shorthand for 'Repeat', with an underscore to distinguish it from 'repeat'.+repeat_ :: RepeatDirection+repeat_ = Repeat++-- | Shorthand for 'RepeatX'.+repeatX :: RepeatDirection+repeatX = RepeatX++-- | Shorthand for 'RepeatY'.+repeatY :: RepeatDirection+repeatY = RepeatY++-- | Shorthand for 'NoRepeat'.+noRepeat :: RepeatDirection+noRepeat = NoRepeat+ instance Default RepeatDirection where   def = Repeat @@ -99,76 +161,109 @@   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)+    readPrec = parens . lift $ do+        skipSpaces+        choice+            [ Repeat   <$ stringCI "repeat"+            , RepeatX  <$ stringCI "repeat-x"+            , RepeatY  <$ stringCI "repeat-y"+            , NoRepeat <$ stringCI "no-repeat"+            ]+    readListPrec = readListPrecDefault  instance Show RepeatDirection where-  showsPrec _ rd = showString $ case rd of-      Repeat   -> "repeat"-      RepeatX  -> "repeat-x"-      RepeatY  -> "repeat-y"-      NoRepeat -> "no-repeat"+    showsPrec p = showsPrec p . FromTextShow +instance TextShow RepeatDirection where+    showb Repeat   = "repeat"+    showb RepeatX  = "repeat-x"+    showb RepeatY  = "repeat-y"+    showb NoRepeat = "no-repeat"+ -- | The style of the caps on the endpoints of a line.-data LineEndCap = ButtCap   -- ^ Flat edges+data LineEndCap = ButtCap   -- ^ Flat edges (default).                 | RoundCap  -- ^ Semicircular end caps                 | SquareCap -- ^ Square end caps-  deriving Eq+  deriving (Bounded, Enum, Eq, Ix, Ord) +-- | Shorthand for 'ButtCap'.+butt :: LineEndCap+butt = ButtCap++-- | Shorthand for 'SquareCap'.+square :: LineEndCap+square = SquareCap+ instance Default LineEndCap where-  def = ButtCap+    def = ButtCap  instance IsString LineEndCap where-  fromString = read+    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+    readPrec = parens . lift $ do+        skipSpaces+        choice+            [ ButtCap   <$ stringCI "butt"+            , RoundCap  <$ stringCI "round"+            , SquareCap <$ stringCI "square"+            ]+    readListPrec = readListPrecDefault +instance RoundProperty LineEndCap where+    round_ = RoundCap+ instance Show LineEndCap where-  showsPrec _ le = showString $ case le of-      ButtCap   -> "butt"-      RoundCap  -> "round"-      SquareCap -> "square"+    showsPrec p = showsPrec p . FromTextShow +instance TextShow LineEndCap where+    showb ButtCap   = "butt"+    showb RoundCap  = "round"+    showb 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+                                  --   connects two lines (default).+  deriving (Bounded, Enum, Eq, Ix, Ord) +-- | Shorthand for 'BevelCorner'.+bevel :: LineJoinCorner+bevel = BevelCorner++-- | Shorthand for 'MiterCorner'.+miter :: LineJoinCorner+miter = MiterCorner+ instance Default LineJoinCorner where-  def = MiterCorner+    def = MiterCorner  instance IsString LineJoinCorner where-  fromString = read+    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+    readPrec = parens . lift $ do+        skipSpaces+        choice+            [ BevelCorner <$ stringCI "bevel"+            , RoundCorner <$ stringCI "round"+            , MiterCorner <$ stringCI "miter"+            ]+    readListPrec = readListPrecDefault +instance RoundProperty LineJoinCorner where+    round_ = RoundCorner+ instance Show LineJoinCorner where-  showsPrec _ corner = showString $ case corner of-      BevelCorner -> "bevel"-      RoundCorner -> "round"-      MiterCorner -> "miter"+    showsPrec p = showsPrec p . FromTextShow +instance TextShow LineJoinCorner where+    showb BevelCorner = "bevel"+    showb RoundCorner = "round"+    showb 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@@ -179,33 +274,56 @@                          | 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+  deriving (Bounded, Enum, Eq, Ix, Ord) +-- | Shorthand for 'StartAnchor'.+start :: TextAnchorAlignment+start = StartAnchor++-- | Shorthand for 'EndAnchor'.+end :: TextAnchorAlignment+end = EndAnchor++-- | Shorthand for 'CenterAnchor'.+center :: TextAnchorAlignment+center = CenterAnchor++-- | Shorthand for 'LeftAnchor'.+left :: TextAnchorAlignment+left = LeftAnchor++-- | Shorthand for 'RightAnchor'.+right :: TextAnchorAlignment+right = RightAnchor+ instance Default TextAnchorAlignment where-  def = StartAnchor+    def = StartAnchor  instance IsString TextAnchorAlignment where-  fromString = read+    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+    readPrec = parens . lift $ do+        skipSpaces+        choice+            [ StartAnchor  <$ stringCI "start"+            , EndAnchor    <$ stringCI "end"+            , CenterAnchor <$ stringCI "center"+            , LeftAnchor   <$ stringCI "left"+            , RightAnchor  <$ stringCI "right"+            ]+    readListPrec = readListPrecDefault  instance Show TextAnchorAlignment where-  showsPrec _ align = showString $ case align of-      StartAnchor  -> "start"-      EndAnchor    -> "end"-      CenterAnchor -> "center"-      LeftAnchor   -> "left"-      RightAnchor  -> "right"+    showsPrec p = showsPrec p . FromTextShow +instance TextShow TextAnchorAlignment where+    showb StartAnchor  = "start"+    showb EndAnchor    = "end"+    showb CenterAnchor = "center"+    showb LeftAnchor   = "left"+    showb 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@@ -214,199 +332,244 @@                            | AlphabeticBaseline                            | IdeographicBaseline                            | BottomBaseline-  deriving (Bounded, Eq, Ix, Ord)+  deriving (Bounded, Enum, Eq, Ix, Ord) +-- | Shorthand for 'TopBaseline'.+top :: TextBaselineAlignment+top = TopBaseline++-- | Shorthand for 'HangingBaseline'.+hanging :: TextBaselineAlignment+hanging = HangingBaseline++-- | Shorthand for 'MiddleBaseline'.+middle :: TextBaselineAlignment+middle = MiddleBaseline++-- | Shorthand for 'AlphabeticBaseline'.+alphabetic :: TextBaselineAlignment+alphabetic = AlphabeticBaseline++-- | Shorthand for 'IdeographicBaseline'.+ideographic :: TextBaselineAlignment+ideographic = IdeographicBaseline++-- | Shorthand for 'BottomBaseline'.+bottom :: TextBaselineAlignment+bottom = BottomBaseline+ instance Default TextBaselineAlignment where-  def = AlphabeticBaseline+    def = AlphabeticBaseline  instance IsString TextBaselineAlignment where-  fromString = read+    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+    readPrec = parens . lift $ do+        skipSpaces+        choice+            [ TopBaseline         <$ stringCI "top"+            , HangingBaseline     <$ stringCI "hanging"+            , MiddleBaseline      <$ stringCI "middle"+            , AlphabeticBaseline  <$ stringCI "alphabetic"+            , IdeographicBaseline <$ stringCI "ideographic"+            , BottomBaseline      <$ stringCI "bottom"+            ]+    readListPrec = readListPrecDefault  instance Show TextBaselineAlignment where-  showsPrec _ bl = showString $ case bl of-      TopBaseline         -> "top"-      HangingBaseline     -> "hanging"-      MiddleBaseline      -> "middle"-      AlphabeticBaseline  -> "alphabetic"-      IdeographicBaseline -> "ideographic"-      BottomBaseline      -> "bottom"---------------------------------------------------------------+    showsPrec p = showsPrec p . FromTextShow --- | '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.+instance TextShow TextBaselineAlignment where+    showb TopBaseline         = "top"+    showb HangingBaseline     = "hanging"+    showb MiddleBaseline      = "middle"+    showb AlphabeticBaseline  = "alphabetic"+    showb IdeographicBaseline = "ideographic"+    showb BottomBaseline      = "bottom" -data ImageData = ImageData !Int !Int !(Vector Word8) deriving (Show, Eq, Ord)+-- | Class for @round@ CSS property values.+class RoundProperty a where+    -- | Shorthand for 'RoundCap' or 'RoundCorner', with an underscore to+    -- distinguish it from 'round'.+    round_ :: a  ------------------------------------------------------------- +-- | Class for Haskell data types which represent JavaScript data. class JSArg a where-  showJS :: a -> String+    -- | Display a value as JavaScript data.+    showbJS :: a -> Builder  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+  showbJS = jsAlphaColour -jsAlphaColour :: AlphaColour Double -> String-jsAlphaColour = showJS+jsAlphaColour :: AlphaColour Double -> Builder+jsAlphaColour aCol+    | a >= 1    = jsColour rgbCol+    | a <= 0    = jsLiteralBuilder "rgba(0,0,0,0)"+    | otherwise = jsLiteralBuilder $ "rgba("+        <> showb r    <> B.singleton ','+        <> showb g    <> B.singleton ','+        <> showb b    <> B.singleton ','+        <> jsDouble a <> B.singleton ')'+  where+    a         = alphaChannel aCol+    rgbCol    = darken (recip a) $ aCol `over` black+    RGB r g b = toSRGB24 rgbCol  instance JSArg Bool where-  showJS True  = "true"-  showJS False = "false"+    showbJS = jsBool -jsBool :: Bool -> String-jsBool = showJS+jsBool :: Bool -> Builder+jsBool True  = "true"+jsBool False = "false" +instance JSArg CanvasAudio where+  showbJS = jsCanvasAudio++jsCanvasAudio :: CanvasAudio -> Builder+jsCanvasAudio (CanvasAudio n _ ) = "sounds[" <> showb n <> B.singleton ']'+ instance JSArg CanvasContext where-  showJS (CanvasContext n _ _) = "canvasbuffers[" ++ show n ++ "]"+    showbJS = jsCanvasContext -jsCanvasContext :: CanvasContext -> String-jsCanvasContext = showJS+jsCanvasContext :: CanvasContext -> Builder+jsCanvasContext (CanvasContext n _ _) = "canvasbuffers[" <> showb n <> B.singleton ']'  instance JSArg CanvasImage where-  showJS (CanvasImage n _ _) = "images[" ++ show n ++ "]"+    showbJS = jsCanvasImage -jsCanvasImage :: CanvasImage -> String-jsCanvasImage = showJS+jsCanvasImage :: CanvasImage -> Builder+jsCanvasImage (CanvasImage n _ _) = "images[" <> showb n <> B.singleton ']'  instance JSArg CanvasGradient where-  showJS (CanvasGradient n) = "gradients[" ++ show n ++ "]"+    showbJS = jsCanvasGradient -jsCanvasGradient :: CanvasGradient -> String-jsCanvasGradient = showJS+jsCanvasGradient :: CanvasGradient -> Builder+jsCanvasGradient (CanvasGradient n) = "gradient_" <> showb n  instance JSArg CanvasPattern where-  showJS (CanvasPattern n) = "patterns[" ++ show n ++ "]"+    showbJS = jsCanvasPattern -jsCanvasPattern :: CanvasPattern -> String-jsCanvasPattern = showJS+jsCanvasPattern :: CanvasPattern -> Builder+jsCanvasPattern (CanvasPattern n) = "pattern_" <> showb n  instance JSArg (Colour Double) where-  showJS = jsLiteralString . sRGB24show+    showbJS = jsColour -jsColour :: Colour Double -> String-jsColour = showJS+jsColour :: Colour Double -> Builder+jsColour = jsLiteralBuilder . sRGB24showb +-- | Convert a colour in hexadecimal 'Builder' form, e.g. \"#00aaff\"+sRGB24showb :: (Floating b, RealFrac b) => Colour b -> Builder+sRGB24showb c =+    B.singleton '#' <> showbHex2 r' <> showbHex2 g' <> showbHex2 b'+  where+    RGB r' g' b' = toSRGB24 c+    showbHex2 x | x <= 0xf = B.singleton '0' <> showbHex x+                | otherwise = showbHex x+ instance JSArg Double where-  showJS a = showFFloat (Just 3) a ""+    showbJS = jsDouble -jsDouble :: Double -> String-jsDouble = showJS+jsDouble :: Double -> Builder+jsDouble = showbFFloat $ Just 3  instance JSArg ImageData where-  showJS (ImageData w h d) = "ImageData(" ++ show w ++ "," ++ show h ++ ",[" ++ vs ++ "])"-     where-          vs = jsList show $ V.toList d+    showbJS = jsImageData -jsImageData :: ImageData -> String-jsImageData = showJS+jsImageData :: ImageData -> Builder+jsImageData (ImageData w h d) = "ImageData(" <> showb w+    <> B.singleton ',' <> showb h+    <> ",[" <> vs <> "])"+  where+    vs = jsList showb $ V.toList d  instance JSArg Int where-  showJS a = show a+    showbJS = jsInt +jsInt :: Int -> Builder+jsInt = showb+ instance JSArg LineEndCap where-  showJS = jsLiteralString . show+    showbJS = jsLineEndCap -jsLineEndCap :: LineEndCap -> String-jsLineEndCap = showJS+jsLineEndCap :: LineEndCap -> Builder+jsLineEndCap = jsLiteralBuilder . showb  instance JSArg LineJoinCorner where-  showJS = jsLiteralString . show+    showbJS = jsLineJoinCorner -jsLineJoinCorner :: LineJoinCorner -> String-jsLineJoinCorner = showJS+jsLineJoinCorner :: LineJoinCorner -> Builder+jsLineJoinCorner = jsLiteralBuilder . showb -jsList :: (a -> String) -> [a] -> String-jsList js = concat . intersperse "," . map js+jsList :: (a -> Builder) -> [a] -> Builder+jsList js = mconcat . intersperse "," . map js  instance JSArg RepeatDirection where-  showJS = jsLiteralString . show+    showbJS = jsRepeatDirection -jsRepeatDirection :: RepeatDirection -> String-jsRepeatDirection = showJS+jsRepeatDirection :: RepeatDirection -> Builder+jsRepeatDirection = jsLiteralBuilder . showb  instance JSArg Text where-  showJS = jsLiteralString . unpack+    showbJS = jsText -jsText :: Text -> String-jsText = showJS+jsText :: Text -> Builder+jsText = jsLiteralBuilder . fromText  instance JSArg TextAnchorAlignment where-  showJS = jsLiteralString . show+    showbJS = jsTextAnchorAlignment -jsTextAnchorAlignment :: TextAnchorAlignment -> String-jsTextAnchorAlignment = showJS+jsTextAnchorAlignment :: TextAnchorAlignment -> Builder+jsTextAnchorAlignment = jsLiteralBuilder . showb  instance JSArg TextBaselineAlignment where-  showJS = jsLiteralString . show+    showbJS = jsTextBaselineAlignment -jsTextBaselineAlignment :: TextBaselineAlignment -> String-jsTextBaselineAlignment = showJS+jsTextBaselineAlignment :: TextBaselineAlignment -> Builder+jsTextBaselineAlignment = jsLiteralBuilder . showb --- The following was from our Sunroof compiler.+-- The following was adapted from our Sunroof compiler. -- ---------------------------------------------------------------- String Conversion Utilities: Haskell -> JS+-- Builder Conversion Utilities: Haskell -> JS -- ------------------------------------------------------------- --- | Transform a Haskell string into a string representing a JS string literal.-jsLiteralString :: String -> String-jsLiteralString = jsQuoteString . jsEscapeString+-- | Convert a 'Builder' to a representation as a JS string literal.+jsLiteralBuilder :: Builder -> Builder+jsLiteralBuilder = jsQuoteBuilder . jsEscapeBuilder --- | Add quotes to a string.-jsQuoteString :: String -> String-jsQuoteString s = "\"" ++ s ++ "\""+-- | Add quotes to a 'Builder'.+jsQuoteBuilder :: Builder -> Builder+jsQuoteBuilder b = B.singleton '"' <> b <> B.singleton '"' --- | Transform a character to a string that represents its JS+-- | Transform a character to a lazy 'TL.Text' that represents its JS --   unicode escape sequence.-jsUnicodeChar :: Char -> String+jsUnicodeChar :: Char -> TL.Text jsUnicodeChar c =-  let hex = showHex (ord c) ""-  in ('\\':'u': replicate (4 - length hex) '0') ++ hex+    let hex = toLazyText . showbHex $ ord c+    in "\\u" <> TL.replicate (4 - TL.length hex) (TL.singleton '0') <> hex +-- | Correctly replace a `Builder'`s characters by the JS escape sequences.+jsEscapeBuilder :: Builder -> Builder+jsEscapeBuilder = fromLazyText . TL.concatMap jsEscapeChar . toLazyText+ -- | 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+jsEscapeChar :: Char -> TL.Text+jsEscapeChar '\\' = "\\\\"+-- Special control sequences.+jsEscapeChar '\0' = jsUnicodeChar '\0' -- Ambigous with numbers+jsEscapeChar '\a' = jsUnicodeChar '\a' -- Non JS+jsEscapeChar '\b' = "\\b"+jsEscapeChar '\f' = "\\f"+jsEscapeChar '\n' = "\\n"+jsEscapeChar '\r' = "\\r"+jsEscapeChar '\t' = "\\t"+jsEscapeChar '\v' = "\\v"+jsEscapeChar '\"' = "\\\""+jsEscapeChar '\'' = "\\'"+-- Non-control ASCII characters can remain as they are.+jsEscapeChar c' | not (isControl c') && isAscii c' = TL.singleton c'+-- All other non ASCII signs are escaped to unicode.+jsEscapeChar c' = jsUnicodeChar c'

@@ -0,0 +1,82 @@+module Graphics.Blank.Parser where++import Control.Applicative hiding (many, optional)++import Data.Char+import Data.Ix+import Data.Functor (void)++import Text.ParserCombinators.ReadP+import Text.ParserCombinators.ReadPrec (ReadPrec, readPrec_to_P)++-- | @maybeRead p@ will either parse @p@ or return 'Nothing' without consuming any+--   input. Compare to 'option' from "Text.ParserCombinators.ReadP".+maybeRead :: ReadP a -> ReadP (Maybe a)+maybeRead p = (Just <$> p) <|> return Nothing++-- | @maybeReadPrec p@ will either parse @p@ or return 'Nothing' without consuming any+--   input. Compare to 'option' from "Text.ParserCombinators.ReadP".+maybeReadPrec :: ReadPrec a -> ReadPrec (Maybe a)+maybeReadPrec p = (Just <$> p) <|> return Nothing++-- | A case-insensitive version of 'string' from "Text.ParserCombinators.ReadP".+stringCI :: String -> ReadP String+stringCI this = look >>= scan this+  where+    scan :: String -> String -> ReadP String+    scan []     _                = return this+    scan (x:xs) (y:ys)+        | toLower x == toLower y = get *> scan xs ys+    scan _      _                = pfail++-- | Convert a 'ReadPrec' to a 'ReadP' (the converse of 'lift').+unlift :: ReadPrec a -> ReadP a+unlift = flip readPrec_to_P 0++-- | Equivalent to the function from @parsec@, but using 'ReadP'.+noneOf :: [Char] -> ReadP Char+noneOf cs = satisfy $ \c -> not $ elem c cs++-------------------------------------------------------------------------------+-- Parser combinators for CSS identifiers. Adapted from the hxt-css package.+-------------------------------------------------------------------------------++-- | Parses a CSS identifier.+cssIdent :: ReadP String+cssIdent = (:) <$> nmstart <*> many nmchar++-- | Parses the beginning character of a CSS identifier.+nmstart :: ReadP Char+nmstart = satisfy p <|> nonascii+  where+    p c = inRange ('a', 'z') c || inRange ('A', 'Z') c || c == '_'++-- | Parses a non-beginning CSS identifier character.+nmchar :: ReadP Char+nmchar = satisfy p <|> nonascii+  where+    p c = inRange ('a', 'z') c || inRange ('A', 'Z') c ||+        isDigit c || elem c "_-"++-- | Parses a CSS string literal.+stringLit :: ReadP String+stringLit = string1 <|> string2+  where+    string1 = char '"'+           *> many (noneOf "\n\r\f\\\"" <|> nl <|> nonascii)+           <* char '*'+    string2 = char '\''+           *> many (noneOf "\n\r\f\\'"  <|> nl <|> nonascii)+           <* char '\''++-- | Parses a non-ASCII CSS character.+nonascii :: ReadP Char+nonascii = satisfy (> '\DEL')++-- | Parses a CSS-style newline.+nl :: ReadP Char+nl = choice+    [ void $ char '\n'+    , char '\r' >> optional (char '\n')+    , void $ char '\f'+    ] >> return '\n'

@@ -1,172 +1,193 @@+{-|+Module:      Graphics.Blank.Style+Copyright:   (C) 2014-2015, The University of Kansas+License:     BSD-style (see the file LICENSE)+Maintainer:  Andy Gill+Stability:   Beta+Portability: GHC++This module exposes overloaded versions of @blank-canvas@ functions that take a+style or color as an argument, which may be of interest if you desire stronger+type safety than @Text@ provides.++Note that this module exports function names that conflict with "Graphics.Blank".+Make sure to hide any functions from "Graphics.Blank" that you use from this+module.+-} module Graphics.Blank.Style -        ( -- * Overloaded versions of 'Canvas' functions-          strokeStyle-        , fillStyle-        , 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+    ( -- * Overloaded versions of 'Canvas' functions+      strokeStyle+    , fillStyle+    , shadowColor+    , addColorStop+    , Style(..)+    , CanvasColor+      -- * 'CanvasColor' creation+    , rgb+    , rgbPercent+    , rgba+    , rgbaPercent+    , hsl+    , hsla+      -- * @colour@ reexports+      -- ** 'Colour' and 'AlphaColour'+    , Colour+    , AlphaColour+    , transparent+    , readColourName+      -- ** CSS Level 1 colors+    , aqua+    , black+    , blue+    , fuchsia+    , gray+    , green+    , lime+    , maroon+    , navy+    , olive+    , purple+    , red+    , silver+    , teal+    , white+    , yellow+      -- ** CSS Level 2 color+    , orange+      -- ** CSS Color Module Level 3 colors+    , aliceblue+    , antiquewhite+    , aquamarine+    , azure+    , beige+    , bisque+    , blanchedalmond+    , 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+    , gainsboro+    , ghostwhite+    , gold+    , goldenrod+    , 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+    , limegreen+    , linen+    , magenta+    , mediumaquamarine+    , mediumblue+    , mediumorchid+    , mediumpurple+    , mediumseagreen+    , mediumslateblue+    , mediumspringgreen+    , mediumturquoise+    , mediumvioletred+    , midnightblue+    , mintcream+    , mistyrose+    , moccasin+    , navajowhite+    , oldlace+    , olivedrab+    , orangered+    , orchid+    , palegoldenrod+    , palegreen+    , paleturquoise+    , palevioletred+    , papayawhip+    , peachpuff+    , peru+    , pink+    , plum+    , powderblue+    , rosybrown+    , royalblue+    , saddlebrown+    , salmon+    , sandybrown+    , seagreen+    , seashell+    , sienna+    , skyblue+    , slateblue+    , slategray+    , slategrey+    , snow+    , springgreen+    , steelblue+    , tan+    , thistle+    , tomato+    , turquoise+    , violet+    , wheat+    , whitesmoke+    , yellowgreen+      -- ** CSS Color Module Level 4 color+    , rebeccapurple+    ) where  import qualified Data.Colour as Colour import           Data.Colour hiding (black, transparent)@@ -179,31 +200,21 @@ import           Graphics.Blank.Canvas import           Graphics.Blank.Generated import           Graphics.Blank.JavaScript+import           Graphics.Blank.Types  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+-- | 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.+-- | Specifies a 'Colour' by its red, green, and blue components, where each component+-- is given by a percentage (which should be between 0% to 100%) 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.+-- | Specifies an 'AlphaColour' by its RGB components and an alpha value. --  -- @ -- 'rgba' r g b 0.0 = 'transparent'@@ -211,8 +222,8 @@ 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.+-- | Specifies an 'AlphaColour' by its RGB component percentages (which should be+-- between 0% and 100%) and an alpha value. --  -- @ -- 'rgbaPercent' r g b 0.0 = 'transparent'@@ -220,19 +231,18 @@ 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+-- | Specifies a 'Colour' by its hue, saturation, and lightness value, where+-- saturation and lightness are percentages between 0% and 100%.+hsl :: Degrees -> 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.+-- Specifies an 'AlphaColour' by its HSL values and an alpha value. --  -- @ -- 'hsla' h s v 0.0 = 'transparent' -- @-hsla :: Int -> Percentage -> Percentage -> Alpha -> AlphaColour Double+hsla :: Degrees -> Percentage -> Percentage -> Alpha -> AlphaColour Double hsla h s l = withOpacity $ hsl h s l  -- |@@ -534,7 +544,7 @@ lightgreen :: Colour Double lightgreen = Names.lightgreen --- | @#D3D3D3@, @rgb(211, 211, 211)@, @hsl(0, 0%, 83%)@. Same as 'lightgrey'.+-- | @#D3D3D3@, @rgb(211, 211, 211)@, @hsl(0, 0%, 83%)@. Same as 'lightgray'. lightgrey :: Colour Double lightgrey = Names.lightgrey 

@@ -0,0 +1,19 @@+module Graphics.Blank.Types where++-- | A value representing a percentage (e.g., @0.0@ represents 0%,+-- @100.0@ represents 100%, etc.).+type Percentage = Double++-- | A normalized percentage value (e.g., @0.0@ represent 0%, @1.0@+-- represents 100%, etc.).+type Interval = Double++-- | An interval representing a color's translucency. 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 = Interval++-- | An angle type in which 360° represents one complete rotation.+type Degrees = Double++-- | An angle type in which 2π radians represents one complete rotation.+type Radians = Double

@@ -0,0 +1,155 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeSynonymInstances #-}+module Graphics.Blank.Types.CSS where++import           Data.Monoid ((<>))+import           Data.String++import           Graphics.Blank.JavaScript+import           Graphics.Blank.Parser+import           Graphics.Blank.Types++import           Prelude.Compat++import           Text.ParserCombinators.ReadP (choice)+import           Text.ParserCombinators.ReadPrec (lift)+import           Text.Read (Read(..), readListPrecDefault)++import           TextShow (TextShow(..), FromTextShow(..))++-- | Denotes CSS distance measurements, especially in the context of 'Font's.+data Length = Em   { runLength :: Double } -- ^ The height of the current font.+            | Ex   { runLength :: Double } -- ^ The height of the character @x@ (x-height) in the current font.+            | Ch   { runLength :: Double } -- ^ The width of the character @0@ in the current font.+            | Rem  { runLength :: Double } -- ^ The height of the font relative to the root element.+            | Vh   { runLength :: Double } -- ^ One percent of the height of the viewport.+            | Vw   { runLength :: Double } -- ^ One percent of the width of the viewport.+            | Vmin { runLength :: Double } -- ^ One percent of the minimum of the viewport height and width.+            | Vmax { runLength :: Double } -- ^ One percent of the maximum of the viewport height and width.+            | Px   { runLength :: Double } -- ^ One device pixel (dot) of the display.+            | Mm   { runLength :: Double } -- ^ One millimeter.+            | Cm   { runLength :: Double } -- ^ One centimeter (10 millimeters).+            | In   { runLength :: Double } -- ^ One inch (~2.54 centimeters).+            | Pt   { runLength :: Double } -- ^ One point (1/72 inches).+            | Pc   { runLength :: Double } -- ^ One pica (12 points).+  deriving (Eq, Ord)++-- | Designates CSS properties that can consist of a 'Length'.+class LengthProperty a where+    -- Create a CSS property value from a 'Length'.+    fromLength :: Length -> a++instance LengthProperty Length where+    fromLength = id++-- | Constructs a 'LengthProperty' value with 'Em' units.+em :: LengthProperty a => Double -> a+em = fromLength . Em++-- | Constructs a 'LengthProperty' value with 'Ex' units.+ex :: LengthProperty a => Double -> a+ex = fromLength . Ex++-- | Constructs a 'LengthProperty' value with 'Ch' units.+ch :: LengthProperty a => Double -> a+ch = fromLength . Ch++-- | Constructs a 'LengthProperty' value with 'Rem' units. 'rem_' has an underscore+-- to distinguish it from 'rem'.+rem_ :: LengthProperty a => Double -> a+rem_ = fromLength . Rem++-- | Constructs a 'LengthProperty' value with 'Vh' units.+vh :: LengthProperty a => Double -> a+vh = fromLength . Vh++-- | Constructs a 'LengthProperty' value with 'Vw' units.+vw :: LengthProperty a => Double -> a+vw = fromLength . Vw++-- | Constructs a 'LengthProperty' value with 'Em' units.+vmin :: LengthProperty a => Double -> a+vmin = fromLength . Vmin++-- | Constructs a 'LengthProperty' value with 'Vmax' units.+vmax :: LengthProperty a => Double -> a+vmax = fromLength . Vmax++-- | Constructs a 'LengthProperty' value with 'Px' units.+px :: LengthProperty a => Double -> a+px = fromLength . Px++-- | Constructs a 'LengthProperty' value with 'Mm' units.+mm :: LengthProperty a => Double -> a+mm = fromLength . Mm++-- | Constructs a 'LengthProperty' value with 'Cm' units.+cm :: LengthProperty a => Double -> a+cm = fromLength . Cm++-- | Constructs a 'LengthProperty' value with 'Im' units. This function has an+--   underscore to distinguish it from the Haskell keyword.+in_ :: LengthProperty a => Double -> a+in_ = fromLength . In++-- | Constructs a 'LengthProperty' value with 'Pt' units.+pt :: LengthProperty a => Double -> a+pt = fromLength . Pt++-- | Constructs a 'LengthProperty' value with 'Pc' units.+pc :: LengthProperty a => Double -> a+pc = fromLength . Pc++instance IsString Length where+    fromString = read++instance Read Length where+    readPrec = do+        d <- readPrec+        lift $ choice+            [ Em d   <$ stringCI "em"+            , Ex d   <$ stringCI "ex"+            , Ch d   <$ stringCI "ch"+            , Rem d  <$ stringCI "rem"+            , Vh d   <$ stringCI "vh"+            , Vw d   <$ stringCI "vw"+            , Vmin d <$ stringCI "vmin"+            , Vmax d <$ stringCI "vmax"+            , Px d   <$ stringCI "px"+            , Mm d   <$ stringCI "mm"+            , Cm d   <$ stringCI "cm"+            , In d   <$ stringCI "in"+            , Pt d   <$ stringCI "pt"+            , Pc d   <$ stringCI "pc"+            ]+    readListPrec = readListPrecDefault++instance Show Length where+    showsPrec p = showsPrec p . FromTextShow++instance TextShow Length where+    showb l = jsDouble (runLength l) <> showbUnits l+      where+        showbUnits (Em   _) = "em"+        showbUnits (Ex   _) = "ex"+        showbUnits (Ch   _) = "ch"+        showbUnits (Rem  _) = "rem"+        showbUnits (Vh   _) = "vh"+        showbUnits (Vw   _) = "vw"+        showbUnits (Vmin _) = "vmin"+        showbUnits (Vmax _) = "vmax"+        showbUnits (Px   _) = "px"+        showbUnits (Mm   _) = "mm"+        showbUnits (Cm   _) = "cm"+        showbUnits (In   _) = "in"+        showbUnits (Pt   _) = "pt"+        showbUnits (Pc   _) = "pc"++-- | Designates CSS properties that can consist of a 'Percentage'.+class PercentageProperty a where+    -- | Create a CSS property value from a 'Percentage'.+    percent :: Percentage -> a++instance PercentageProperty Percentage where+    percent = id

@@ -0,0 +1,337 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+module Graphics.Blank.Types.Cursor where++import           Data.Monoid+import           Data.String (IsString(..))+import qualified Data.Text as TS (Text)+import           Data.Text (pack)++import           Graphics.Blank.JavaScript+import           Graphics.Blank.Parser (stringCI, unlift)++import           Prelude.Compat++import           Text.ParserCombinators.ReadP (ReadP, (<++), between, char,+                                               choice, munch, skipSpaces)+import           Text.ParserCombinators.ReadPrec (lift)+import           Text.Read (Read(..), readListPrecDefault)++import           TextShow++-- | A data type that can represent a browser cursor.+class CanvasCursor a where+    -- | Convert a value into a JavaScript string representing a cursor value.+    jsCanvasCursor :: a -> Builder++instance CanvasCursor TS.Text where+    jsCanvasCursor = jsText++instance CanvasCursor Cursor where+    jsCanvasCursor = jsCursor++-- | Specified the mouse cursor's appearance in a web browser.+-- +-- Images by the Mozilla Developer Network are licensed under+-- <http://creativecommons.org/licenses/by-sa/2.5/ CC-BY-SA 2.5>.+data Cursor = Auto         -- ^ The browser determines the cursor to display based on the+                           --   current context.+            | Default      -- ^ <<https://developer.mozilla.org/@api/deki/files/3438/=default.gif>>+            | None         -- ^ No cursor is rendered.+            | ContextMenu  -- ^ <<https://developer.mozilla.org/@api/deki/files/3461/=context-menu.png>>+            | Help         -- ^ <<https://developer.mozilla.org/@api/deki/files/3442/=help.gif>>+            | Pointer      -- ^ <<https://developer.mozilla.org/@api/deki/files/3449/=pointer.gif>>+            | Progress     -- ^ <<https://developer.mozilla.org/@api/deki/files/3450/=progress.gif>>+            | Wait         -- ^ <<https://developer.mozilla.org/@api/deki/files/3457/=wait.gif>>+            | Cell         -- ^ <<https://developer.mozilla.org/@api/deki/files/3434/=cell.gif>>+            | Crosshair    -- ^ <<https://developer.mozilla.org/@api/deki/files/3437/=crosshair.gif>>+            | Text         -- ^ <<https://developer.mozilla.org/files/3809/text.gif>>+            | VerticalText -- ^ <<https://developer.mozilla.org/@api/deki/files/3456/=vertical-text.gif>>+            | Alias        -- ^ <<https://developer.mozilla.org/@api/deki/files/3432/=alias.gif>>+            | Copy         -- ^ <<https://developer.mozilla.org/@api/deki/files/3436/=copy.gif>>+            | Move         -- ^ <<https://developer.mozilla.org/@api/deki/files/3443/=move.gif>>+            | NoDrop       -- ^ <<https://developer.mozilla.org/@api/deki/files/3445/=no-drop.gif>>+            | NotAllowed   -- ^ <<https://developer.mozilla.org/@api/deki/files/3446/=not-allowed.gif>>+            | AllScroll    -- ^ <<https://developer.mozilla.org/@api/deki/files/3433/=all-scroll.gif>>+            | ColResize    -- ^ <<https://developer.mozilla.org/@api/deki/files/3435/=col-resize.gif>>+            | RowResize    -- ^ <<https://developer.mozilla.org/@api/deki/files/3451/=row-resize.gif>>+            | NResize      -- ^ <<https://developer.mozilla.org/files/4083/n-resize.gif>>+            | EResize      -- ^ <<https://developer.mozilla.org/files/4085/e-resize.gif>>+            | SResize      -- ^ <<https://developer.mozilla.org/files/4087/s-resize.gif>>+            | WResize      -- ^ <<https://developer.mozilla.org/files/4089/w-resize.gif>>+            | NEResize     -- ^ <<https://developer.mozilla.org/files/4091/ne-resize.gif>>+            | NWResize     -- ^ <<https://developer.mozilla.org/files/4093/nw-resize.gif>>+            | SEResize     -- ^ <<https://developer.mozilla.org/files/4097/se-resize.gif>>+            | SWResize     -- ^ <<https://developer.mozilla.org/files/4095/sw-resize.gif>>+            | EWResize     -- ^ <<https://developer.mozilla.org/files/3806/3-resize.gif>>+            | NSResize     -- ^ <<https://developer.mozilla.org/files/3808/6-resize.gif>>+            | NESWResize   -- ^ <<https://developer.mozilla.org/files/3805/1-resize.gif>>+            | NWSEResize   -- ^ <<https://developer.mozilla.org/files/3807/4-resize.gif>>+            | ZoomIn       -- ^ <<https://developer.mozilla.org/@api/deki/files/3459/=zoom-in.gif>>+            | ZoomOut      -- ^ <<https://developer.mozilla.org/@api/deki/files/3460/=zoom-out.gif>>+            | Grab         -- ^ <<https://developer.mozilla.org/@api/deki/files/3440/=grab.gif>>+            | Grabbing     -- ^ <<https://developer.mozilla.org/@api/deki/files/3441/=grabbing.gif>>+            | URL TS.Text Cursor+              -- ^ An image from a URL. Must be followed by another 'Cursor'.+    deriving (Eq, Ord)++instance IsString Cursor where+    fromString = read++instance JSArg Cursor where+    showbJS = jsCursor++jsCursor :: Cursor -> Builder+jsCursor = jsLiteralBuilder . showb++instance Read Cursor where+    readPrec = lift $ do+        skipSpaces+        choice+          [ Auto         <$ stringCI "auto"+          , Default      <$ stringCI "default"+          , None         <$ stringCI "none"+          , ContextMenu  <$ stringCI "context-menu"+          , Help         <$ stringCI "help"+          , Pointer      <$ stringCI "pointer"+          , Progress     <$ stringCI "progress"+          , Wait         <$ stringCI "wait"+          , Cell         <$ stringCI "cell"+          , Crosshair    <$ stringCI "crosshair"+          , Text         <$ stringCI "text"+          , VerticalText <$ stringCI "vertical-text"+          , Alias        <$ stringCI "alias"+          , Copy         <$ stringCI "copy"+          , Move         <$ stringCI "move"+          , NoDrop       <$ stringCI "no-drop"+          , NotAllowed   <$ stringCI "not-allowed"+          , AllScroll    <$ stringCI "all-scroll"+          , ColResize    <$ stringCI "col-resize"+          , RowResize    <$ stringCI "row-resize"+          , NResize      <$ stringCI "n-resize"+          , EResize      <$ stringCI "e-resize"+          , SResize      <$ stringCI "s-resize"+          , WResize      <$ stringCI "w-resize"+          , NEResize     <$ stringCI "ne-resize"+          , NWResize     <$ stringCI "nw-resize"+          , SEResize     <$ stringCI "se-resize"+          , SWResize     <$ stringCI "sw-resize"+          , EWResize     <$ stringCI "ew-resize"+          , NSResize     <$ stringCI "ns-resize"+          , NESWResize   <$ stringCI "nesw-resize"+          , NWSEResize   <$ stringCI "nwse-resize"+          , ZoomIn       <$ stringCI "zoom-in"+          , ZoomOut      <$ stringCI "zoom-out"+          , Grab         <$ stringCI "grab"+          , Grabbing     <$ stringCI "grabbing"+          , do _ <- stringCI "url("+               let quoted quote = between (char quote) (char quote)+               url' <- quoted '"' (readURL $ Just '"')+                 <++ quoted '\'' (readURL $ Just '\'')+                 <++ readURL Nothing+               _ <- char ')'+               skipSpaces+               _ <- char ','+               URL url' <$> unlift readPrec+          ]+    +    readListPrec = readListPrecDefault++readURL :: Maybe Char -> ReadP TS.Text+readURL mQuote = do+    url' <- case mQuote of+        Just quote -> munch (/= quote)+        Nothing    -> munch (/= ')')+    return $ pack url'++instance Show Cursor where+    showsPrec p = showsPrec p . FromTextShow++instance TextShow Cursor where+    showb Auto         = "auto"+    showb Default      = "default"+    showb None         = "none"+    showb ContextMenu  = "context-menu"+    showb Help         = "help"+    showb Pointer      = "pointer"+    showb Progress     = "progress"+    showb Wait         = "wait"+    showb Cell         = "cell"+    showb Crosshair    = "crosshair"+    showb Text         = "text"+    showb VerticalText = "vertical-text"+    showb Alias        = "alias"+    showb Copy         = "copy"+    showb Move         = "move"+    showb NoDrop       = "no-drop"+    showb NotAllowed   = "not-allowed"+    showb AllScroll    = "all-scroll"+    showb ColResize    = "col-resize"+    showb RowResize    = "row-resize"+    showb NResize      = "n-resize"+    showb EResize      = "e-resize"+    showb SResize      = "s-resize"+    showb WResize      = "w-resize"+    showb NEResize     = "ne-resize"+    showb NWResize     = "nw-resize"+    showb SEResize     = "se-resize"+    showb SWResize     = "sw-resize"+    showb EWResize     = "ew-resize"+    showb NSResize     = "ns-resize"+    showb NESWResize   = "nesw-resize"+    showb NWSEResize   = "nwse-resize"+    showb ZoomIn       = "zoom-in"+    showb ZoomOut      = "zoom-out"+    showb Grab         = "grab"+    showb Grabbing     = "grabbing"+    showb (URL url' cur) =+        "url(" <> jsLiteralBuilder (fromText url') <> "), " <> showb cur++-- | Shorthand for 'Auto'.+auto :: Cursor+auto = Auto++-- | Shorthand for 'Default', with an underscore to distinguish it from the+-- Haskell keyword @default@.+default_ :: Cursor+default_ = Default++-- | Shorthand for 'None'.+none :: Cursor+none = None++-- | Shorthand for 'ContextMenu'.+contextMenu :: Cursor+contextMenu = ContextMenu++-- | Shorthand for 'Help'.+help :: Cursor+help = Help++-- | Shorthand for 'Pointer'.+pointer :: Cursor+pointer = Pointer++-- | Shorthand for 'Progress'.+progress :: Cursor+progress = Progress++-- | Shorthand for 'Wait'.+wait :: Cursor+wait = Wait++-- | Shorthand for 'Cell'.+cell :: Cursor+cell = Cell++-- | Shorthand for 'Crosshair'.+crosshair :: Cursor+crosshair = Crosshair++-- | Shorthand for 'Text'.+text :: Cursor+text = Text++-- | Shorthand for 'VerticalText'.+verticalText :: Cursor+verticalText = VerticalText++-- | Shorthand for 'Alias'.+alias :: Cursor+alias = Alias++-- | Shorthand for 'Copy'.+copy :: Cursor+copy = Copy++-- | Shorthand for 'Move'.+move :: Cursor+move = Move++-- | Shorthand for 'NoDrop'.+noDrop :: Cursor+noDrop = NoDrop++-- | Shorthand for 'NotAllowed'.+notAllowed :: Cursor+notAllowed = NotAllowed++-- | Shorthand for 'AllScroll'.+allScroll :: Cursor+allScroll = AllScroll++-- | Shorthand for 'ColResize'.+colResize :: Cursor+colResize = ColResize++-- | Shorthand for 'RowResize'.+rowResize :: Cursor+rowResize = RowResize++-- | Shorthand for 'NResize'.+nResize :: Cursor+nResize = NResize++-- | Shorthand for 'EResize'.+eResize :: Cursor+eResize = EResize++-- | Shorthand for 'SResize'.+sResize :: Cursor+sResize = SResize++-- | Shorthand for 'WResize'.+wResize :: Cursor+wResize = WResize++-- | Shorthand for 'NEResize'.+neResize :: Cursor+neResize = NEResize++-- | Shorthand for 'NWResize'.+nwResize :: Cursor+nwResize = NWResize++-- | Shorthand for 'SEResize'.+seResize :: Cursor+seResize = SEResize++-- | Shorthand for 'SWResize'.+swResize :: Cursor+swResize = SWResize++-- | Shorthand for 'EWResize'.+ewResize :: Cursor+ewResize = ewResize++-- | Shorthand for 'NSResize'.+nsResize :: Cursor+nsResize = NSResize++-- | Shorthand for 'NESWResize'.+neswResize :: Cursor+neswResize = NESWResize++-- | Shorthand for 'NWSEResize'.+nwseResize :: Cursor+nwseResize = NWSEResize++-- | Shorthand for 'ZoomIn'.+zoomIn :: Cursor+zoomIn = ZoomIn++-- | Shorthand for 'ZoomOut'.+zoomOut :: Cursor+zoomOut = ZoomOut++-- | Shorthand for 'Grab'.+grab :: Cursor+grab = Grab++-- | Shorthand for 'Grabbing'.+grabbing :: Cursor+grabbing = Grabbing++-- | Shorthand for 'URL'.+url :: TS.Text -> Cursor -> Cursor+url = URL

@@ -0,0 +1,679 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+module Graphics.Blank.Types.Font where++import           Control.Applicative+import           Control.Monad++import           Data.Char+import           Data.Default.Class+import           Data.Ix (Ix)+import           Data.Maybe+import           Data.Monoid+import           Data.String+import qualified Data.Text as TS+import           Data.Text (Text)+import qualified Data.Text.Lazy.Builder as B (singleton)++import           Graphics.Blank.JavaScript+import           Graphics.Blank.Parser+import           Graphics.Blank.Types+import           Graphics.Blank.Types.CSS++import qualified Text.ParserCombinators.ReadP as ReadP+import           Text.ParserCombinators.ReadP hiding ((<++), choice, pfail)+import qualified Text.ParserCombinators.ReadPrec as ReadPrec+import           Text.ParserCombinators.ReadPrec (ReadPrec, (<++), lift, pfail)+import           Text.Read (Read(..), readListPrecDefault)++import           TextShow (TextShow(..), Builder, FromTextShow(..), showbSpace)++-------------------------------------------------------------------------------++-- | A data type that can represent a browser font.+class CanvasFont a where+    -- | Convert a value into a JavaScript string representing a font value.+    jsCanvasFont :: a -> Builder++instance CanvasFont Text where+    jsCanvasFont = jsText++instance CanvasFont Font where+    jsCanvasFont = jsFont++-------------------------------------------------------------------------------++-- | A CSS-style font data type.+data Font = FontProperties+  {   fontStyle   :: FontStyle+    , fontVariant :: FontVariant+    , fontWeight  :: FontWeight+    , fontSize    :: FontSize+    , lineHeight  :: LineHeight+    , fontFamily  :: [FontFamily]+  } -- ^ A font specified by its individual longhand properties.+  | CaptionFont      -- ^ The font used for captioned controls (e.g., buttons, drop-downs, etc.)+  | IconFont         -- ^ The font used to label icons.+  | MenuFont         -- ^ The font used in menus (e.g., dropdown menus and menu lists).+  | MessageBoxFont   -- ^ The font used in dialog boxes.+  | SmallCaptionFont -- ^ The font used for labeling small controls.+  | StatusBarFont    -- ^ The font used in window status bars.+  deriving (Eq, Ord)++-- |+-- Creates a new font from the 'FontFamily' list, using the 'Default' instances+-- for the other five longhand properties. If you only wish to change certain+-- properties and leave the others alone, this provides a convenient mechanism+-- for doing so:+-- +-- @+-- ('defFont' ["Gill Sans Extrabold", 'sansSerif']) {+--     'fontStyle'  = 'italic'+--   , 'fontSize'   = 12 # 'px'+--   , 'lineHeight' = 14 # 'px'+-- }+-- @+defFont :: [FontFamily] -> Font+defFont = FontProperties def def def def def++-- | Shorthand for 'CaptionFont'.+caption :: Font+caption = CaptionFont++-- | Shorthand for 'IconFont'.+icon :: Font+icon = IconFont++-- | Shorthand for 'MenuFont'.+menu :: Font+menu = MenuFont++-- | Shorthand for 'MessageBoxFont'.+messageBox :: Font+messageBox = MessageBoxFont++-- | Shorthand for 'SmallCaptionFont'.+smallCaption :: Font+smallCaption = SmallCaptionFont++-- | Shorthand for 'StatusBarFont'.+statusBar :: Font+statusBar = StatusBarFont++instance IsString Font where+    fromString = read++instance JSArg Font where+    showbJS = jsFont++jsFont :: Font -> Builder+jsFont = jsLiteralBuilder . showb++instance Read Font where+    readPrec = do+        lift skipSpaces+        ReadPrec.choice+            [ CaptionFont      <$ lift (stringCI "caption")+            , IconFont         <$ lift (stringCI "icon")+            , MenuFont         <$ lift (stringCI "menu")+            , MessageBoxFont   <$ lift (stringCI "message-box")+            , SmallCaptionFont <$ lift (stringCI "small-caption")+            , StatusBarFont    <$ lift (stringCI "status-bar")+            , readFontProperties Nothing Nothing Nothing+            ]+    readListPrec = readListPrecDefault++-- | Like 'Either', but with three possibilities instead of two.+data OneOfThree a b c = One a | Two b | Three c++-- |+-- The formal syntax for the font CSS property+-- (https://developer.mozilla.org/en-US/docs/Web/CSS/font#Syntax) is surprisingly complex.+-- It requires that font-style, font-variant, and font-weight must be defined, if any,+-- before the font-size value. Furthermore, each of those three properties may only be defined at+-- most once, and the relative order of the three does not matter. This is a tall order for the+-- Text.ParserCombinators modules, so we use a heavily monadic utility function to detect+-- make it easier to catch bad input. The three Maybe arguments each represent whether its+-- respective property has not (Nothing) or has (Just) been read. If it has been read, then+-- readFontProperties will not attempt to parse it again.+-- +-- readFontProperties will proceed to parse the remaining Font longhand properties once+-- either all three of the first properties have been parsed, or when it is unsuccessful at+-- parsing any of the first three properties.+readFontProperties :: Maybe FontStyle -> Maybe FontVariant -> Maybe FontWeight -> ReadPrec Font+readFontProperties style variant weight =+    -- If all three properties have been parsed, proceed to the remaining three properties.+    if isJust style && isJust variant && isJust weight+       then readFontProperties' style variant weight+       else do+               -- If the property has already been parsed, do not parse it again.+           let parseCheck :: Maybe a -> ReadPrec a -> ReadPrec a+               parseCheck mb parser = if isJust mb then pfail else parser+               +               readStyle, readVariant, readWeight :: ReadPrec (OneOfThree FontStyle FontVariant FontWeight)+               readStyle   = One   <$> parseCheck style readPrec+               readVariant = Two   <$> parseCheck variant readPrec+               readWeight  = Three <$> parseCheck weight readPrec+           +           -- First attempt to parse font-style, then font-variant, then font-weight (unless one+           -- of them has already been parsed, in which case skip to the next property parser.+           prop <- maybeReadPrec $ readStyle <++ readVariant <++ readWeight+           -- Check to see which property, if any, was parsed.+           case prop of+               Just (One style') -> do+                   when (isJust style) pfail -- Safeguard to ensure a property is not parsed twice.+                   readFontProperties (Just style') variant weight+               Just (Two variant') -> do+                   when (isJust variant) pfail+                   readFontProperties style (Just variant') weight+               Just (Three weight') -> do+                   when (isJust weight) pfail+                   readFontProperties style variant (Just weight')+               -- If no properties were parsed, proceed to the remaining three properties.+               Nothing -> readFontProperties' style variant weight++-- |+-- Parses the remaining three Font longhand properties (font-size, line-height, and+-- font-family). Make sure to also parse the forward slash, if any, that separates+-- the font-size and line-height properties.+readFontProperties' :: Maybe FontStyle -> Maybe FontVariant -> Maybe FontWeight -> ReadPrec Font+readFontProperties' mbStyle mbVariant mbWeight =+  FontProperties (fromMaybe def mbStyle) (fromMaybe def mbVariant) (fromMaybe def mbWeight)+  <$> readPrec+  <*> lift (option def $ skipSpaces *> char '/' *> unlift readPrec)+  <*> (lift (munch1 isSpace) *> readPrec)++instance Show Font where+    showsPrec p = showsPrec p . FromTextShow++instance TextShow Font where+    showb (FontProperties style variant weight size height' family)+        = showb style+       <> showbSpace+       <> showb variant+       <> showbSpace+       <> showb weight+       <> showbSpace+       <> showb size+       <> B.singleton '/'+       <> showb height'+       <> showbSpace+       <> showb family+    showb CaptionFont      = "caption"+    showb IconFont         = "icon"+    showb MenuFont         = "menu"+    showb MessageBoxFont   = "message-box"+    showb SmallCaptionFont = "small-caption"+    showb StatusBarFont    = "status-bar"++-------------------------------------------------------------------------------++-- | Specifies if a 'Font' is italic or oblique.+data FontStyle = NormalStyle  -- ^ Selects a font classified as normal (default).+               | ItalicStyle  -- ^ Selects a font that is labeled italic, or if one is not available,+                              --   one labeled oblique.+               | ObliqueStyle -- ^ Selects a font that is labeled oblique.+  deriving (Bounded, Enum, Eq, Ix, Ord)++-- | Shorthand for 'ItalicStyle'.+italic :: FontStyle+italic = ItalicStyle++-- | Shorthand for 'ObliqueStyle'.+oblique :: FontStyle+oblique = ObliqueStyle++instance Default FontStyle where+    def = NormalStyle++instance IsString FontStyle where+    fromString = read++instance NormalProperty FontStyle++instance Read FontStyle where+    readPrec = lift $ do+        skipSpaces+        ReadP.choice+            [ NormalStyle  <$ stringCI "normal"+            , ItalicStyle  <$ stringCI "italic"+            , ObliqueStyle <$ stringCI "oblique"+            ]+    readListPrec = readListPrecDefault++instance Show FontStyle where+    showsPrec p = showsPrec p . FromTextShow++instance TextShow FontStyle where+    showb NormalStyle  = "normal"+    showb ItalicStyle  = "italic"+    showb ObliqueStyle = "oblique"++-------------------------------------------------------------------------------++-- | Specifies the face of a 'Font'.+data FontVariant = NormalVariant    -- ^ A normal font face (default).+                 | SmallCapsVariant -- ^ A font face with small capital letters for lowercase characters.+  deriving (Bounded, Enum, Eq, Ix, Ord)++-- | Shorthand for 'SmallCapsVariant'.+smallCaps :: FontVariant+smallCaps = SmallCapsVariant++instance Default FontVariant where+    def = NormalVariant++instance IsString FontVariant where+    fromString = read++instance NormalProperty FontVariant++instance Read FontVariant where+    readPrec = lift $ do+      skipSpaces+      (NormalVariant <$ stringCI "normal") <|> (SmallCapsVariant <$ stringCI "small-caps")+    readListPrec = readListPrecDefault++instance Show FontVariant where+    showsPrec p = showsPrec p . FromTextShow++instance TextShow FontVariant where+    showb NormalVariant    = "normal"+    showb SmallCapsVariant = "small-caps"++-------------------------------------------------------------------------------++-- |+-- Specifies the boldness of a 'Font'. Note that 'FontWeight' is an instance of+-- 'Num' so that the nine numeric weights can be used directly. For example:+-- +-- @+-- ('defFont' ['sansSerif']) { 'fontWeight' = 900 }+-- @+-- +-- Attempting to use a numeric weight other than the nine given will result in+-- a runtime error.+data FontWeight = NormalWeight -- ^ Default.+                | BoldWeight+                | BolderWeight+                | LighterWeight+                | Weight100+                | Weight200+                | Weight300+                | Weight400+                | Weight500+                | Weight600+                | Weight700+                | Weight800+                | Weight900+  deriving (Bounded, Enum, Eq, Ix, Ord)++-- | Shorthand for 'BoldWeight'.+bold :: FontWeight+bold = BoldWeight++-- | Shorthand for 'BolderWeight'.+bolder :: FontWeight+bolder = BolderWeight++-- | Shorthand for 'LighterWeight'.+lighter :: FontWeight+lighter = LighterWeight++fontWeightError :: a+fontWeightError = error "invalid font-weight operation"++instance Default FontWeight where+    def = NormalWeight++instance IsString FontWeight where+    fromString = read++instance NormalProperty FontWeight++instance Num FontWeight where+    (+)    = fontWeightError+    (-)    = fontWeightError+    (*)    = fontWeightError+    abs    = fontWeightError+    signum = fontWeightError+    fromInteger 100 = Weight100+    fromInteger 200 = Weight200+    fromInteger 300 = Weight300+    fromInteger 400 = Weight400+    fromInteger 500 = Weight500+    fromInteger 600 = Weight600+    fromInteger 700 = Weight700+    fromInteger 800 = Weight800+    fromInteger 900 = Weight900+    fromInteger _   = fontWeightError++instance Read FontWeight where+    readPrec = lift $ do+        skipSpaces+        ReadP.choice+            [ NormalWeight  <$ stringCI "normal"+            , BoldWeight    <$ stringCI "bold"+            , BolderWeight  <$ stringCI "bolder"+            , LighterWeight <$ stringCI "lighter"+            , Weight100     <$ string   "100"+            , Weight200     <$ string   "200"+            , Weight300     <$ string   "300"+            , Weight400     <$ string   "400"+            , Weight500     <$ string   "500"+            , Weight600     <$ string   "600"+            , Weight700     <$ string   "700"+            , Weight800     <$ string   "800"+            , Weight900     <$ string   "900"+            ]+    readListPrec = readListPrecDefault++instance Show FontWeight where+    showsPrec p = showsPrec p . FromTextShow++instance TextShow FontWeight where+    showb NormalWeight  = "normal"+    showb BoldWeight    = "bold"+    showb BolderWeight  = "bolder"+    showb LighterWeight = "lighter"+    showb Weight100     = "100"+    showb Weight200     = "200"+    showb Weight300     = "300"+    showb Weight400     = "400"+    showb Weight500     = "500"+    showb Weight600     = "600"+    showb Weight700     = "700"+    showb Weight800     = "800"+    showb Weight900     = "900"++-------------------------------------------------------------------------------++-- | The desired height of 'Font' glyphs.+--+-- ==== __Examples__+--+-- @+-- ('defFont' ['sansSerif']) { 'fontSize' = 'xxSmall' }+-- ('defFont' ['sansSerif']) { 'fontSize' = 30 # 'pt' }+-- ('defFont' ['sansSerif']) { 'fontSize' = 50 # 'percent' }+-- @+data FontSize = XXSmallSize+              | XSmallSize+              | SmallSize+              | MediumSize -- ^ Default.+              | LargeSize+              | XLargeSize+              | XXLargeSize+              | LargerSize+              | SmallerSize+              | FontSizeLength Length+              | FontSizePercentage Percentage+  deriving (Eq, Ord)++-- | Shorthand for 'XXSmallSize'.+xxSmall :: FontSize+xxSmall = XXSmallSize++-- | Shorthand for 'XSmallSize'.+xSmall :: FontSize+xSmall = XSmallSize++-- | Shorthand for 'SmallSize'.+small :: FontSize+small = SmallSize++-- | Shorthand for 'MediumSize'.+medium :: FontSize+medium = MediumSize++-- | Shorthand for 'LargeSize'.+large :: FontSize+large = LargeSize++-- | Shorthand for 'XLargeSize'.+xLarge :: FontSize+xLarge = XLargeSize++-- | Shorthand for 'XXLargeSize'.+xxLarge :: FontSize+xxLarge = XXLargeSize++-- | Shorthand for 'LargerSize'.+larger :: FontSize+larger = LargerSize++-- | Shorthand for 'SmallerSize'.+smaller :: FontSize+smaller = SmallerSize++instance Default FontSize where+    def = MediumSize++instance IsString FontSize where+    fromString = read++instance LengthProperty FontSize where+    fromLength = FontSizeLength++instance PercentageProperty FontSize where+    percent = FontSizePercentage++instance Read FontSize where+    readPrec = do+        lift $ skipSpaces+        ReadPrec.choice+            [ XXSmallSize        <$  lift (stringCI "xx-small")+            , XSmallSize         <$  lift (stringCI "x-small")+            , SmallSize          <$  lift (stringCI "small")+            , MediumSize         <$  lift (stringCI "medium")+            , LargeSize          <$  lift (stringCI "large")+            , XLargeSize         <$  lift (stringCI "x-large")+            , XXLargeSize        <$  lift (stringCI "xx-large")+            , LargerSize         <$  lift (stringCI "larger")+            , SmallerSize        <$  lift (stringCI "smaller")+            , FontSizeLength     <$> readPrec+            , FontSizePercentage <$> readPrec <* lift (char '%')+            ]+    readListPrec = readListPrecDefault++instance Show FontSize where+    showsPrec p = showsPrec p . FromTextShow++instance TextShow FontSize where+    showb XXSmallSize            = "xx-small"+    showb XSmallSize             = "x-small"+    showb SmallSize              = "small"+    showb MediumSize             = "medium"+    showb LargeSize              = "large"+    showb XLargeSize             = "x-large"+    showb XXLargeSize            = "xx-large"+    showb LargerSize             = "larger"+    showb SmallerSize            = "smaller"+    showb (FontSizeLength l)     = showb l+    showb (FontSizePercentage p) = jsDouble p <> B.singleton '%'++-------------------------------------------------------------------------------++-- | The height of the line boxes in a 'Font'.+--+-- ==== __Examples__+--+-- @+-- ('defFont' ['sansSerif']) { 'lineHeight' = 'normal' }+-- ('defFont' ['sansSerif']) { 'lineHeight' = 50 }+-- ('defFont' ['sansSerif']) { 'lineHeight' = 30 # 'em' }+-- ('defFont' ['sansSerif']) { 'lineHeight' = 70 # 'percent' }+-- @+data LineHeight = NormalLineHeight -- ^ Default.+                | LineHeightNumber Double+                | LineHeightLength Length+                | LineHeightPercentage Percentage+  deriving (Eq, Ord)++lineHeightError :: a+lineHeightError = error "no arithmetic for line-height"++instance Default LineHeight where+    def = NormalLineHeight++instance Fractional LineHeight where+    (/)   = lineHeightError+    recip = lineHeightError+    fromRational = LineHeightNumber . fromRational++instance IsString LineHeight where+    fromString = read++instance LengthProperty LineHeight where+    fromLength = LineHeightLength++instance NormalProperty LineHeight++instance Num LineHeight where+    (+)    = lineHeightError+    (-)    = lineHeightError+    (*)    = lineHeightError+    abs    = lineHeightError+    signum = lineHeightError+    fromInteger = LineHeightNumber . fromInteger++instance PercentageProperty LineHeight where+    percent = LineHeightPercentage++instance Read LineHeight where+    readPrec = do+        lift skipSpaces+        ReadPrec.choice+            [ NormalLineHeight     <$  lift (stringCI "normal")+            , LineHeightNumber     <$> readPrec+            , LineHeightLength     <$> readPrec+            , LineHeightPercentage <$> readPrec <* lift (char '%')+            ]+    readListPrec = readListPrecDefault++instance Show LineHeight where+    showsPrec p = showsPrec p . FromTextShow++instance TextShow LineHeight where+    showb NormalLineHeight         = "normal"+    showb (LineHeightNumber n)     = jsDouble n+    showb (LineHeightLength l)     = showb l+    showb (LineHeightPercentage p) = jsDouble p <> B.singleton '%'++-------------------------------------------------------------------------------++-- |+-- The name of a 'Font' family. Note that both 'FontFamily' and @['FontFamily']@+-- are instances of 'IsString', so it is possible to produce 'FontFamily' values+-- in several different ways. For example, these are all of type 'FontFamily':+-- +-- @+-- 'FontFamilyName' "Gill Sans Extrabold"+-- "Gill Sans Extrabold" :: 'FontFamily'+-- 'serif'+-- "serif" :: 'FontFamily'+-- @+-- +-- These are all of type @['FontFamily']@:+-- +-- @+-- ['FontFamilyName' \"Helvetica\", 'serif']+-- [\"Helvetica\", "serif"] :: ['FontFamily']+-- "Helvetica, serif" :: ['FontFamily']+-- @+data FontFamily = FontFamilyName Text -- ^ The name of a custom font family.+                | SerifFamily         -- ^ A generic font family where glyphs have+                                      --   serifed endings.+                | SansSerifFamily     -- ^ A generic font family where glyphs do not+                                      --   have serifed endings.+                | MonospaceFamily     -- ^ A generic font family where all glyphs have+                                      --   the same fixed width.+                | CursiveFamily       -- ^ A generic font family with cursive glyphs.+                | FantasyFamily       -- ^ A generic font family where glyphs have+                                      --   decorative, playful representations.+  deriving (Eq, Ord)++-- | Shorthand for 'SerifFamily'.+serif :: FontFamily+serif = SerifFamily++-- | Shorthand for 'SansSerifFamily'.+sansSerif :: FontFamily+sansSerif = SansSerifFamily++-- | Shorthand for 'MonospaceFamily'.+monospace :: FontFamily+monospace = MonospaceFamily++-- | Shorthand for 'CursiveFamily'.+cursive :: FontFamily+cursive = CursiveFamily++-- | Shorthand for 'FantasyFamily'.+fantasy :: FontFamily+fantasy = FantasyFamily++instance IsString FontFamily where+    fromString = read++-- |+-- There are two separate 'IsString' instances for 'FontFamily' so that single font+-- families and lists of font families alike can be converted from string literals.+instance IsString [FontFamily] where+    fromString = read++instance Read FontFamily where+    readPrec = lift $ do+        skipSpaces+        ReadP.choice+          [ SerifFamily     <$ stringCI "serif"+          , SansSerifFamily <$ stringCI "sans-serif"+          , MonospaceFamily <$ stringCI "monospace"+          , CursiveFamily   <$ stringCI "cursive"+          , FantasyFamily   <$ stringCI "fantasy"+          , let quoted quote = between (char quote) (char quote)+             in quoted '"' (readFontFamily $ Just '"')+                  <|> quoted '\'' (readFontFamily $ Just '\'')+                  <|> readFontFamily Nothing+          ]+    +    -- readListPrec is overloaded so that it will read in a comma-separated list of+    -- family names not delimited by square brackets, as per the CSS syntax.+    readListPrec = lift . sepBy1 (unlift readPrec) $ skipSpaces *> char ','++readFontFamily :: Maybe Char -> ReadP FontFamily+readFontFamily mQuote = do+    name <- case mQuote of+        Just quote -> munch (/= quote)+        Nothing    -> unwords <$> sepBy1 cssIdent (munch1 isSpace)+    return . FontFamilyName $ TS.pack name++instance Show FontFamily where+    showsPrec p = showsPrec p . FromTextShow+    showList    = showsPrec 0 . FromTextShow++instance TextShow FontFamily where+    showb (FontFamilyName name) = showb name+    showb SerifFamily           = "serif"+    showb SansSerifFamily       = "sans-serif"+    showb MonospaceFamily       = "monospace"+    showb CursiveFamily         = "cursive"+    showb FantasyFamily         = "fantasy"+    +    -- Omit the square brackets when showing a list of font families so that+    -- it matches the CSS syntax.+    showbList = jsList showb++-------------------------------------------------------------------------------++-- | A convenient way to use the 'Default' normal value for several 'Font'+-- longhand properties.+class Default a => NormalProperty a where+    -- | The default value for a CSS property. For example, it can be used+    -- like this:+    -- +    -- @+    -- ('defFont' ['sansSerif']) { 'lineHeight' = 'normal' }+    -- @+    normal :: a+    normal = def

@@ -12,7 +12,6 @@ import Graphics.Blank.Generated import Graphics.Blank.JavaScript - -- | Clear the screen. Restores the default transformation matrix. clearCanvas :: Canvas () clearCanvas = do@@ -31,12 +30,12 @@ infixr 0 #  -- | The @#@-operator is the Haskell analog to the @.@-operator---   in Javascript. Example:---+--   in JavaScript. Example:+--  -- > grd # addColorStop(0, "#8ED6FF");---+--  --   This can be seen as equivalent of @grd.addColorStop(0, "#8ED6FF")@.-(#) :: a -> (a -> Canvas b) -> Canvas b+(#) :: a -> (a -> b) -> b (#) obj act = act obj  -- | Read a file, and generate a data URL.@@ -45,14 +44,13 @@ -- readDataURL :: Text -> FilePath -> IO Text readDataURL mime_type filePath = do-	    dat <- B.readFile filePath-	    return $ "data:" <> mime_type <> ";base64," <> decodeUtf8 (encode dat)+    dat <- B.readFile filePath+    return $ "data:" <> mime_type <> ";base64," <> decodeUtf8 (encode dat) --- | Find the mime type for a data URL.---+-- | 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:'"@@ -64,7 +62,6 @@    (mime_type,rest2) = Text.span (/= ';') rest1  -- | Write a data URL to a given file.- writeDataURL :: FilePath -> Text -> IO () writeDataURL fileName              = B.writeFile fileName@@ -98,7 +95,7 @@ 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+-- | Acts like 'putImageDataAt', 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.

@@ -1,4 +1,4 @@-Copyright (c)2014, The University of Kansas+Copyright (c) 2014-2015, The University of Kansas  All rights reserved. 

@@ -35,7 +35,7 @@ |-------|-------| | [Examples](https://github.com/ku-fpg/blank-canvas/wiki/Examples) | Various complete examples of using blank-canvas | | [Installation](https://github.com/ku-fpg/blank-canvas/wiki/Installation) | How to install blank-canvas |-| [Hackage](https://hackage.haskell.org/package/blank-canvas) | Current release is 0.4.0 |+| [Hackage](https://hackage.haskell.org/package/blank-canvas) | Current release is 0.5 | | [API](https://github.com/ku-fpg/blank-canvas/wiki/API) | Discussion of API, compared with the original JavaScript API | | [Canvas Examples](https://github.com/ku-fpg/blank-canvas/wiki/Canvas%20Examples) | Transliterated from <http://www.html5canvastutorials.com/> into Haskell and blank-canvas, with kind permission of Eric Rowell, author of the JavaScript HTML5 Canvas Tutorial. | | [FAQ](https://github.com/ku-fpg/blank-canvas/wiki/FAQ) | F.A.Q. |

@@ -1,17 +1,17 @@ Name:                blank-canvas-Version:             0.5+Version:             0.6 Synopsis:            HTML5 Canvas Graphics Library -Description:      blank-canvas is a Haskell binding to the complete-                  HTML5 Canvas API. blank-canvas allows Haskell-                  users to write, in Haskell, interactive images-                  onto their web browsers. blank-canvas gives the-                  user a single full-window canvas, and provides+Description:      @blank-canvas@ is a Haskell binding to the complete+                  <https://developer.mozilla.org/en-US/docs/Web/API/Canvas_API HTML5 Canvas API>.+                  @blank-canvas@ allows Haskell users to write, in Haskell,+                  interactive images onto their web browsers. @blank-canvas@+                  gives the user a single full-window canvas, and provides                   many well-documented functions for rendering                   images.                   .                   @-		     &#123;-&#35; LANGUAGE OverloadedStrings &#35;-&#125;+                     &#123;-&#35; LANGUAGE OverloadedStrings &#35;-&#125;                      module Main where                      import Graphics.Blank                     -- import the blank canvas                      .@@ -20,14 +20,14 @@                      &#32;&#32;&#32;&#32;moveTo(50,50)                      &#32;&#32;&#32;&#32;lineTo(200,100)                      &#32;&#32;&#32;&#32;lineWidth 10-                     &#32;&#32;&#32;&#32;strokeStyle "red"+                     &#32;&#32;&#32;&#32;strokeStyle \"red\"                      &#32;&#32;&#32;&#32;stroke()                              -- this draws the ink into the canvas                   @-		  .+                  .                   <<https://github.com/ku-fpg/blank-canvas/wiki/images/Red_Line.png>>-		  .-		  For more details, read the <https://github.com/ku-fpg/blank-canvas/wiki blank-canvas wiki>.-		  .+                  .+                  For more details, read the <https://github.com/ku-fpg/blank-canvas/wiki blank-canvas wiki>.+                  . License:             BSD3 License-file:        LICENSE Author:              Andy Gill and Ryan Scott@@ -37,9 +37,9 @@ Bug-reports:         https://github.com/ku-fpg/blank-canvas/issues Category:            Graphics Build-type:          Simple-Stability:           beta+Stability:           Beta Extra-source-files:  README.md-            	     Changelog.md+                     Changelog.md Cabal-version:       >= 1.10 data-files:     static/index.html@@ -48,38 +48,123 @@   Library-  Exposed-modules:     Graphics.Blank,-                       Graphics.Blank.GHCi,+  Exposed-modules:     Graphics.Blank+                       Graphics.Blank.Cursor+                       Graphics.Blank.Font+                       Graphics.Blank.GHCi                        Graphics.Blank.Style-  other-modules:       Graphics.Blank.Canvas,-                       Graphics.Blank.DeviceContext,-                       Graphics.Blank.Events,-                       Graphics.Blank.Generated,-                       Graphics.Blank.JavaScript,-                       Graphics.Blank.Utils,+  other-modules:       Graphics.Blank.Canvas+                       Graphics.Blank.DeviceContext+                       Graphics.Blank.Events+                       Graphics.Blank.Generated+                       Graphics.Blank.JavaScript+                       Graphics.Blank.Parser+                       Graphics.Blank.Types+                       Graphics.Blank.Types.CSS+                       Graphics.Blank.Types.Cursor+                       Graphics.Blank.Types.Font+                       Graphics.Blank.Utils                        Paths_blank_canvas    default-language:    Haskell2010-  build-depends:       aeson              >= 0.7   && < 0.9,+  build-depends:       aeson              >= 0.7     && < 0.11,                        base64-bytestring  == 1.0.*,-                       base               >= 4.3.1 && < 4.8,+                       base               >= 4.6     && < 4.9,+                       base-compat        >= 0.8.1   && < 1,                        bytestring         == 0.10.*,-                       colour             >= 2.2   && < 3.0,+                       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,+                       http-types         >= 0.8     && < 0.10,+                       mime-types         >= 0.1.0.3 && < 0.2,+                       kansas-comet       >= 0.4     && < 0.5,+                       scotty             >= 0.10    && < 0.11,+                       stm                >= 2.2     && < 2.5,+                       text               >= 1.1     && < 1.3,+                       text-show          >= 2       && < 2.2,+                       transformers       >= 0.3     && < 0.5,                        wai                == 3.*,-                       wai-extra          >= 3.0.1 && < 3.1,+                       wai-extra          >= 3.0.1   && < 3.1,                        warp               == 3.*,-                       vector             >= 0.10  && < 0.11+                       vector             >= 0.10    && < 0.12 -  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+  GHC-options:         -Wall+  GHC-prof-options:    -Wall -fsimpl-tick-factor=100000+++test-suite wiki-suite+    build-depends:    base              >= 4.6  && < 4.9,+                      blank-canvas      == 0.6.*,+                      containers        == 0.5.*,+                      process           == 1.2.*,+                      directory         >= 1.2,+                      shake             >= 0.13,+                      stm               >= 2.2  && < 2.5,+                      text              >= 1.1  && < 1.3,+                      time              >= 1.4  && < 1.6,+                      unix              == 2.7.*,+                      vector            >= 0.10 && < 0.12++    default-language: Haskell2010+    GHC-options:      -threaded -Wall+    main-is:          Main.hs+    hs-source-dirs:   wiki-suite+    type:             exitcode-stdio-1.0+    other-modules:    Arc+                      Bezier_Curve+                      Bounce+                      Circle+                      Clipping_Region+                      Color_Fill+                      Color_Square+                      Custom_Shape+                      Custom_Transform+                      Draw_Canvas+                      Draw_Device+                      Draw_Image+                      Favicon+                      Font_Size_and_Style+                      Get_Image_Data_URL+                      Global_Alpha+                      Global_Composite_Operations+                      Grayscale+                      Image_Crop+                      Image_Loader+                      Image_Size+                      Is_Point_In_Path+                      Key_Read+                      Line+                      Line_Cap+                      Line_Color+                      Line_Join+                      Line_Width+                      Linear_Gradient+                      Load_Image_Data_URL+                      Load_Image_Data_URL_2+                      Miter_Limit+                      Path+                      Pattern+                      Quadratic_Curve+                      Radial_Gradient+                      Rectangle+                      Red_Line+                      Rotate_Transform+                      Rotating_Square+                      Rounded_Corners+                      Scale_Transform+                      Semicircle+                      Shadow+                      Square+                      Text_Align+                      Text_Baseline+                      Text_Color+                      Text_Metrics+                      Text_Stroke+                      Text_Wrap+                      Tic_Tac_Toe+                      Translate_Transform+                      Wiki+  source-repository head   type:     git

@@ -11,7 +11,7 @@         <script type="text/javascript">             var session = 0; // global session number             var images = [];-            var gradients = [];+            var sounds = [];             var patterns = [];             var canvasbuffers = [];             var c = null;@@ -57,29 +57,11 @@                 }             } -            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) {-                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) {-                return function (u,c) {-                    var count = patterns.push(c.createPattern(img,src));-                    $.kc.reply(u,count - 1);-                }-            }-             function MeasureText(txt) {                 return function (u,c) {+	            // If we try return the object directly, via json, we+                    // get different results on different browsers.+	            // So we build an object explicity.                     $.kc.reply(u,{ width: c.measureText(txt).width });                 }             }@@ -103,7 +85,7 @@                 return function (u,c) {                     var img = c.getImageData(sx,sy,sw,sh);                     var arr = [];-                    for(var i = 0;i < img.data.length;i++) {+                    for (var i = 0;i < img.data.length;i++) {                         arr[i] = img.data[i];                     }                     $.kc.reply(u,{ width: img.width@@ -113,28 +95,37 @@                 }             } +            function Cursor(cur) {+                return function(u, c) {+                    c.canvas.style.cursor = cur;+                    $.kc.reply(u, []);+                };+            }+             function Sync(u,c) {                 $.kc.reply(u,[]);             }              function Trigger(e) {-		var o = {};-		o.metaKey = e.metaKey;+                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.pageXY != undefined) {+                    o.pageXY = e.pageXY;                 }-                if (e.which != undefined) { -                    o.which = e.which; +                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,Trigger);             }+             function redraw() {                 $.ajax({ url: "/canvas/" + session,                          type: "GET",@@ -152,6 +143,23 @@                 }                 return imgData;              }++            function NewAudio(src) {+                return function (u,c) {+                    var audio = new Audio();+                    var count = sounds.push(audio);+                    // var dur   = audio.duration;+                    //+                    // I commented this out because there's a chance that the browser won't+                    // know the audio duration until it's "loaded" (i.e., it can be played+                    // through). Further testing might be wise.+                    audio.oncanplaythrough = function () {+                        $.kc.reply(u,[count - 1,audio.duration]);+                    };+                    audio.onerror = function() { alert("Audio " + src + " not found.\nAdd as a URL to fix this."); };+                    audio.src = src;+                }+            }              $(document).ready(function() {                 // Make the canvas the size of the window

@@ -0,0 +1,29 @@+{-# LANGUAGE OverloadedStrings #-}+module Arc where++import Graphics.Blank+import Wiki -- (578,200)++main :: IO ()+main = blankCanvas 3000 $ \ context -> do+    send context $ do+        let centerX = width context / 2;+        let centerY = height context / 2;+        let radius = 75;+        let startingAngle = 1.1 * pi+        let endingAngle = 1.9 * pi+        lineWidth 15+        strokeStyle "black"++        beginPath()+        arc(centerX - 50, centerY, radius, startingAngle, endingAngle, False)+        stroke()++        beginPath()+        strokeStyle "blue"+        arc(centerX + 50, centerY, radius, startingAngle, endingAngle, True)+        stroke()+++    wiki $ snapShot context "images/Arc.png"+    wiki $ close context

@@ -0,0 +1,20 @@+{-# LANGUAGE OverloadedStrings #-}+module Bezier_Curve where++import Graphics.Blank+import Wiki -- (578,200)++main :: IO ()+main = blankCanvas 3000 $ \ context -> do+    send context $ do+        beginPath()+        moveTo(188, 150)+        bezierCurveTo(140, 10, 388, 10, 388, 170)+        lineWidth 10+        -- line color+        strokeStyle "black"+        stroke()+++    wiki $ snapShot context "images/Bezier_Curve.png"+    wiki $ close context

@@ -0,0 +1,67 @@+{-# LANGUAGE OverloadedStrings #-}+module Bounce where++import Control.Concurrent+import Control.Monad -- wiki $+import Data.Text (Text)+import Graphics.Blank+import Wiki -- (512,384)++main :: IO ()+main = blankCanvas 3000 { events = ["mousedown"] } $ go++type Ball a = ((Double, Double), Double, a)++type Color = String++epoch :: [Ball ()]+epoch = []++type State = ([Ball Color])++showBall :: (Double, Double) -> Text -> Canvas ()+showBall (x,y) col = do+        beginPath()+        globalAlpha 0.5+        fillStyle col+        arc(x, y, 50, 0, pi*2, False)+        closePath()+        fill()++moveBall :: Ball a -> Ball a+moveBall ((x,y),d,a) = ((x,y+d),d+0.5,a)++go :: DeviceContext -> IO ()+go context = do+     let bounce :: Ball a -> Ball a+         bounce ((x,y),d,a)+            | y + 25 >= height context && d > 0 = ((x,y),-(d-0.5)*0.97,a)+            | otherwise         = ((x,y),d,a)++     let loop (balls,cols) = do++             send context $ do+                clearCanvas+                sequence_+                     [ showBall xy col+                     | (xy,_,col) <- balls+                     ]+             threadDelay (20 * 1000) ++             wiki $ counter (\ _ -> True) $ \ n -> do+                  file <- wiki $ anim_png "Bounce"+                  wiki $ when (n `mod` 43 == 0) $ send context $ trigger $ Event { eMetaKey = False, ePageXY = return(fromIntegral (100 + length balls * 45),20), eType = "mousedown", eWhich = Nothing}+                  wiki $ when (n `mod` 3 == 0) $ snapShot context $ file+                  wiki $ when (n >= 400) $ do { build_anim "Bounce" 7; close context }++             es <- flush context+             if (null es) then return () else print es++             let newBalls = [ ((x,y),0,head cols) +                            | Just (x,y) <- map ePageXY es+                            ]++             loop (map bounce $ map moveBall $ balls ++ newBalls, tail cols)+++     loop ([((100,100),0,"blue")],cycle ["red","blue","green","orange","cyan"])

@@ -0,0 +1,24 @@+{-# LANGUAGE OverloadedStrings #-}+module Circle where++import Graphics.Blank+import Wiki -- (578,200)++main :: IO ()+main = blankCanvas 3000 $ \ context -> do+    send context $ do+        let centerX = width context / 2+        let centerY = height context / 2+        let radius = 70++        beginPath()+        arc(centerX, centerY, radius, 0, 2 * pi, False)+        fillStyle "#8ED6FF"+        fill()+        lineWidth  5+        strokeStyle "black"+        stroke()+++    wiki $ snapShot context "images/Circle.png"+    wiki $ close context

@@ -0,0 +1,55 @@+{-# LANGUAGE OverloadedStrings #-}+module Clipping_Region where++import Graphics.Blank+import Wiki -- (578,200)++main :: IO ()+main = blankCanvas 3000 $ \ context -> do+    send context $ do+      let x = width context / 2;+      let y = height context / 2;+      let radius = 75;+      let offset = 50;++      {-+       * save() allows us to save the canvas context before+       * defining the clipping region so that we can return+       * to the default state later on+       -}+      save();+      beginPath();+      arc(x, y, radius, 0, 2 * pi, False);+      clip();++      -- draw blue circle inside clipping region+      beginPath();+      arc(x - offset, y - offset, radius, 0, 2 * pi, False);+      fillStyle "blue";+      fill();++      -- draw yellow circle inside clipping region+      beginPath();+      arc(x + offset, y, radius, 0, 2 * pi, False);+      fillStyle "yellow";+      fill();++      -- draw red circle inside clipping region+      beginPath();+      arc(x, y + offset, radius, 0, 2 * pi, False);+      fillStyle "red";+      fill();++      {-+       * restore() restores the canvas context to its original state+       * before we defined the clipping region+       -}+      restore();+      beginPath();+      arc(x, y, radius, 0, 2 * pi, False);+      lineWidth 10;+      strokeStyle "blue";+      stroke();++    wiki $ snapShot context "images/Clipping_Region.png"+    wiki $ close context

@@ -0,0 +1,28 @@+{-# LANGUAGE OverloadedStrings #-}+module Color_Fill where++import Graphics.Blank+import Wiki -- (578,200)++main :: IO ()+main = blankCanvas 3000 $ \ context -> do+    send context $ do+        beginPath();+        moveTo(170, 80);+        bezierCurveTo(130, 100, 130, 150, 230, 150);+        bezierCurveTo(250, 180, 320, 180, 340, 150);+        bezierCurveTo(420, 150, 420, 120, 390, 100);+        bezierCurveTo(430, 40, 370, 30, 340, 50);+        bezierCurveTo(320, 5, 250, 20, 250, 50);+        bezierCurveTo(200, 5, 150, 20, 170, 80);++      -- complete custom shape+        closePath();+        lineWidth 5;+        fillStyle "#8ED6FF";+        fill();+        strokeStyle "blue";+        stroke();++    wiki $ snapShot context "images/Color_Fill.png"+    wiki $ close context

@@ -0,0 +1,22 @@+{-# LANGUAGE OverloadedStrings #-}+module Color_Square where++import qualified Data.Vector.Unboxed as V+import           Graphics.Blank+import           Wiki -- (300,300)++main :: IO ()+main = blankCanvas 3000 $ \ context -> do+    let v = V.fromList+          $ concat+          $ [ [r,g,0,255]+            | r <- [0..255]+            , g <- [0..255]+            ]++    send context $ do+        putImageData (ImageData 256 256 v, [22,22])++    wiki $ snapShot context "images/Color_Square.png"+    wiki $ close context+    

@@ -0,0 +1,26 @@+{-# LANGUAGE OverloadedStrings #-}+module Custom_Shape where++import Graphics.Blank+import Wiki -- (578,200)++main :: IO ()+main = blankCanvas 3000 $ \ context -> do+    send context $ do+        beginPath();+        moveTo(170, 80);+        bezierCurveTo(130, 100, 130, 150, 230, 150);+        bezierCurveTo(250, 180, 320, 180, 340, 150);+        bezierCurveTo(420, 150, 420, 120, 390, 100);+        bezierCurveTo(430, 40, 370, 30, 340, 50);+        bezierCurveTo(320, 5, 250, 20, 250, 50);+        bezierCurveTo(200, 5, 150, 20, 170, 80);+      -- complete custom shape+        closePath();+        lineWidth 5;+        strokeStyle "blue";+        stroke();+++    wiki $ snapShot context "images/Custom_Shape.png"+    wiki $ close context

@@ -0,0 +1,28 @@+{-# LANGUAGE OverloadedStrings #-}+module Custom_Transform where++import Graphics.Blank+import Wiki -- (578,200)++main :: IO ()+main = blankCanvas 3000 $ \ context -> do+    send context $ do+        let rectWidth = 150;+        let rectHeight = 75;++        -- translation matrix:+        --  1  0  tx+        --  0  1  ty+        --  0  0  1+        let tx = width context / 2;+        let ty = height context / 2;++        -- apply custom transform+        transform(1, 0, 0, 1, tx, ty);++        fillStyle "blue";+        fillRect(rectWidth / (-2), rectHeight / (-2), rectWidth, rectHeight);+++    wiki $ snapShot context "images/Custom_Transform.png"+    wiki $ close context

@@ -0,0 +1,20 @@+{-# LANGUAGE OverloadedStrings #-}+module Draw_Canvas where++import Graphics.Blank                     -- import the blank canvas+import Wiki -- (600,200)++main :: IO ()+main = blankCanvas 3000 $ \ context -> do -- start blank canvas on port 3000+        send context $ do                 -- send commands to this specific context+                moveTo(50,50)+                lineTo(200,100)+                lineWidth 10+                strokeStyle "red"+                stroke()                  -- this draws the ink into the canvas++                me <- myCanvasContext+                drawImage(me,[50,50])++        wiki $ snapShot context "images/Draw_Canvas.png"+        wiki $ close context

@@ -0,0 +1,19 @@+{-# LANGUAGE OverloadedStrings #-}+module Draw_Device where++import Graphics.Blank                     -- import the blank canvas+import Wiki -- (600,200)++main :: IO ()+main = blankCanvas 3000 $ \ context -> do -- start blank canvas on port 3000+        send context $ do                 -- send commands to this specific context+                moveTo(50,50)+                lineTo(200,100)+                lineWidth 10+                strokeStyle "red"+                stroke()                  -- this draws the ink into the canvas++                drawImage(context,[50,50])++        wiki $ snapShot context "images/Draw_Device.png"+        wiki $ close context

@@ -0,0 +1,16 @@+{-# LANGUAGE OverloadedStrings #-}+module Draw_Image where++import Graphics.Blank+import Wiki -- (578,200)++main :: IO ()+main = do+    blankCanvas 3000 $ \ context -> do+        send context $ do+            img <- newImage "images/Haskell.jpg"+            drawImage(img,[69,50])+++        wiki $ snapShot context "images/Draw_Image.png"+        wiki $ close context

@@ -0,0 +1,37 @@+{-# LANGUAGE OverloadedStrings #-}+module Favicon where++import Graphics.Blank                     -- import the blank canvas+import Wiki -- (32,32)++main :: IO ()+main = blankCanvas 3000 $ \ context -> do -- start blank canvas on port 3000+        send context $ do                 -- send commands to this specific context++             beginPath()+             let relPath x xs = do+                      beginPath()+                      moveTo x+                      sequence_ [ lineTo p | ss <- drop 2 $ scanl (flip (:)) [] (x:xs)+                                           , let p = (sum (map fst ss), sum (map snd ss))+                                           ]+                      closePath()+             +             translate(height context * 0.07,height context * 0.8)+             scale (height context / 20,-height context / 20)++             let shape x xs col = do+                     relPath x xs+                     lineWidth 0.5+                     fillStyle col+                     lineCap "round"+                     fill()                     ++             shape (0,0) [(4,6),(-4,6),(3,0),(4,-6),(-4,-6)] "#E8000D" +             shape (8,6) [(-4,6),(3,0),(8,-12),(-3,0),(-2.5,3.75),(-2.5,-3.75),(-3,0)] "#0022B4"+             shape (17,3.5) [(-3.5,0),(-8/6,12/6),(3.5+8/6,0)] "#FFC82D" +             shape (17,6.5) [(-5.5,0),(-8/6,12/6),(5.5+8/6,0)] "#FFC82D" ++        -- wiki $ txt <- send context $ toDataURL() ; print txt+        wiki $ snapShot context "images/Favicon.png"+        wiki $ close context

@@ -0,0 +1,15 @@+{-# LANGUAGE OverloadedStrings #-}+module Font_Size_and_Style where++import Graphics.Blank+import Wiki -- (578,200)++main :: IO ()+main = blankCanvas 3000 $ \ context -> do+    send context $ do+        font "40pt Calibri"+        fillText("Hello World!", 150, 100)+++    wiki $ snapShot context "images/Font_Size_and_Style.png"+    wiki $ close context

@@ -0,0 +1,31 @@+{-# LANGUAGE OverloadedStrings #-}+module Get_Image_Data_URL where++import qualified Data.Text as Text+import           Graphics.Blank+import           Wiki -- (578,350)++main :: IO ()+main = blankCanvas 3000 $ \ context -> do+    url <- send context $ do+        beginPath();+        moveTo(170, 80);+        bezierCurveTo(130, 100, 130, 150, 230, 150);+        bezierCurveTo(250, 180, 320, 180, 340, 150);+        bezierCurveTo(420, 150, 420, 120, 390, 100);+        bezierCurveTo(430, 40, 370, 30, 340, 50);+        bezierCurveTo(320, 5, 250, 20, 250, 50);+        bezierCurveTo(200, 5, 150, 20, 170, 80);+      -- complete custom shape+        closePath();+        lineWidth 5;+        strokeStyle "blue";+        stroke();+        toDataURL();++    send context $ do+        font "18pt Calibri"+        fillText(Text.pack $ show $ Text.take 50 $ url, 10, 300)++    wiki $ snapShot context "images/Get_Image_Data_URL.png"+    wiki $ close context

@@ -0,0 +1,25 @@+{-# LANGUAGE OverloadedStrings #-}+module Global_Alpha where++import Graphics.Blank+import Wiki -- (578,200)++main :: IO ()+main = blankCanvas 3000 $ \ context -> do+    send context $ do+      -- draw blue rectangle+      beginPath();+      rect(200, 20, 100, 100);+      fillStyle "blue";+      fill();++      -- draw transparent red circle+      globalAlpha 0.5;+      beginPath();+      arc(320, 120, 60, 0, 2 * pi, False);+      fillStyle "red";+      fill();+++    wiki $ snapShot context "images/Global_Alpha.png"+    wiki $ close context

@@ -0,0 +1,70 @@+{-# LANGUAGE OverloadedStrings #-}+module Global_Composite_Operations where++import qualified Data.Text as Text+import           Graphics.Blank+import           Wiki -- (578,430)++main :: IO ()+main = blankCanvas 3000 $ \ context -> do+    send context $ do++        tempCanvas <- newCanvas (round (width context  :: Double),+                                 round (height context :: Double))+        console_log tempCanvas+        (w,h) <- return (round (width context  :: Double) :: Int,+                         round (height context :: Double) :: Int)+        console_log $ Text.pack $ show $ (w,h)+        +        let squareWidth = 55;+        let circleRadius = 35;+        let shapeOffset = 50;++        let compss = +             [["source-atop", "source-in", "source-out", "source-over"]+             ,["destination-atop","destination-in","destination-out","destination-over"]+             ,["lighter","darker","xor","copy"]+             ]++        -- translate context to add 10px padding+        translate(10, 10);+++        sequence_ [+             do++                -- clear temp context+                with tempCanvas $ do+                        save();++                        clearRect(0, 0, width context, height context);+                        -- draw rectangle (destination)+                        beginPath();+                        rect(0, 0, squareWidth, squareWidth);+                        fillStyle "blue";+                        fill();++                        -- set global composite+                        globalCompositeOperation thisOperation;++                        -- draw circle (source)+                        beginPath();+                        arc(shapeOffset, shapeOffset, circleRadius, 0, 2 * pi, False);+                        fillStyle "red";+                        fill();++                        restore();++                        font "10pt Verdana";+                        fillStyle "black";+                        fillText(thisOperation, 0, squareWidth + 45);++                drawImage(tempCanvas, [x * 125, y * 125]);+++              | (comps,y)         <- compss `zip` [0..]+              , (thisOperation,x) <- comps  `zip` [0..]+              ]++    wiki $ snapShot context "images/Global_Composite_Operations.png"+    wiki $ close context

@@ -0,0 +1,33 @@+{-# LANGUAGE OverloadedStrings #-}+module Grayscale where++import qualified Data.Vector.Unboxed as V+import           Graphics.Blank+import           Wiki -- (578,400)++main :: IO ()+main = do+    blankCanvas 3000 $ \ context -> do+        ImageData w h v <- send context $ do+            img <- newImage "images/House.jpg"+            drawImage(img,[50,50])+            getImageData(50,50, width img, height img)+        +        let group4 (a:b:c:d:xs) = (a,b,c,d) : group4 xs+            group4 _            = []+        +        let v' = V.fromList+              $ concat+              $ [ let brightness = round+                                 ( 0.34 * fromIntegral r +                                 + 0.5 * fromIntegral g+                                 + 0.16 * fromIntegral b :: Double)+                  in [brightness,brightness,brightness,a] +                | (r,g,b,a) <- group4 $ V.toList $ v+                ]+        +        send context $ do+            putImageData (ImageData w h v', [100,100])+        +        wiki $ snapShot context "images/Grayscale.png"+        wiki $ close context

@@ -0,0 +1,16 @@+{-# LANGUAGE OverloadedStrings #-}+module Image_Crop where++import Graphics.Blank+import Wiki -- (578,200)++main :: IO ()+main = do+    blankCanvas 3000 $ \ context -> do+        send context $ do+            img <- newImage "images/Haskell.jpg"+            drawImage(img,[150,0,150,150,50,50,150,200])+        +        +        wiki $ snapShot context "images/Image_Crop.png"+        wiki $ close context

@@ -0,0 +1,18 @@+{-# LANGUAGE OverloadedStrings #-}+module Image_Loader where++import Graphics.Blank+import Wiki -- (578,400)++main :: IO ()+main = do+    blankCanvas 3000 $ \ context -> do+        send context $ do+            img1 <- newImage "images/Haskell.jpg"+            img2 <- newImage "images/House.jpg"+            drawImage(img1,[69,50,97,129])+            drawImage(img2,[200,50])+        +        +        wiki $ snapShot context "images/Image_Loader.png"+        wiki $ close context

@@ -0,0 +1,16 @@+{-# LANGUAGE OverloadedStrings #-}+module Image_Size where++import Graphics.Blank+import Wiki -- (578,200)++main :: IO ()+main = do+    blankCanvas 3000 $ \ context -> do+        send context $ do+            img <- newImage "images/Haskell.jpg"+            drawImage(img,[69,50,97,129])+        +        +        wiki $ snapShot context "images/Image_Size.png"+        wiki $ close context

@@ -0,0 +1,29 @@+{-# LANGUAGE OverloadedStrings #-}+module Is_Point_In_Path where++import Graphics.Blank+import Wiki -- (400,400)++main :: IO ()+main = blankCanvas 3000 $ \ context -> do++    send context $ do+        strokeStyle "blue";+        beginPath();+        rect(100,100,200,200)+        cmds <- sequence [ do+                   b <- isPointInPath (x,y)+                   return $ do+                        beginPath()+                        fillStyle $ if b then "red" else "green"+                        arc(x, y, 5, 0, pi*2, False)+                        fill()+                 | x <- take 8 [25,25+50..]+                 , y <- take 8 [25,25+50..]+                 ]+        stroke()+        -- Now draw the points+        sequence_ cmds++    wiki $ snapShot context "images/Is_Point_In_Path.png"+    wiki $ close context

@@ -0,0 +1,52 @@+{-# LANGUAGE OverloadedStrings #-}+module Key_Read where++import           Data.List (nub)+import           Data.Monoid ((<>))+import qualified Data.Text as Text+-- import           Debug.Trace+import           Graphics.Blank+import           Wiki -- (512,200)++data State = State+        { keys :: [Int]    -- key *codes* for pressed keys+        , step :: Int+        }+     deriving Show++main :: IO ()+main = blankCanvas 3000 { events = ["keyup","keydown"] } $ \ context -> loop context (State [] 0)++loop :: DeviceContext -> State -> IO ()+loop context state = do+        send context $ do+                clearRect (0,0,width context,height context)+                lineWidth 1+                strokeStyle "red"+                font "30pt Calibri"+                fillText("Keys currently pressed: " <> Text.pack (show (keys state)),10,50)+                fillText("Counter: " <> Text.pack (show (step state)),10,150)++        control context state++control :: DeviceContext -> State -> IO ()+control context state = do+    wiki $ counter (\ _ -> True) $ \ n -> do+        file <- wiki $ anim_png "Key_Read"+        wiki $ snapShot context $ file+        wiki $ whenM (n == 1) $ ev context "keydown" 90+        wiki $ whenM (n == 2) $ ev context "keydown" 88+        wiki $ whenM (n == 3) $ ev context "keyup" 88+        wiki $ whenM (n == 4) $ ev context "keyup" 90+        wiki $ whenM (n == 5) $ do { build_anim "Key_Read" 100; close context }+    event <- wait context+    print event+    let down_keys = case (eType event,eWhich event) of+                     ("keydown",Just c) -> [c]+                     _ -> []+    let up_keys = case (eType event,eWhich event) of+                     ("keyup",Just c) -> [c]+                     _ -> []+    let current_keys = [ k | k <- nub (keys state ++ down_keys), not (k `elem` up_keys) ]+    let state' = state { step = step state + 1, keys = current_keys }+    loop context state'

@@ -0,0 +1,17 @@+{-# LANGUAGE OverloadedStrings #-}+module Line where++import Graphics.Blank+import Wiki -- (578,200)++main :: IO ()+main = blankCanvas 3000 $ \ context -> do+    send context $ do+        beginPath()+        moveTo(100,150)+        lineTo(450,50)+        stroke()+++    wiki $ snapShot context "images/Line.png"+    wiki $ close context

@@ -0,0 +1,23 @@+{-# LANGUAGE OverloadedStrings #-}+module Line_Cap where++import Graphics.Blank+import Wiki -- (578,200)++main :: IO ()+main = blankCanvas 3000 $ \ context -> do+    send context $ do+        sequence_+           [ do beginPath()+                moveTo(200, height context / 2 + n)+                lineTo(width context - 200, height context / 2 + n)+                lineWidth 20+                strokeStyle "#0000ff"+                lineCap cap+                stroke()+           | (cap,n) <- zip ["butt","round","square"] [-50,0,50]+           ]+++    wiki $ snapShot context "images/Line_Cap.png"+    wiki $ close context

@@ -0,0 +1,18 @@+{-# LANGUAGE OverloadedStrings #-}+module Line_Color where++import Graphics.Blank+import Wiki -- (578,200)++main :: IO ()+main = blankCanvas 3000 $ \ context -> do+    send context $ do+        moveTo(100,150)+        lineTo(450,50)+        lineWidth 5+        strokeStyle "#ff0000"+        stroke()+++    wiki $ snapShot context "images/Line_Color.png"+    wiki $ close context

@@ -0,0 +1,39 @@+{-# LANGUAGE OverloadedStrings #-}+module Line_Join where++import Graphics.Blank+import Wiki -- (578,200)++main :: IO ()+main = blankCanvas 3000 $ \ context -> do+    send context $ do+        +        lineWidth 25;++      -- miter line join (left)+        beginPath();+        moveTo(99, 150);+        lineTo(149, 50);+        lineTo(199, 150);+        lineJoin "miter";+        stroke();++      -- round line join (middle)+        beginPath();+        moveTo(239, 150);+        lineTo(289, 50);+        lineTo(339, 150);+        lineJoin "round";+        stroke();++      -- bevel line join (right)+        beginPath();+        moveTo(379, 150);+        lineTo(429, 50);+        lineTo(479, 150);+        lineJoin "bevel";+        stroke();+ ++    wiki $ snapShot context "images/Line_Join.png"+    wiki $ close context

@@ -0,0 +1,17 @@+{-# LANGUAGE OverloadedStrings #-}+module Line_Width where++import Graphics.Blank+import Wiki -- (578,200)++main :: IO ()+main = blankCanvas 3000 $ \ context -> do+    send context $ do+        moveTo(100,150)+        lineTo(450,50)+        lineWidth 15+        stroke()+++    wiki $ snapShot context "images/Line_Width.png"+    wiki $ close context

@@ -0,0 +1,22 @@+{-# LANGUAGE OverloadedStrings #-}+module Linear_Gradient where++import           Graphics.Blank+import qualified Graphics.Blank.Style as Style+import           Wiki -- (578,200)++main :: IO ()+main = blankCanvas 3000 $ \ context -> do+    send context $ do        +        rect(0, 0, width context, height context)+        grd <- createLinearGradient(0, 0, width context, height context)+        -- light blue+        grd # addColorStop(0, "#8ED6FF")+        -- dark blue+        grd # addColorStop(1, "#004CB3")+        Style.fillStyle grd;+        fill();+++    wiki $ snapShot context "images/Linear_Gradient.png"+    wiki $ close context

@@ -0,0 +1,17 @@+{-# LANGUAGE OverloadedStrings #-}+module Load_Image_Data_URL where++import qualified Data.Text.IO as Text.IO+import           Graphics.Blank+import           Wiki -- (578,200)++main :: IO ()+main = do+    blankCanvas 3000 $ \ context -> do+        url <- Text.IO.readFile "data/dataURL.txt"+        send context $ do+               img <- newImage url+               drawImage (img,[0,0])+        +        wiki $ snapShot context "images/Load_Image_Data_URL.png"+        wiki $ close context

@@ -0,0 +1,15 @@+{-# LANGUAGE OverloadedStrings #-}+module Load_Image_Data_URL_2 where++import Graphics.Blank+import Wiki -- (578,200)++main :: IO ()+main = blankCanvas 3000 $ \ context -> do+    url <- readDataURL "image/jpeg" "images/Haskell.jpg"+    send context $ do+           img <- newImage url+           drawImage (img,[0,0])++    wiki $ snapShot context "images/Load_Image_Data_URL_2.png"+    wiki $ close context

@@ -0,0 +1,298 @@+-- Shake Generator for wiki pages+{-# LANGUAGE CPP #-}+module Main where++import           Prelude hiding ((*>))++import           Control.Concurrent++import           Data.Char+import           Data.List++import qualified Development.Shake as Shake+import           Development.Shake hiding (doesFileExist)+import           Development.Shake.FilePath++import           System.Directory+import           System.Environment+import           System.IO+import           System.Process++-- TO test: ghci wiki-suite/Draw_Canvas.hs -idist/build/autogen/:.:wiki-suite+import qualified Arc+import qualified Bezier_Curve+import qualified Bounce+import qualified Circle+import qualified Clipping_Region+import qualified Color_Fill+import qualified Color_Square+import qualified Custom_Shape+import qualified Draw_Canvas+import qualified Draw_Device+import qualified Draw_Image+import qualified Favicon+import qualified Font_Size_and_Style+import qualified Get_Image_Data_URL+import qualified Global_Alpha+import qualified Global_Composite_Operations+import qualified Grayscale+import qualified Image_Crop+import qualified Image_Loader+import qualified Image_Size+import qualified Is_Point_In_Path+import qualified Key_Read+import qualified Line+import qualified Line_Cap+import qualified Line_Color+import qualified Line_Join+import qualified Line_Width+import qualified Linear_Gradient+import qualified Load_Image_Data_URL+import qualified Load_Image_Data_URL_2+import qualified Miter_Limit+import qualified Path+import qualified Pattern+import qualified Quadratic_Curve+import qualified Radial_Gradient+import qualified Rectangle+import qualified Red_Line+import qualified Rotating_Square+import qualified Rounded_Corners+import qualified Semicircle+import qualified Shadow+import qualified Square+import qualified Text_Align+import qualified Text_Baseline+import qualified Text_Color+import qualified Text_Metrics+import qualified Text_Stroke+import qualified Text_Wrap+import qualified Tic_Tac_Toe+import qualified Translate_Transform+import qualified Scale_Transform+import qualified Rotate_Transform+import qualified Custom_Transform++import System.Environment++main :: IO ()+main = do +     args <- getArgs +     main2 args++main2 :: [String] -> IO ()+main2 ["Arc"] = Arc.main+main2 ["Bezier_Curve"] = Bezier_Curve.main+main2 ["Bounce"] = Bounce.main+main2 ["Circle"] = Circle.main+main2 ["Clipping_Region"] = Clipping_Region.main+main2 ["Color_Fill"] = Color_Fill.main+main2 ["Color_Square"] = Color_Square.main+main2 ["Custom_Shape"] = Custom_Shape.main+main2 ["Draw_Canvas"] = Draw_Canvas.main+main2 ["Draw_Device"] = Draw_Device.main+main2 ["Draw_Image"] = Draw_Image.main+main2 ["Favicon"] = Favicon.main+main2 ["Font_Size_and_Style"] = Font_Size_and_Style.main+main2 ["Get_Image_Data_URL"] = Get_Image_Data_URL.main+main2 ["Global_Alpha"] = Global_Alpha.main+main2 ["Global_Composite_Operations"] = Global_Composite_Operations.main+main2 ["Grayscale"] = Grayscale.main+main2 ["Image_Crop"] = Image_Crop.main+main2 ["Image_Loader"] = Image_Loader.main+main2 ["Miter_Limit"] = Miter_Limit.main+main2 ["Image_Size"] = Image_Size.main+main2 ["Is_Point_In_Path"] = Is_Point_In_Path.main+main2 ["Key_Read"] = Key_Read.main+main2 ["Line"] = Line.main+main2 ["Line_Cap"] = Line_Cap.main+main2 ["Line_Color"] = Line_Color.main+main2 ["Line_Join"] = Line_Join.main+main2 ["Line_Width"] = Line_Width.main+main2 ["Linear_Gradient"] = Linear_Gradient.main+main2 ["Load_Image_Data_URL"] = Load_Image_Data_URL.main+main2 ["Load_Image_Data_URL_2"] = Load_Image_Data_URL_2.main+main2 ["Path"] = Path.main+main2 ["Pattern"] = Pattern.main+main2 ["Quadratic_Curve"] = Quadratic_Curve.main+main2 ["Radial_Gradient"] = Radial_Gradient.main+main2 ["Rectangle"] = Rectangle.main+main2 ["Red_Line"] = Red_Line.main+main2 ["Rotating_Square"] = Rotating_Square.main+main2 ["Rounded_Corners"] = Rounded_Corners.main+main2 ["Semicircle"] = Semicircle.main+main2 ["Shadow"] = Shadow.main+main2 ["Square"] = Square.main+main2 ["Text_Align"] = Text_Align.main+main2 ["Text_Baseline"] = Text_Baseline.main+main2 ["Text_Color"] = Text_Color.main+main2 ["Text_Metrics"] = Text_Metrics.main+main2 ["Text_Stroke"] = Text_Stroke.main+main2 ["Text_Wrap"] = Text_Wrap.main+main2 ["Tic_Tac_Toe"] = Tic_Tac_Toe.main+main2 ["Translate_Transform"] = Translate_Transform.main+main2 ["Scale_Transform"] = Scale_Transform.main+main2 ["Rotate_Transform"] = Rotate_Transform.main+main2 ["Custom_Transform"] = Custom_Transform.main++main2 ["clean"] = do +        _ <- createProcess $ shell "rm blank-canvas.wiki/images/*.png blank-canvas.wiki/images/*.gif blank-canvas.wiki/examples/*.hs"+        return ()+        +main2 args = shakeArgs shakeOptions $ do++    if null args then do+            want ["blank-canvas.wiki/images/" ++ nm ++ ".gif" | nm <- movies ]+            want ["blank-canvas.wiki/images/" ++ nm ++ ".png" | nm <- examples ++ tutorial]+            want ["blank-canvas.wiki/examples/" ++ nm ++ ".hs" | nm <- movies ++ examples ++ tutorial]+            want ["blank-canvas.wiki/" ++ toMinus nm ++ ".md" | nm <- movies ++ examples ++ tutorial]+    else return ()++    ["blank-canvas.wiki/images/*.png", "blank-canvas.wiki/images/*.gif"] |*> \out -> do+        let nm = takeBaseName out++	liftIO $ print (out,nm)++	let tmp = "tmp"++        liftIO $ createDirectoryIfMissing False tmp+        liftIO $ removeFiles tmp [nm ++ "*.png"]+        liftIO $ createDirectoryIfMissing False tmp++        need [ "blank-canvas.wiki/" ++ toMinus nm ++ ".md" ]+        let haskell_file = nm ++ ".hs"+        need [ "wiki-suite/" ++ haskell_file, "blank-canvas.wiki/examples/" ++ haskell_file ]        +        liftIO $ print nm++        txt <- readFile' $ "wiki-suite/" ++ haskell_file++        let (w,h) = head $+              [ case words ln of+                 [_,_,_,n] -> read n+                 _ -> (512,384)+              | ln <- lines txt +              , "import" `isPrefixOf` ln && "Wiki" `isInfixOf` ln+              ] ++ [(512,384) :: (Int, Int)]+++        sequence_ [+             do (_,_,_,ghc) <- liftIO $ +                              createProcess (proc "./dist/build/wiki-suite/wiki-suite" [nm])++                 -- wait a second, for things to start+                liftIO $ threadDelay (1 * 1000 * 1000)+                +#if defined(darwin_HOST_OS)+                command_ [] "/usr/bin/open" +                                       ["-a"+                                       ,"/Applications/Google Chrome.app"+                                       ,"http://localhost:3000/?height=" ++ show (h) ++ "&width=" ++ show (w) ++ hd]+#else+                -- TODO: Figure out what Windows/MinTTY uses+                command_ [] "/usr/bin/xdg-open" ["http://localhost:3000/?height=" ++ show (h) ++ "&width=" ++ show (w) ++ hd]+#endif+                 -- wait for haskell program to stop+                liftIO $ waitForProcess ghc | hd <- [("")] ++ if nm == "Text_Wrap" then [("&hd")] else [] ]+        return ()+++    "blank-canvas.wiki/examples/*.hs" *> \ out -> do+        liftIO $ print out+        let haskell_file = takeFileName out++        txt <- readFile' $ "./wiki-suite/" ++ haskell_file++        let new = reverse+                $ dropWhile (all isSpace)+                $ reverse+                [ if "module" `isPrefixOf` ln +		  then "module Main where"+		  else ln+                | ln <- lines txt +                , not ("wiki $" `isInfixOf` ln)         -- remove the wiki stuff+                , not ("import" `isPrefixOf` ln && "Wiki" `isInfixOf` ln)+                ]++        writeFileChanged out (unlines $ map (untabify 0) new)++    "blank-canvas.wiki/*.md" *> \ out -> do+        b <- Shake.doesFileExist out+--        liftIO $ print b+        txts <- liftIO $ if b then do+                        h <- openFile out ReadMode+                        let loop = do+                       	     b' <- hIsEOF h +                	     if b'+                	     then return []+                	     else do+                    	   	ln <- hGetLine h+                		lns <- loop+                		return (ln : lns)+                        txts <- loop +                        hClose h+                        return txts+                else return []         +--        liftIO $ print txts++        let p = not . (code_header `isPrefixOf`)+        let textToKeep = takeWhile p txts++        let haskell_file = map (\ c -> if c == '-' then '_' else c) +	    		 $ replaceExtension (takeFileName out) ".hs"+++        liftIO $ print haskell_file+        txt <- readFile' $ "blank-canvas.wiki/examples/" ++ haskell_file ++        let new = unlines $+                       [ t | t <- textToKeep +                       ] +++                       [code_header] +++                       lines txt +++                       [code_footer]++--        liftIO $ putStrLn new++        writeFileChanged out new+++-- to clean: rm images/*png images/*gif examples/*hs+-- */++movies :: [String]+movies = ["Rotating_Square","Tic_Tac_Toe","Bounce","Key_Read","Square"]++examples :: [String]+examples = ["Red_Line","Favicon"]+        ++ ["Color_Square"] ++tutorial :: [String]+tutorial = ["Line", "Line_Width", "Line_Color", "Line_Cap","Miter_Limit"]+        ++ ["Arc","Quadratic_Curve","Bezier_Curve"]+        ++ ["Path","Line_Join","Rounded_Corners","Is_Point_In_Path"]+        ++ ["Custom_Shape","Rectangle","Circle","Semicircle"]+        ++ ["Color_Fill","Linear_Gradient","Radial_Gradient","Pattern"]+        ++ ["Draw_Image","Image_Size","Image_Crop","Image_Loader", "Draw_Canvas", "Draw_Device"]+        ++ ["Font_Size_and_Style","Text_Color","Text_Stroke","Text_Align","Text_Baseline","Text_Metrics","Text_Wrap"]+        ++ ["Translate_Transform","Scale_Transform","Rotate_Transform","Custom_Transform"]+        ++ ["Shadow","Global_Alpha","Clipping_Region","Global_Composite_Operations"]+        ++ ["Grayscale","Get_Image_Data_URL","Load_Image_Data_URL"]+        ++ ["Load_Image_Data_URL_2"]++wiki_dir :: String+wiki_dir = "."++toMinus :: String -> String+toMinus = map (\ c -> if c == '_' then '-' else c) +++untabify :: Int -> String -> String+untabify _ [] = []+untabify n (c:cs) | c == '\t' = let t = 8 - n `mod` 8 in take t (cycle " ") ++ untabify (n + t) cs+                  | otherwise = c : untabify (n + 1) cs ++code_header :: String+code_header = "````Haskell"++code_footer :: String+code_footer = "````"

@@ -0,0 +1,32 @@+{-# LANGUAGE OverloadedStrings #-}+module Miter_Limit where++import Graphics.Blank+import Wiki -- (578,200)++main :: IO ()+main = blankCanvas 3000 $ \ context -> do+  send context $ do+    clearRect(0,0,150,150);+    -- Draw guides+    strokeStyle "#09f";+    lineWidth    2;+    strokeRect(-5,50,160,50);+ +    -- Set line styles+    strokeStyle "#000";+    lineWidth 10;+ +    -- check input+    miterLimit 5;++    -- Draw lines+    beginPath()+    moveTo(0,100)+    sequence_ [ lineTo((fromIntegral i ** 1.5)*2,75+(if i `mod` 2 == 0 then 25 else -25))+              | i <- [0..20] :: [Int]+              ]+    stroke();++  wiki $ snapShot context "images/Miter_Limit.png"+  wiki $ close context

@@ -0,0 +1,27 @@+{-# LANGUAGE OverloadedStrings #-}+module Path where++import Graphics.Blank+import Wiki -- (578,200)++main :: IO ()+main = blankCanvas 3000 $ \ context -> do+    send context $ do+        beginPath()+        moveTo(100, 20)+        -- line 1+        lineTo(200, 160)+        -- quadratic curve+        quadraticCurveTo(230, 200, 250, 120)+        -- bezier curve+        bezierCurveTo(290, -40, 300, 200, 400, 150)+        -- line 2+        lineTo(500, 90)+        lineWidth 5+        strokeStyle "blue"+        stroke()++++    wiki $ snapShot context "images/Path.png"+    wiki $ close context

@@ -0,0 +1,19 @@+{-# LANGUAGE OverloadedStrings #-}+module Pattern where++import           Graphics.Blank+import qualified Graphics.Blank.Style as Style+import           Wiki -- (578,200)++main :: IO ()+main = blankCanvas 3000 $ \ context -> do+    send context $ do+        imageObj <- newImage "images/Haskell.jpg"+        pattern <- createPattern (imageObj,"repeat")+        rect(0, 0, width context, height context);+        Style.fillStyle pattern;+        fill();+++    wiki $ snapShot context "images/Pattern.png"+    wiki $ close context

@@ -0,0 +1,20 @@+{-# LANGUAGE OverloadedStrings #-}+module Quadratic_Curve where++import Graphics.Blank+import Wiki -- (578,200)++main :: IO ()+main = blankCanvas 3000 $ \ context -> do+    send context $ do+        beginPath()+        moveTo(188, 150)+        quadraticCurveTo(288, 0, 388, 150)+        lineWidth 10+        -- line color+        strokeStyle "black"+        stroke()+++    wiki $ snapShot context "images/Quadratic_Curve.png"+    wiki $ close context

@@ -0,0 +1,22 @@+{-# LANGUAGE OverloadedStrings #-}+module Radial_Gradient where++import           Graphics.Blank+import qualified Graphics.Blank.Style as Style+import           Wiki -- (578,200)++main :: IO ()+main = blankCanvas 3000 $ \ context -> do+    send context $ do+        rect(0, 0, width context, height context)+        grd <- createRadialGradient (238, 50, 10, 238, 50, 300)+        -- light blue+        grd # addColorStop(0, "#8ED6FF")+        -- dark blue+        grd # addColorStop(1, "#004CB3")+        Style.fillStyle grd;+        fill();+++    wiki $ snapShot context "images/Radial_Gradient.png"+    wiki $ close context

@@ -0,0 +1,20 @@+{-# LANGUAGE OverloadedStrings #-}+module Rectangle where++import Graphics.Blank+import Wiki -- (578,200)++main :: IO ()+main = blankCanvas 3000 $ \ context -> do+    send context $ do+        beginPath();+        rect(188, 50, 200, 100);+        fillStyle "yellow";+        fill();+        lineWidth 7;+        strokeStyle "black";+        stroke();+      ++    wiki $ snapShot context "images/Rectangle.png"+    wiki $ close context

@@ -0,0 +1,17 @@+{-# LANGUAGE OverloadedStrings #-}+module Red_Line where++import Graphics.Blank                     -- import the blank canvas+import Wiki -- (600,200)++main :: IO ()+main = blankCanvas 3000 $ \ context -> do -- start blank canvas on port 3000+        send context $ do                 -- send commands to this specific context+                moveTo(50,50)+                lineTo(200,100)+                lineWidth 10+                strokeStyle "red"+                stroke()                  -- this draws the ink into the canvas++        wiki $ snapShot context "images/Red_Line.png"+        wiki $ close context

@@ -0,0 +1,20 @@+{-# LANGUAGE OverloadedStrings #-}+module Rotate_Transform where++import Graphics.Blank+import Wiki -- (578,200)++main :: IO ()+main = blankCanvas 3000 $ \ context -> do+    send context $ do+        let rectWidth = 150;+        let rectHeight = 75;+        translate(width context / 2, height context / 2);+        rotate (pi/4);++        fillStyle "blue";+        fillRect(rectWidth / (-2), rectHeight / (-2), rectWidth, rectHeight);+++    wiki $ snapShot context "images/Rotate_Transform.png"+    wiki $ close context

@@ -0,0 +1,36 @@+{-# LANGUAGE OverloadedStrings #-}+module Rotating_Square where++import Control.Concurrent+import Graphics.Blank+import Wiki -- (384,384)++main :: IO ()+main = blankCanvas 3000 $ flip loop 0++loop :: DeviceContext -> Double -> IO ()+loop context n = do+        send context $ do+                clearRect (0,0,width context,height context)+                beginPath()+                save()+                translate (width context / 2,height context / 2)+                rotate (pi * n)+                beginPath()+                moveTo(-100,-100)+                lineTo(-100,100)+                lineTo(100,100)+                lineTo(100,-100)+                closePath()+                lineWidth 10+                strokeStyle "green"+                stroke()+                restore()+        threadDelay (20 * 1000)+        v <- wiki $ return (round (n*100) :: Int)+        wiki $ whenM (v `mod` 2 == 0) $ do+                file <- wiki $ anim_png "Rotating_Square"+                wiki $ snapShot context $ file+                wiki $ whenM (v == 48) $ do { build_anim "Rotating_Square" 5; close context }+        loop context (n + 0.01)+

@@ -0,0 +1,29 @@+{-# LANGUAGE OverloadedStrings #-}+module Rounded_Corners where++import Graphics.Blank+import Wiki -- (578,200)++main :: IO ()+main = blankCanvas 3000 $ \ context -> do+    send context $ do+        +        lineWidth 25;++        let rectWidth = 200;+        let rectHeight = 100;+        let rectX = 189;+        let rectY = 50;+        let cornerRadius = 50;++        beginPath();+        moveTo(rectX, rectY);+        lineTo(rectX + rectWidth - cornerRadius, rectY);+        arcTo(rectX + rectWidth, rectY, rectX + rectWidth, rectY + cornerRadius, cornerRadius);+        lineTo(rectX + rectWidth, rectY + rectHeight);+        lineWidth 5;+        stroke();+++    wiki $ snapShot context "images/Rounded_Corners.png"+    wiki $ close context

@@ -0,0 +1,20 @@+{-# LANGUAGE OverloadedStrings #-}+module Scale_Transform where++import Graphics.Blank+import Wiki -- (578,200)++main :: IO ()+main = blankCanvas 3000 $ \ context -> do+    send context $ do+        let rectWidth = 150;+        let rectHeight = 75;+        translate(width context / 2, height context / 2);+        scale(1, 0.5);++        fillStyle "blue";+        fillRect(rectWidth / (-2), rectHeight / (-2), rectWidth, rectHeight);+++    wiki $ snapShot context "images/Scale_Transform.png"+    wiki $ close context

@@ -0,0 +1,21 @@+{-# LANGUAGE OverloadedStrings #-}+module Semicircle where++import Graphics.Blank+import Wiki -- (578,200)++main :: IO ()+main = blankCanvas 3000 $ \ context -> do+    send context $ do+        beginPath();+        arc(288, 75, 70, 0, pi, False);+        closePath();+        lineWidth 5;+        fillStyle "red";+        fill();+        strokeStyle "#550000";+        stroke();+++    wiki $ snapShot context "images/Semicircle.png"+    wiki $ close context

@@ -0,0 +1,20 @@+{-# LANGUAGE OverloadedStrings #-}+module Shadow where++import Graphics.Blank+import Wiki -- (578,200)++main :: IO ()+main = blankCanvas 3000 $ \ context -> do+    send context $ do+        rect(188, 40, 200, 100);+        fillStyle "red";+        shadowColor "#999";+        shadowBlur 20;+        shadowOffsetX 15;+        shadowOffsetY 15;+        fill()+++    wiki $ snapShot context "images/Shadow.png"+    wiki $ close context

@@ -0,0 +1,49 @@+{-# LANGUAGE OverloadedStrings #-}+module Square where++import Graphics.Blank+import Wiki -- (512,512)++main :: IO ()+main = blankCanvas 3000 { events = ["mousedown"] } $ \ context -> do+          let loop (x,y) (color:colors) = do+                send context $ saveRestore $ do+                        translate (x,y)+                        beginPath()+                        moveTo(-100,-100)+                        lineTo(-100,100)+                        lineTo(100,100)+                        lineTo(100,-100)+                        closePath()+                        lineWidth 10+                        strokeStyle color+                        stroke()+++                wiki $ counter (\ _ -> True) $ \ n -> do+                    file <- wiki $ anim_png "Square"+                    wiki $ snapShot context $ file+                    let e (x',y') = wiki $ send context $ trigger $ Event {+                        eMetaKey = False+                      , ePageXY = return (x',y')+                      , eType = "mousedown"+                      , eWhich = Nothing+                    }+                    wiki $ whenM (n == 1) $ e (x-100,y+50)+                    wiki $ whenM (n == 2) $ e (x+20, y-60)+                    wiki $ whenM (n == 3) $ e (x+40, y+20)+                    wiki $ whenM (n == 4) $ e (x+60, y-60)+                    wiki $ whenM (n >= 5) $ do { build_anim "Square" 100; close context }++                event <- wait context+                case ePageXY event of+                        Nothing -> loop (x,y) colors+                        Just (x',y') -> loop (x',y') colors++          putStrLn "calling size"                +          loop (width context / 2,height context / 2)+               (cycle [ "#749871", "#1887f2", "#808080", "f01234"])++++

@@ -0,0 +1,19 @@+{-# LANGUAGE OverloadedStrings #-}+module Text_Align where++import Graphics.Blank+import Wiki -- (578,200)++main :: IO ()+main = blankCanvas 3000 $ \ context -> do+    send context $ do+        let x = width context / 2+        let y = height context / 2+        font "30pt Calibri"+        textAlign "center"+        fillStyle "blue"+        fillText("Hello World!", x, y)+++    wiki $ snapShot context "images/Text_Align.png"+    wiki $ close context

@@ -0,0 +1,20 @@+{-# LANGUAGE OverloadedStrings #-}+module Text_Baseline where++import Graphics.Blank+import Wiki -- (578,200)++main :: IO ()+main = blankCanvas 3000 $ \ context -> do+    send context $ do+        let x = width context / 2+        let y = height context / 2+        font "30pt Calibri"+        textAlign "center"+        textBaseline "middle"+        fillStyle "blue"+        fillText("Hello World!", x, y)+++    wiki $ snapShot context "images/Text_Baseline.png"+    wiki $ close context

@@ -0,0 +1,16 @@+{-# LANGUAGE OverloadedStrings #-}+module Text_Color where++import Graphics.Blank+import Wiki -- (578,200)++main :: IO ()+main = blankCanvas 3000 $ \ context -> do+    send context $ do+        font "40pt Calibri"+        fillStyle "#0000ff"+        fillText("Hello World!", 150, 100)+++    wiki $ snapShot context "images/Text_Color.png"+    wiki $ close context

@@ -0,0 +1,28 @@+{-# LANGUAGE OverloadedStrings #-}+module Text_Metrics where++import           Data.Monoid+import qualified Data.Text as Text+import           Graphics.Blank+import           Wiki -- (578,200)++main :: IO ()+main = blankCanvas 3000 $ \ context -> do+    send context $ do        +        let x = width context / 2+        let y = height context / 2 - 10;+        let text = "Hello World!"+        font "30pt Calibri"+        textAlign "center"+        fillStyle "blue"+        fillText(text, x, y)++        TextMetrics w <- measureText text+        font "20pt Calibri"+        textAlign "center"+        fillStyle "#555"+        fillText("(" <> Text.pack (show w) <> "px wide)", x, y + 40)+++    wiki $ snapShot context "images/Text_Metrics.png"+    wiki $ close context

@@ -0,0 +1,17 @@+{-# LANGUAGE OverloadedStrings #-}+module Text_Stroke where++import Graphics.Blank+import Wiki -- (578,200)++main :: IO ()+main = blankCanvas 3000 $ \ context -> do+    send context $ do+        font "60pt Calibri"+        lineWidth 3+        strokeStyle "blue"+        strokeText("Hello World!", 80, 110)+++    wiki $ snapShot context "images/Text_Stroke.png"+    wiki $ close context

@@ -0,0 +1,34 @@+{-# LANGUAGE OverloadedStrings #-}+module Text_Wrap where++import           Data.Monoid+import qualified Data.Text as Text+import           Graphics.Blank+import           Wiki -- (578,200)++main :: IO ()+main = blankCanvas 3000 $ \ context -> do+    let r = devicePixelRatio context+    send context $ do+        font $ Text.pack $ "lighter " ++ show (16 * r) ++ "pt Calibri"+        fillStyle "#000"+        let maxWidth = 400 * r+        wrapText 0 (Text.words message) ((width context - maxWidth) / 2) 60 maxWidth (25 * r)+    let ex = wiki $ if r > 1.5 then "@2x" else ""+    wiki $ snapShot context $ "images/Text_Wrap" ++ ex ++ ".png"+    wiki $ close context+    where++        message = "All the world's a stage, and all the men and women merely players. " <>+                  "They have their exits and their entrances; And one man in his time plays many parts."++        wrapText _  []   _ _ _        _          = return ()+        wrapText wc text x y maxWidth lineHeight = do+             TextMetrics testWidth <- measureText $ Text.unwords $ take (wc+1) $ text+             if (testWidth > maxWidth && wc > 0) || length text <= wc+             then do fillText(Text.unwords $ take wc $ text,x,y)+                     wrapText 0      (drop wc text) x (y + lineHeight) maxWidth lineHeight+             else do wrapText (wc+1) text           x y                maxWidth lineHeight+++

@@ -0,0 +1,132 @@+{-# LANGUAGE OverloadedStrings #-}+module Tic_Tac_Toe where++import           Control.Concurrent -- wiki $++import qualified Data.Map as Map+import           Data.Map (Map)+import           Data.Text (Text)++-- import           Debug.Trace++import           Graphics.Blank++import           Wiki -- (512,384)++main :: IO ()+main = blankCanvas 3000 { events = ["mousedown"] } $ \ context -> loop context Map.empty X++data XO = X | O  deriving (Eq,Ord,Show)++swap :: XO -> XO+swap X = O+swap O = X++loop :: DeviceContext -> Map (Int, Int) XO -> XO -> IO ()+loop context board turn = do+        sz <- send context $ do+                clearRect (0,0,width context,height context)+                beginPath()++                let sz = min (width context) (height context)+                save()+                translate (width context / 2,height context / 2)+                sequence_ [ do bigLine (-sz * 0.45,n) (sz * 0.45,n)+                               bigLine (n,-sz * 0.45) (n,sz * 0.45)+                          | n <- [-sz * 0.15,sz * 0.15]+                          ]+++                sequence_ [ do save()+                               translate (fromIntegral x * sz * 0.3,fromIntegral y * sz * 0.3)+                               case Map.lookup (x,y) board of+                                  Just X -> drawX (sz * 0.1)+                                  Just O -> drawO (sz * 0.1)+                                  Nothing -> return ()+                               restore()+                          | x <- [-1,0,1]+                          , y <- [-1,0,1]+                          ]+                restore()+                return sz++        let pointToSq :: (Double, Double) -> Maybe (Int, Int)+            pointToSq (x,y) = do+                    x' <- fd ((x - width context / 2) / sz)+                    y' <- fd ((y - height context / 2) / sz)+                    return (x',y')++            fd x = +--                    trace (show ("fx",x,r)) $+                    if r `elem` [-1..1] then Just (signum r) else Nothing+                where r = round (x * 3.3333)++        let press = (width context / 2 + fromIntegral x * (sz / 4),height context / 2 + fromIntegral y * (sz / 4)) -- wiki $+                where (x,y) = head [ ix | (ix,Nothing)                                   -- wiki $+                                                 <- [ ((x',y'),Map.lookup (x',y') board) -- wiki $+                                                    | y' <- [-1,0,1]                     -- wiki $+                                                    , x' <- [-1,0,1]                     -- wiki $+                                                    ]]                                   -- wiki $++        _ <- wiki $ forkIO $ send context $ trigger $ Event {+              eMetaKey = False+            , ePageXY = return $ press+            , eType = "keypress"+            , eWhich = Nothing+        }+        event <- wait context++        file <- wiki $ anim_png "Tic_Tac_Toe"+        wiki $ snapShot context $ file+        wiki $ whenM (Map.size board == 7) $ do { build_anim "Tic_Tac_Toe" 100; close context ; quit }++        print event+        case ePageXY event of+           -- if no mouse location, ignore, and redraw+           Nothing -> loop context board turn+           Just (x',y') -> case pointToSq (x',y') of+                             Nothing -> loop context board turn+                             Just pos -> case Map.lookup pos board of+                                           Nothing -> loop context+                                                            (Map.insert pos turn board)+                                                            (swap turn)+                                                    -- already something here+                                           Just _ -> loop context board turn++xColor, oColor, boardColor :: Text+xColor = "#ff0000"+oColor = "#00a000"+boardColor = "#000080"++drawX :: Double -> Canvas ()+drawX size = do+        strokeStyle xColor+        lineCap "butt"+        beginPath()+        moveTo(-size,-size)+        lineTo(size,size)+        lineWidth 10+        stroke()+        beginPath()+        moveTo(-size,size)+        lineTo(size,-size)+        lineWidth 10+        stroke()++drawO :: Double -> Canvas ()+drawO radius = do+        beginPath()+        arc(0, 0, radius, 0, 2 * pi, False)+        lineWidth 10+        strokeStyle oColor+        stroke()++bigLine :: (Double, Double) -> (Double, Double) -> Canvas ()+bigLine (x,y) (x',y') = do+        beginPath()+        moveTo(x,y)+        lineTo(x',y')+        lineWidth 20+        strokeStyle boardColor+        lineCap "round"+        stroke()

@@ -0,0 +1,18 @@+{-# LANGUAGE OverloadedStrings #-}+module Translate_Transform where++import Graphics.Blank+import Wiki -- (578,200)++main :: IO ()+main = blankCanvas 3000 $ \ context -> do+    send context $ do+        let rectWidth = 150;+        let rectHeight = 75;+        translate(width context / 2, height context / 2);+        fillStyle "blue";+        fillRect(rectWidth / (-2), rectHeight / (-2), rectWidth, rectHeight);+++    wiki $ snapShot context "images/Translate_Transform.png"+    wiki $ close context

@@ -0,0 +1,123 @@+{-# LANGUAGE OverloadedStrings #-}+-- wiki generator support++module Wiki where++import           Control.Concurrent+import           Control.Concurrent.STM+import qualified Control.Monad as M++import           Data.Text (Text)+import           Data.Time.Clock.POSIX++import           Graphics.Blank++import           System.Exit+import           System.IO.Unsafe+import           System.Posix.Process+import           System.Process++import           Text.Printf++-- import           Trace.Hpc.Reflect+-- import           Trace.Hpc.Tix++snapShot :: DeviceContext -> FilePath -> IO ()+snapShot context fileName = do+        txt <- send context $ do++                tempCanvas <- newCanvas (round (width context + 20  :: Double),+                                         round (height context + 20 :: Double))++                top' <- myCanvasContext++                with tempCanvas $ do+                        -- print a border, because we can (looks better in wiki)++                        save()+                        beginPath()+                        moveTo(1,1)+                        lineTo(width context+1,1)+                        lineTo(width context+1,height context+1)+                        lineTo(1,height context+1)+                        closePath()+                        fillStyle "white"++                        shadowOffsetX 10+                        shadowOffsetY 10;+                        shadowBlur 15;+                        shadowColor "#999";++                        fill()++                        beginPath()+                        moveTo(0.5,0.5)+                        lineTo(width context+1.5,0.5)+                        lineTo(width context+1.5,height context+1.5)+                        lineTo(0.5,height context+1.5)+                        closePath()++                        shadowOffsetX 0+                        shadowOffsetY 0+                        shadowBlur 0+                        lineWidth 1+                        strokeStyle "black"++                        stroke()++                        restore()+                        +                        drawImage(top',[1,1])+                        toDataURL() -- of tempCanvas++        writeDataURL ("blank-canvas.wiki/" ++ fileName) txt++wiki :: a -> a+wiki = id++close :: DeviceContext -> IO ()+close context = do+--        n <- getPOSIXTime                +--        Tix tix <- examineTix+--	let tix' = filter (\ t -> ("Graphics.Blank" `isPrefixOf` tixModuleName t)) +--	         $ tix+--        writeFile ("tix/tix_" ++ printf "_%013d" (floor (fromRational (toRational n) * 1000) :: Integer) ++ ".tix") $ show $ Tix tix'+        send context $ eval "open(location, '_self').close()"+        threadDelay (1000 * 1000);+        putStrLn "dieing"+        p <- getProcessID +        callProcess "kill" [show p]+        quit++quit :: IO a+quit = exitSuccess++whenM :: Monad m => Bool -> m () -> m ()+whenM = M.when++anim_png :: String -> IO String+anim_png nm = do+   n <- getPOSIXTime                +   return $ "tmp/" ++ nm ++ printf "_%013d" (floor (fromRational (toRational n) * 1000 :: Double) :: Integer) ++ ".png"++build_anim :: String -> Int -> IO ()+build_anim nm pz = do+       callCommand $ "convert -delay " ++ show pz ++ " -loop 0 -dispose background blank-canvas.wiki/tmp/" ++ nm ++ "_*.png blank-canvas.wiki/images/" ++ nm ++ ".gif"+       return ()+++{-# NOINLINE count #-}+count :: TVar Int+count = unsafePerformIO $ newTVarIO 1++counter :: (Int -> Bool) -> (Int -> IO ()) -> IO ()+counter p k = do+    n <- atomically $ do+           v <- readTVar count+           writeTVar count $! v + 1+           return v+    if p n then k n else return ()+++ev :: DeviceContext -> Text -> Int -> IO ()+ev context t c = send context $ trigger $ Event { eMetaKey = False, ePageXY = Nothing, eType = t, eWhich = Just c }