diff --git a/Changelog.md b/Changelog.md new file mode 100644 --- /dev/null +++ b/Changelog.md @@ -0,0 +1,18 @@ +## 0.5 + +API changes + * Using Double rather than Float + * Generalized saveRestore to be polymorphic + +API additions + * Added sync for forcing synchronization between the server and client + * Added argument specific variants of drawImage and putImageData. + * Added ADTs for RepeatDirection, Alignment, Baseline, LineEnds, Corner (previous used Text) + * Use of the colour(sic) package (Text is still allowed) + +Bug fixes: + * Fixed unicode escapes in strings + +Additions: + * Allow Images to access client-side filesystem + diff --git a/Graphics/Blank.hs b/Graphics/Blank.hs --- a/Graphics/Blank.hs +++ b/Graphics/Blank.hs @@ -15,7 +15,7 @@ , DeviceContext -- abstact , send -- * HTML5 Canvas API - -- | See for the JavaScript + -- | See for the JavaScript -- version of this API. , Canvas -- abstact -- ** Canvas element @@ -42,6 +42,8 @@ , lineCap , lineJoin , miterLimit + , LineEndCap(..) + , LineJoinCorner(..) -- ** Colors, styles and shadows , strokeStyle , fillStyle @@ -53,6 +55,7 @@ , createRadialGradient , createPattern , addColorStop + , RepeatDirection(..) , CanvasGradient , CanvasPattern -- ** Paths @@ -70,12 +73,14 @@ , rect , isPointInPath -- ** Text - , font + , font , textAlign , textBaseline , fillText , strokeText , measureText + , TextAnchorAlignment(..) + , TextBaselineAlignment(..) , TextMetrics(..) -- ** Rectangles , clearRect @@ -97,6 +102,8 @@ , with , myCanvasContext , deviceCanvasContext + -- ** Syncing + , sync -- ** Debugging , console_log , eval @@ -104,7 +111,7 @@ -- ** Drawing Utilities , module Graphics.Blank.Utils -- ** Events - , trigger + , trigger , eventQueue , wait , flush @@ -115,38 +122,48 @@ , local_only ) where -import Control.Concurrent -import Control.Concurrent.STM -import Control.Monad -import Control.Exception -import Network.Wai.Handler.Warp (run) -import Network.Wai (Middleware,remoteHost, responseLBS) -import qualified Network.HTTP.Types as H -import Network.Socket (SockAddr(..)) -import System.IO.Unsafe (unsafePerformIO) ---import System.Mem.StableName -import Web.Scotty (scottyApp, get, file) -import qualified Web.Scotty as Scotty ---import Network.Wai.Middleware.RequestLogger -- Used when debugging ---import Network.Wai.Middleware.Static -import qualified Web.Scotty.Comet as KC -import Data.Aeson -import Data.Aeson.Types (parse) -import Data.String +import Control.Concurrent +import Control.Concurrent.STM +import Control.Exception +import Control.Monad +import Control.Monad.IO.Class + +import Data.Aeson +import Data.Aeson.Types (parse) +import Data.List as L +import Data.Monoid ((<>)) +import qualified Data.Set as S +import Data.String import qualified Data.Text as T -import Data.Text (Text) -import Data.Monoid((<>)) +import Data.Text (Text) +import qualified Data.Text.Lazy as LT -import Graphics.Blank.Events -import Graphics.Blank.DeviceContext -import Graphics.Blank.Canvas -import Graphics.Blank.Generated hiding (fillStyle,strokeStyle) +import qualified Graphics.Blank.Canvas as Canvas +import Graphics.Blank.Canvas hiding (addColorStop) +import Graphics.Blank.DeviceContext +import Graphics.Blank.Events import qualified Graphics.Blank.Generated as Generated +import Graphics.Blank.Generated hiding (fillStyle, strokeStyle, shadowColor) import qualified Graphics.Blank.JavaScript as JavaScript -import Graphics.Blank.JavaScript hiding (width, height) -import Graphics.Blank.Utils -import Paths_blank_canvas +import Graphics.Blank.JavaScript hiding (width, height) +import Graphics.Blank.Utils +import qualified Network.HTTP.Types as H +import Network.Wai (Middleware, responseLBS) +import Network.Wai.Middleware.Local +import Network.Wai.Handler.Warp +-- import Network.Wai.Middleware.RequestLogger -- Used when debugging +-- import Network.Wai.Middleware.Static + +import Paths_blank_canvas + +import System.IO.Unsafe (unsafePerformIO) +-- import System.Mem.StableName + +import qualified Web.Scotty as Scotty +import Web.Scotty (scottyApp, get, file) +import qualified Web.Scotty.Comet as KC + -- | blankCanvas is the main entry point into blank-canvas. -- A typical invocation would be -- @@ -172,17 +189,21 @@ kComet <- KC.kCometPlugin + locals :: TVar (S.Set Text) <- atomically $ newTVar S.empty + -- print dataDir app <- scottyApp $ do -- middleware logStdoutDev - sequence_ [ Scotty.middleware ware - | ware <- middleware opts + sequence_ [ Scotty.middleware ware + | ware <- middleware opts ] -- use the comet let kc_opts :: KC.Options kc_opts = KC.Options { KC.prefix = "/blank", KC.verbose = if debug opts then 3 else 0 } + + KC.connect kc_opts $ \ kc_doc -> do -- register the events we want to watch for KC.send kc_doc $ T.unlines @@ -198,18 +219,19 @@ atomically $ writeTChan queue event _ -> return () - let cxt0 = DeviceContext kc_doc queue 300 300 1 - - -- A bit of bootstrapping + + let cxt0 = DeviceContext kc_doc queue 300 300 1 locals + + -- A bit of bootstrapping DeviceAttributes w h dpr <- send cxt0 device -- print (DeviceAttributes w h dpr) - let cxt1 = cxt0 + let cxt1 = cxt0 { ctx_width = w , ctx_height = h , ctx_devicePixelRatio = dpr } - + (actions $ cxt1) `catch` \ (e :: SomeException) -> do print ("Exception in blank-canvas application:" :: String) print e @@ -219,57 +241,78 @@ get "/jquery.js" $ file $ dataDir ++ "/static/jquery.js" get "/jquery-json.js" $ file $ dataDir ++ "/static/jquery-json.js" get "/kansas-comet.js" $ file $ kComet - sequence_ [ get (fromString ("/" ++ nm)) $ file $ (root opts ++ "/" ++ nm) | nm <- static opts ] + + -- There has to be a better way of doing this, using function, perhaps? + get (Scotty.regex "^/(.*)$") $ do + fileName :: Text <- Scotty.param "1" + db <- liftIO $ atomically $ readTVar $ locals + if fileName `S.member` db + then do + mime <- mimeTypes (T.unpack fileName) + Scotty.setHeader "Content-Type" $ LT.fromStrict $ mime + file $ (root opts ++ "/" ++ T.unpack fileName) + else do + Scotty.next + return () - run (port opts) app + + runSettings (setPort (port opts) + $ setTimeout 5 + $ defaultSettings + ) app + -- | Sends a set of Canvas commands to the canvas. Attempts -- to common up as many commands as possible. Should not crash. send :: DeviceContext -> Canvas a -> IO a -send cxt commands = - send' (deviceCanvasContext cxt) commands id +send cxt commands = + send' (deviceCanvasContext cxt) commands id where - send' :: CanvasContext -> Canvas a -> (String -> String) -> IO a - send' c (Bind (Return a) k) cmds = send' c (k a) cmds - send' c (Bind (Bind m k1) k2) cmds = send' c (Bind m (\ r -> Bind (k1 r) k2)) cmds - send' c (Bind (Method cmd) k) cmds = send' c (k ()) (cmds . ((showJS c ++ ".") ++) . shows cmd . (";" ++)) - send' c (Bind (Command cmd) k) cmds = send' c (k ()) (cmds . shows cmd . (";" ++)) - send' c (Bind (Query query) k) cmds = do - -- send the com - uq <- atomically $ getUniq - -- The query function returns a function takes the unique port number of the reply. - sendToCanvas cxt (cmds . ((show query ++ "(" ++ show uq ++ "," ++ showJS c ++ ");") ++)) - v <- KC.getReply (theComet cxt) uq - case parse (parseQueryResult query) v of - Error msg -> fail msg - Success a -> do - send' c (k a) id - send' c (Bind (With c' m) k) cmds = send' c' (Bind m (With c . k)) cmds - send' c (Bind MyContext k) cmds = send' c (k c) cmds + sendBind :: CanvasContext -> Canvas a -> (a -> Canvas b) -> (String -> String) -> IO b + sendBind c (Return a) k cmds = send' c (k a) cmds + sendBind c (Bind m k1) k2 cmds = sendBind c m (\ r -> Bind (k1 r) k2) cmds + sendBind c (Method cmd) k cmds = send' c (k ()) (cmds . ((showJS c ++ ".") ++) . shows cmd . (";" ++)) + sendBind c (Command cmd) k cmds = send' c (k ()) (cmds . shows cmd . (";" ++)) + sendBind c (Query query) k cmds = sendQuery c query k cmds + sendBind c (With c' m) k cmds = send' c' (Bind m (With c . k)) cmds + sendBind c MyContext k cmds = send' c (k c) cmds - send' _ (With c m) cmds = send' c m cmds - send' c MyContext cmds = send' c (Return c) cmds - send' _ (Return a) cmds = do + sendQuery :: CanvasContext -> Query a -> (a -> Canvas b) -> (String -> String) -> IO b + sendQuery c query k cmds = do + case query of + NewImage url -> do + let url' = if "/" `T.isPrefixOf` url then T.tail url else url + atomically $ do + db <- readTVar (localFiles cxt) + writeTVar (localFiles cxt) $ S.insert url' $ db + _ -> return () + + -- send the com + uq <- atomically $ getUniq + -- The query function returns a function takes the unique port number of the reply. + sendToCanvas cxt (cmds . ((show query ++ "(" ++ show uq ++ "," ++ showJS c ++ ");") ++)) + v <- KC.getReply (theComet cxt) uq + case parse (parseQueryResult query) v of + Error msg -> fail msg + Success a -> do + send' c (k a) id + + + + send' :: CanvasContext -> Canvas a -> (String -> String) -> IO a +-- Most of these can be factored out, except return + send' c (Bind m k) cmds = sendBind c m k cmds + send' _ (With c m) cmds = send' c m cmds -- This is a bit of a hack + send' _ (Return a) cmds = do sendToCanvas cxt cmds return a - send' c cmd cmds = send' c (Bind cmd Return) cmds + send' c cmd cmds = sendBind c cmd Return cmds local_only :: Middleware -local_only f r k = case remoteHost r of - SockAddrInet _ h | h == fromIntegral home - -> f r k -#if !defined(mingw32_HOST_OS) && !defined(_WIN32) - SockAddrUnix _ -> f r k -#endif - _ -> k $ responseLBS H.status403 - [("Content-Type", "text/plain")] - "local access only" - where - home :: Integer - home = 127 + (256 * 256 * 256) * 1 +local_only = local $ responseLBS H.status403 [("Content-Type", "text/plain")] "local access only" {-# NOINLINE uniqVar #-} @@ -282,17 +325,26 @@ writeTVar uniqVar (u + 1) return u +mimeTypes :: Monad m => FilePath -> m Text +mimeTypes filePath + | ".jpg" `L.isSuffixOf` filePath = return "image/jpeg" + | ".png" `L.isSuffixOf` filePath = return "image/png" + | ".gif" `L.isSuffixOf` filePath = return "image/gif" + | otherwise = fail $ "do not understand mime type for : " ++ show filePath + ------------------------------------------------- -data Options = Options +-- TODO: add extra mime types + + +data Options = Options { port :: Int -- ^ which port do we issue the blank canvas using , events :: [EventName] -- ^ which events does the canvas listen to , debug :: Bool -- ^ turn on debugging (default False) - , static :: [String] -- ^ path to images, and other static artifacts , root :: String -- ^ location of the static files (default .) , middleware :: [Middleware] -- ^ extra middleware(s) to be executed. (default [local_only]) } - + instance Num Options where (+) = error "no arithmetic for Blank Canvas Options" (-) = error "no arithmetic for Blank Canvas Options" @@ -302,7 +354,6 @@ fromInteger n = Options { port = fromInteger n , events = [] , debug = False - , static = [] , root = "." , middleware = [local_only] } @@ -317,9 +368,14 @@ strokeStyle :: Text -> Canvas () strokeStyle = Generated.strokeStyle +shadowColor :: Text -> Canvas () +shadowColor = Generated.shadowColor + +addColorStop :: (Double, Text) -> CanvasGradient -> Canvas () +addColorStop = Canvas.addColorStop + height :: (Image image, Num a) => image -> a height = JavaScript.height width :: (Image image, Num a) => image -> a width = JavaScript.width - diff --git a/Graphics/Blank/Canvas.hs b/Graphics/Blank/Canvas.hs --- a/Graphics/Blank/Canvas.hs +++ b/Graphics/Blank/Canvas.hs @@ -2,28 +2,30 @@ module Graphics.Blank.Canvas where -import Graphics.Blank.Events -import Graphics.Blank.JavaScript +import Control.Applicative +import Control.Monad (ap, liftM2) -import Data.Aeson (FromJSON(..),Value(..),encode) -import Data.Aeson.Types (Parser, (.:)) -import Data.Char (chr) -import Control.Monad (ap, liftM2) -import Control.Applicative -import Data.Monoid +import Graphics.Blank.Events +import Graphics.Blank.JavaScript + +import Data.Aeson (FromJSON(..),Value(..),encode) +import Data.Aeson.Types (Parser, (.:)) +import Data.Char (chr) + import qualified Data.ByteString.Lazy as DBL +import Data.Monoid import qualified Data.Text as Text -import Data.Text (Text) +import Data.Text (Text) data Canvas :: * -> * where - Method :: Method -> Canvas () -- . - Command :: Command -> Canvas () -- - Query :: (Show a) => Query a -> Canvas a - With :: CanvasContext -> Canvas a -> Canvas a - MyContext :: Canvas CanvasContext - Bind :: Canvas a -> (a -> Canvas b) -> Canvas b - Return :: a -> Canvas a + Method :: Method -> Canvas () -- . + Command :: Command -> Canvas () -- + Query :: (Show a) => Query a -> Canvas a + With :: CanvasContext -> Canvas a -> Canvas a + MyContext :: Canvas CanvasContext + Bind :: Canvas a -> (a -> Canvas b) -> Canvas b + Return :: a -> Canvas a instance Monad Canvas where return = Return @@ -40,62 +42,63 @@ mappend = liftM2 mappend mempty = return mempty + -- HTML5 Canvas assignments: FillStyle, Font, GlobalAlpha, GlobalCompositeOperation, LineCap, LineJoin, LineWidth, MiterLimit, ShadowBlur, ShadowColor, ShadowOffsetX, ShadowOffsetY, StrokeStyle, TextAlign, TextBaseline data Method -- regular HTML5 canvas commands - = Arc (Float,Float,Float,Float,Float,Bool) - | ArcTo (Float,Float,Float,Float,Float) + = Arc (Double, Double, Double, Double, Double, Bool) + | ArcTo (Double, Double, Double, Double, Double) | BeginPath - | BezierCurveTo (Float,Float,Float,Float,Float,Float) - | forall image . Image image => DrawImage (image,[Float]) -- 'drawImage' takes 2, 4 or 8 floats arguments - | ClearRect (Float,Float,Float,Float) + | BezierCurveTo (Double, Double, Double, Double, Double, Double) + | ClearRect (Double, Double, Double, Double) | Clip | ClosePath + | forall image . Image image => DrawImage (image,[Double]) -- drawImage' takes 2, 4, or 8 'Double' arguments. See 'drawImageAt', 'drawImageSize', and 'drawImageCrop' for variants with exact numbers of arguments. | Fill - | FillRect (Float,Float,Float,Float) + | FillRect (Double, Double, Double, Double) | forall style . Style style => FillStyle style - | FillText (Text,Float,Float) + | FillText (Text, Double, Double) | Font Text - | GlobalAlpha Float + | GlobalAlpha Double | GlobalCompositeOperation Text - | LineCap Text - | LineJoin Text - | LineTo (Float,Float) - | LineWidth Float - | MiterLimit Float - | MoveTo (Float,Float) - | PutImageData (ImageData,[Float]) - | QuadraticCurveTo (Float,Float,Float,Float) - | Rect (Float,Float,Float,Float) + | LineCap LineEndCap + | LineJoin LineJoinCorner + | LineTo (Double, Double) + | LineWidth Double + | MiterLimit Double + | MoveTo (Double, Double) + | PutImageData (ImageData, [Double]) -- 'putImageData' takes 2 or 6 'Double' arguments. See `putImageDataAt' and `putImageDataDirty' for variants with exact numbers of arguments. + | QuadraticCurveTo (Double, Double, Double, Double) + | Rect (Double, Double, Double, Double) | Restore - | Rotate Float - | Scale (Float,Float) + | Rotate Double | Save - | SetTransform (Float,Float,Float,Float,Float,Float) + | Scale (Double, Double) + | SetTransform (Double, Double, Double, Double, Double, Double) + | ShadowBlur Double + | forall canvasColor . CanvasColor canvasColor => ShadowColor canvasColor + | ShadowOffsetX Double + | ShadowOffsetY Double | Stroke - | StrokeRect (Float,Float,Float,Float) - | StrokeText (Text,Float,Float) + | StrokeRect (Double, Double, Double, Double) | forall style . Style style => StrokeStyle style - | ShadowBlur Float - | ShadowColor Text - | ShadowOffsetX Float - | ShadowOffsetY Float - | TextAlign Text - | TextBaseline Text - | Transform (Float,Float,Float,Float,Float,Float) - | Translate (Float,Float) + | StrokeText (Text,Double, Double) + | TextAlign TextAnchorAlignment + | TextBaseline TextBaselineAlignment + | Transform (Double, Double, Double, Double, Double, Double) + | Translate (Double, Double) data Command = Trigger Event - | AddColorStop (Float,Text) CanvasGradient + | forall color . CanvasColor color => AddColorStop (Double, color) CanvasGradient | forall msg . JSArg msg => Log msg | Eval Text instance Show Command where show (Trigger e) = "Trigger(" ++ map (chr . fromEnum) (DBL.unpack (encode e)) ++ ")" show (AddColorStop (off,rep) g) - = showJS g ++ ".addColorStop(" ++ showJS off ++ "," ++ showJS rep ++ ")" - show (Log msg) = "console.log(" ++ showJS msg ++ ")" + = showJS g ++ ".addColorStop(" ++ showJS off ++ "," ++ jsStyle rep ++ ")" + show (Log msg) = "console.log(" ++ showJS msg ++ ")" show (Eval cmd) = Text.unpack cmd -- no escaping or interpretation ----------------------------------------------------------------------------- @@ -116,7 +119,7 @@ trigger = Command . Trigger -- | add a Color stop to a Canvas Gradient. -addColorStop :: (Float,Text) -> CanvasGradient -> Canvas () +addColorStop :: CanvasColor color => (Double, color) -> CanvasGradient -> Canvas () addColorStop (off,rep) = Command . AddColorStop (off,rep) -- | 'console_log' aids debugging by sending the argument to the browser console.log. @@ -129,22 +132,23 @@ ----------------------------------------------------------------------------- data Query :: * -> * where - Device :: Query DeviceAttributes - ToDataURL :: Query Text - MeasureText :: Text -> Query TextMetrics - IsPointInPath :: (Float,Float) -> Query Bool - NewImage :: Text -> Query CanvasImage - CreateLinearGradient :: (Float,Float,Float,Float) -> Query CanvasGradient - CreateRadialGradient :: (Float,Float,Float,Float,Float,Float) -> Query CanvasGradient - CreatePattern :: Image image => (image,Text) -> Query CanvasPattern - NewCanvas :: (Int,Int) -> Query CanvasContext - GetImageData :: (Float,Float,Float,Float) -> Query ImageData + Device :: Query DeviceAttributes + ToDataURL :: Query Text + MeasureText :: Text -> Query TextMetrics + IsPointInPath :: (Double, Double) -> Query Bool + NewImage :: Text -> Query CanvasImage + CreateLinearGradient :: (Double, Double, Double, Double) -> Query CanvasGradient + CreateRadialGradient :: (Double, Double, Double, Double, Double, Double) -> Query CanvasGradient + CreatePattern :: Image image => (image, RepeatDirection) -> Query CanvasPattern + NewCanvas :: (Int, Int) -> Query CanvasContext + GetImageData :: (Double, Double, Double, Double) -> Query ImageData + Sync :: Query () -data DeviceAttributes = DeviceAttributes Int Int Float +data DeviceAttributes = DeviceAttributes Int Int Double deriving Show - + -- | The 'width' argument of 'TextMetrics' can trivially be projected out. -data TextMetrics = TextMetrics Float +data TextMetrics = TextMetrics Double deriving Show instance Show (Query a) where @@ -155,10 +159,11 @@ show (NewImage url) = "NewImage(" ++ showJS url ++ ")" show (CreateLinearGradient (x0,y0,x1,y1)) = "CreateLinearGradient(" ++ showJS x0 ++ "," ++ showJS y0 ++ "," ++ showJS x1 ++ "," ++ showJS y1 ++ ")" show (CreateRadialGradient (x0,y0,r0,x1,y1,r1)) = "CreateRadialGradient(" ++ showJS x0 ++ "," ++ showJS y0 ++ "," ++ showJS r0 ++ "," ++ showJS x1 ++ "," ++ showJS y1 ++ "," ++ showJS r1 ++ ")" - show (CreatePattern (img,str)) = "CreatePattern(" ++ jsImage img ++ "," ++ showJS str ++ ")" + show (CreatePattern (img,dir)) = "CreatePattern(" ++ jsImage img ++ "," ++ jsRepeatDirection dir ++ ")" show (NewCanvas (x,y)) = "NewCanvas(" ++ showJS x ++ "," ++ showJS y ++ ")" - show (GetImageData (sx,sy,sw,sh)) + show (GetImageData (sx,sy,sw,sh)) = "GetImageData(" ++ showJS sx ++ "," ++ showJS sy ++ "," ++ showJS sw ++ "," ++ showJS sh ++ ")" + show Sync = "Sync" -- This is how we take our value to bits parseQueryResult :: Query a -> Value -> Parser a @@ -171,20 +176,21 @@ parseQueryResult (CreateRadialGradient {}) o = CanvasGradient <$> parseJSON o parseQueryResult (CreatePattern {}) o = CanvasPattern <$> parseJSON o parseQueryResult (NewCanvas {}) o = uncurry3 CanvasContext <$> parseJSON o -parseQueryResult (GetImageData {}) (Object o) = ImageData +parseQueryResult (GetImageData {}) (Object o) = ImageData <$> (o .: "width") <*> (o .: "height") <*> (o .: "data") +parseQueryResult (Sync {}) _ = return () -- we just accept anything; empty list sent parseQueryResult _ _ = fail "no parse in blank-canvas server (internal error)" uncurry3 :: (t0 -> t1 -> t2 -> t3) -> (t0, t1, t2) -> t3 -uncurry3 f (a,b,c) = f a b c +uncurry3 f (a,b,c) = f a b c device :: Canvas DeviceAttributes device = Query Device -- | Turn the canvas into a png data stream / data URL. --- +-- -- > "data:image/png;base64,iVBORw0KGgo.." -- toDataURL :: () -> Canvas Text @@ -193,29 +199,32 @@ measureText :: Text -> Canvas TextMetrics measureText = Query . MeasureText -isPointInPath :: (Float,Float) -> Canvas Bool +isPointInPath :: (Double, Double) -> Canvas Bool isPointInPath = Query . IsPointInPath --- | 'image' takes a URL (perhaps a data URL), and returns the 'CanvasImage' handle, +-- | 'image' takes a URL (perhaps a data URL), and returns the 'CanvasImage' handle, -- _after_ loading. -- The assumption is you are using local images, so loading should be near instant. newImage :: Text -> Canvas CanvasImage -newImage = Query . NewImage +newImage = Query . NewImage -createLinearGradient :: (Float,Float,Float,Float) -> Canvas CanvasGradient +createLinearGradient :: (Double, Double, Double, Double) -> Canvas CanvasGradient createLinearGradient = Query . CreateLinearGradient -createRadialGradient :: (Float,Float,Float,Float,Float,Float) -> Canvas CanvasGradient +createRadialGradient :: (Double, Double, Double, Double, Double, Double) -> Canvas CanvasGradient createRadialGradient = Query . CreateRadialGradient -createPattern :: (CanvasImage, Text) -> Canvas CanvasPattern +createPattern :: (CanvasImage, RepeatDirection) -> Canvas CanvasPattern createPattern = Query . CreatePattern -- | Create a new, off-screen canvas buffer. Takes width and height. -newCanvas :: (Int,Int) -> Canvas CanvasContext +newCanvas :: (Int, Int) -> Canvas CanvasContext newCanvas = Query . NewCanvas -- | Capture ImageDate from the Canvas. -getImageData :: (Float,Float,Float,Float) -> Canvas ImageData -getImageData = Query . GetImageData +getImageData :: (Double, Double, Double, Double) -> Canvas ImageData +getImageData = Query . GetImageData +-- | Send all commands to the browser, wait for the browser to ack, then continue. +sync :: Canvas () +sync = Query $ Sync diff --git a/Graphics/Blank/DeviceContext.hs b/Graphics/Blank/DeviceContext.hs --- a/Graphics/Blank/DeviceContext.hs +++ b/Graphics/Blank/DeviceContext.hs @@ -1,29 +1,33 @@ {-# LANGUAGE OverloadedStrings #-} module Graphics.Blank.DeviceContext where -import Graphics.Blank.JavaScript -import Control.Concurrent.STM - -import qualified Web.Scotty.Comet as KC +import Control.Concurrent.STM -import Graphics.Blank.Events -import Data.Monoid((<>)) +import Data.Set (Set) +import Data.Monoid ((<>)) +import Data.Text (Text) import qualified Data.Text as T +import Graphics.Blank.Events +import Graphics.Blank.JavaScript + +import qualified Web.Scotty.Comet as KC + -- | 'Context' is our abstact handle into a specific 2d-context inside a browser. -- Note that the JavaScript API concepts of 2D-Context and Canvas -- are conflated in blank-canvas. Therefore, there is no 'getContext' method, -- rather 'getContext' is implied (when using 'send'). data DeviceContext = DeviceContext - { theComet :: KC.Document -- ^ The mechansims for sending commands - , eventQueue :: EventQueue -- ^ A single (typed) event queue - , ctx_width :: !Int - , ctx_height :: !Int - , ctx_devicePixelRatio :: !Float + { theComet :: KC.Document -- ^ The mechansims for sending commands + , eventQueue :: EventQueue -- ^ A single (typed) event queue + , ctx_width :: !Int + , ctx_height :: !Int + , ctx_devicePixelRatio :: !Double + , localFiles :: TVar (Set Text) -- ^ approved local files } -instance Image DeviceContext where +instance Image DeviceContext where jsImage = jsImage . deviceCanvasContext width = fromIntegral . ctx_width height = fromIntegral . ctx_height @@ -36,7 +40,7 @@ -- to use the native devicePixelRatio, and if successful, 'devicePixelRatio' will return a number other than 1. -- You can think of devicePixelRatio as the line width to use to make lines look one pixel wide. -devicePixelRatio :: DeviceContext -> Float +devicePixelRatio :: DeviceContext -> Double devicePixelRatio = ctx_devicePixelRatio -- | internal command to send a message to the canvas. @@ -51,7 +55,7 @@ -- | 'flush' all the current events, returning them all to the user. Never blocks. flush :: DeviceContext -> IO [Event] flush cxt = atomically $ loop - where loop = do + where loop = do b <- isEmptyTChan (eventQueue cxt) if b then return [] else do e <- readTChan (eventQueue cxt) diff --git a/Graphics/Blank/Events.hs b/Graphics/Blank/Events.hs --- a/Graphics/Blank/Events.hs +++ b/Graphics/Blank/Events.hs @@ -1,16 +1,17 @@ {-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-} module Graphics.Blank.Events where +import Control.Applicative ((<|>), (<$>), (<*>)) +import Control.Concurrent.STM + import Data.Aeson (FromJSON(..), Value(..), ToJSON(..)) import Data.Aeson.Types ((.:), (.=), object) -import Control.Applicative((<|>),(<$>),(<*>)) -import Control.Concurrent.STM import Data.Text (Text) --- | Basic Event from Browser; see for details. +-- | Basic Event from Browser; see for details. data Event = Event { eMetaKey :: Bool - , ePageXY :: Maybe (Float,Float) + , ePageXY :: Maybe (Double, Double) , eType :: EventName -- "Describes the nature of the event." jquery , eWhich :: Maybe Int -- magic code for key presses } @@ -18,22 +19,22 @@ instance FromJSON Event where - parseJSON (Object v) = Event <$> ((v .: "eMetaKey") <|> return False) - <*> (Just <$> (v .: "ePageXY") <|> return Nothing) - <*> (v .: "eType") - <*> (Just <$> (v .: "eWhich") <|> return Nothing) + parseJSON (Object v) = Event <$> ((v .: "metaKey") <|> return False) + <*> (Just <$> (v .: "pageXY") <|> return Nothing) + <*> (v .: "type") + <*> (Just <$> (v .: "which") <|> return Nothing) parseJSON _ = fail "no parse of Event" instance ToJSON Event where toJSON e = object - $ ((:) ("eMetaKey" .= eMetaKey e)) + $ ((:) ("metaKey" .= eMetaKey e)) $ (case ePageXY e of Nothing -> id - Just (x,y) -> (:) ("ePageXY" .= (x,y))) - $ ((:) ("eType" .= eType e)) + Just (x,y) -> (:) ("pageXY" .= (x,y))) + $ ((:) ("type" .= eType e)) $ (case eWhich e of Nothing -> id - Just w -> (:) ("eWhich" .= w)) + Just w -> (:) ("which" .= w)) $ [] -- | 'EventName' mirrors event names from jquery, and use lower case. diff --git a/Graphics/Blank/GHCi.hs b/Graphics/Blank/GHCi.hs --- a/Graphics/Blank/GHCi.hs +++ b/Graphics/Blank/GHCi.hs @@ -3,10 +3,11 @@ import Control.Concurrent import Control.Concurrent.STM import Control.Monad -import System.IO.Unsafe (unsafePerformIO) import Graphics.Blank (Options(..),port,send, Canvas, blankCanvas) +import System.IO.Unsafe (unsafePerformIO) + -- | splitCanvas is the GHCi entry point into blank-canvas. -- A typical invocation would be -- @@ -39,6 +40,6 @@ -- common TVar for all ports in use. {-# NOINLINE usedPorts #-} -usedPorts :: TVar [(Int,TMVar (Canvas ()))] +usedPorts :: TVar [(Int, TMVar (Canvas ()))] usedPorts = unsafePerformIO $ newTVarIO [] diff --git a/Graphics/Blank/Generated.hs b/Graphics/Blank/Generated.hs --- a/Graphics/Blank/Generated.hs +++ b/Graphics/Blank/Generated.hs @@ -6,67 +6,63 @@ import Data.Text (Text) instance Show Method where - show (Arc (a1,a2,a3,a4,a5,a6)) = "arc(" ++ jsFloat a1 ++ "," ++ jsFloat a2 ++ "," ++ jsFloat a3 ++ "," ++ jsFloat a4 ++ "," ++ jsFloat a5 ++ "," ++ jsBool a6 ++ ")" - show (ArcTo (a1,a2,a3,a4,a5)) = "arcTo(" ++ jsFloat a1 ++ "," ++ jsFloat a2 ++ "," ++ jsFloat a3 ++ "," ++ jsFloat a4 ++ "," ++ jsFloat a5 ++ ")" + show (Arc (a1,a2,a3,a4,a5,a6)) = "arc(" ++ jsDouble a1 ++ "," ++ jsDouble a2 ++ "," ++ jsDouble a3 ++ "," ++ jsDouble a4 ++ "," ++ jsDouble a5 ++ "," ++ jsBool a6 ++ ")" + show (ArcTo (a1,a2,a3,a4,a5)) = "arcTo(" ++ jsDouble a1 ++ "," ++ jsDouble a2 ++ "," ++ jsDouble a3 ++ "," ++ jsDouble a4 ++ "," ++ jsDouble a5 ++ ")" show BeginPath = "beginPath()" - show (BezierCurveTo (a1,a2,a3,a4,a5,a6)) = "bezierCurveTo(" ++ jsFloat a1 ++ "," ++ jsFloat a2 ++ "," ++ jsFloat a3 ++ "," ++ jsFloat a4 ++ "," ++ jsFloat a5 ++ "," ++ jsFloat a6 ++ ")" - show (DrawImage (a1,a2)) = "drawImage(" ++ jsImage a1 ++ "," ++ jsList jsFloat a2 ++ ")" - show (ClearRect (a1,a2,a3,a4)) = "clearRect(" ++ jsFloat a1 ++ "," ++ jsFloat a2 ++ "," ++ jsFloat a3 ++ "," ++ jsFloat a4 ++ ")" + show (BezierCurveTo (a1,a2,a3,a4,a5,a6)) = "bezierCurveTo(" ++ jsDouble a1 ++ "," ++ jsDouble a2 ++ "," ++ jsDouble a3 ++ "," ++ jsDouble a4 ++ "," ++ jsDouble a5 ++ "," ++ jsDouble a6 ++ ")" + show (ClearRect (a1,a2,a3,a4)) = "clearRect(" ++ jsDouble a1 ++ "," ++ jsDouble a2 ++ "," ++ jsDouble a3 ++ "," ++ jsDouble a4 ++ ")" show Clip = "clip()" show ClosePath = "closePath()" + show (DrawImage (a1,a2)) = "drawImage(" ++ jsImage a1 ++ "," ++ jsList jsDouble a2 ++ ")" show Fill = "fill()" - show (FillRect (a1,a2,a3,a4)) = "fillRect(" ++ jsFloat a1 ++ "," ++ jsFloat a2 ++ "," ++ jsFloat a3 ++ "," ++ jsFloat a4 ++ ")" + show (FillRect (a1,a2,a3,a4)) = "fillRect(" ++ jsDouble a1 ++ "," ++ jsDouble a2 ++ "," ++ jsDouble a3 ++ "," ++ jsDouble a4 ++ ")" show (FillStyle (a1)) = "fillStyle = (" ++ jsStyle a1 ++ ")" - show (FillText (a1,a2,a3)) = "fillText(" ++ jsText a1 ++ "," ++ jsFloat a2 ++ "," ++ jsFloat a3 ++ ")" + show (FillText (a1,a2,a3)) = "fillText(" ++ jsText a1 ++ "," ++ jsDouble a2 ++ "," ++ jsDouble a3 ++ ")" show (Font (a1)) = "font = (" ++ jsText a1 ++ ")" - show (GlobalAlpha (a1)) = "globalAlpha = (" ++ jsFloat a1 ++ ")" + show (GlobalAlpha (a1)) = "globalAlpha = (" ++ jsDouble a1 ++ ")" show (GlobalCompositeOperation (a1)) = "globalCompositeOperation = (" ++ jsText a1 ++ ")" - show (LineCap (a1)) = "lineCap = (" ++ jsText a1 ++ ")" - show (LineJoin (a1)) = "lineJoin = (" ++ jsText a1 ++ ")" - show (LineTo (a1,a2)) = "lineTo(" ++ jsFloat a1 ++ "," ++ jsFloat a2 ++ ")" - show (LineWidth (a1)) = "lineWidth = (" ++ jsFloat a1 ++ ")" - show (MiterLimit (a1)) = "miterLimit = (" ++ jsFloat a1 ++ ")" - show (MoveTo (a1,a2)) = "moveTo(" ++ jsFloat a1 ++ "," ++ jsFloat a2 ++ ")" - show (PutImageData (a1,a2)) = "putImageData(" ++ jsImageData a1 ++ "," ++ jsList jsFloat a2 ++ ")" - show (QuadraticCurveTo (a1,a2,a3,a4)) = "quadraticCurveTo(" ++ jsFloat a1 ++ "," ++ jsFloat a2 ++ "," ++ jsFloat a3 ++ "," ++ jsFloat a4 ++ ")" - show (Rect (a1,a2,a3,a4)) = "rect(" ++ jsFloat a1 ++ "," ++ jsFloat a2 ++ "," ++ jsFloat a3 ++ "," ++ jsFloat a4 ++ ")" + show (LineCap (a1)) = "lineCap = (" ++ jsLineEndCap a1 ++ ")" + show (LineJoin (a1)) = "lineJoin = (" ++ jsLineJoinCorner a1 ++ ")" + show (LineTo (a1,a2)) = "lineTo(" ++ jsDouble a1 ++ "," ++ jsDouble a2 ++ ")" + show (LineWidth (a1)) = "lineWidth = (" ++ jsDouble a1 ++ ")" + show (MiterLimit (a1)) = "miterLimit = (" ++ jsDouble a1 ++ ")" + show (MoveTo (a1,a2)) = "moveTo(" ++ jsDouble a1 ++ "," ++ jsDouble a2 ++ ")" + show (PutImageData (a1,a2)) = "putImageData(" ++ jsImageData a1 ++ "," ++ jsList jsDouble a2 ++ ")" + show (QuadraticCurveTo (a1,a2,a3,a4)) = "quadraticCurveTo(" ++ jsDouble a1 ++ "," ++ jsDouble a2 ++ "," ++ jsDouble a3 ++ "," ++ jsDouble a4 ++ ")" + show (Rect (a1,a2,a3,a4)) = "rect(" ++ jsDouble a1 ++ "," ++ jsDouble a2 ++ "," ++ jsDouble a3 ++ "," ++ jsDouble a4 ++ ")" show Restore = "restore()" - show (Rotate (a1)) = "rotate(" ++ jsFloat a1 ++ ")" - show (Scale (a1,a2)) = "scale(" ++ jsFloat a1 ++ "," ++ jsFloat a2 ++ ")" + show (Rotate (a1)) = "rotate(" ++ jsDouble a1 ++ ")" show Save = "save()" - show (SetTransform (a1,a2,a3,a4,a5,a6)) = "setTransform(" ++ jsFloat a1 ++ "," ++ jsFloat a2 ++ "," ++ jsFloat a3 ++ "," ++ jsFloat a4 ++ "," ++ jsFloat a5 ++ "," ++ jsFloat a6 ++ ")" + show (Scale (a1,a2)) = "scale(" ++ jsDouble a1 ++ "," ++ jsDouble a2 ++ ")" + show (SetTransform (a1,a2,a3,a4,a5,a6)) = "setTransform(" ++ jsDouble a1 ++ "," ++ jsDouble a2 ++ "," ++ jsDouble a3 ++ "," ++ jsDouble a4 ++ "," ++ jsDouble a5 ++ "," ++ jsDouble a6 ++ ")" + show (ShadowBlur (a1)) = "shadowBlur = (" ++ jsDouble a1 ++ ")" + show (ShadowColor (a1)) = "shadowColor = (" ++ jsCanvasColor a1 ++ ")" + show (ShadowOffsetX (a1)) = "shadowOffsetX = (" ++ jsDouble a1 ++ ")" + show (ShadowOffsetY (a1)) = "shadowOffsetY = (" ++ jsDouble a1 ++ ")" show Stroke = "stroke()" - show (StrokeRect (a1,a2,a3,a4)) = "strokeRect(" ++ jsFloat a1 ++ "," ++ jsFloat a2 ++ "," ++ jsFloat a3 ++ "," ++ jsFloat a4 ++ ")" - show (StrokeText (a1,a2,a3)) = "strokeText(" ++ jsText a1 ++ "," ++ jsFloat a2 ++ "," ++ jsFloat a3 ++ ")" + show (StrokeRect (a1,a2,a3,a4)) = "strokeRect(" ++ jsDouble a1 ++ "," ++ jsDouble a2 ++ "," ++ jsDouble a3 ++ "," ++ jsDouble a4 ++ ")" show (StrokeStyle (a1)) = "strokeStyle = (" ++ jsStyle a1 ++ ")" - show (ShadowBlur (a1)) = "shadowBlur = (" ++ jsFloat a1 ++ ")" - show (ShadowColor (a1)) = "shadowColor = (" ++ jsText a1 ++ ")" - show (ShadowOffsetX (a1)) = "shadowOffsetX = (" ++ jsFloat a1 ++ ")" - show (ShadowOffsetY (a1)) = "shadowOffsetY = (" ++ jsFloat a1 ++ ")" - show (TextAlign (a1)) = "textAlign = (" ++ jsText a1 ++ ")" - show (TextBaseline (a1)) = "textBaseline = (" ++ jsText a1 ++ ")" - show (Transform (a1,a2,a3,a4,a5,a6)) = "transform(" ++ jsFloat a1 ++ "," ++ jsFloat a2 ++ "," ++ jsFloat a3 ++ "," ++ jsFloat a4 ++ "," ++ jsFloat a5 ++ "," ++ jsFloat a6 ++ ")" - show (Translate (a1,a2)) = "translate(" ++ jsFloat a1 ++ "," ++ jsFloat a2 ++ ")" + show (StrokeText (a1,a2,a3)) = "strokeText(" ++ jsText a1 ++ "," ++ jsDouble a2 ++ "," ++ jsDouble a3 ++ ")" + show (TextAlign (a1)) = "textAlign = (" ++ jsTextAnchorAlignment a1 ++ ")" + show (TextBaseline (a1)) = "textBaseline = (" ++ jsTextBaselineAlignment a1 ++ ")" + show (Transform (a1,a2,a3,a4,a5,a6)) = "transform(" ++ jsDouble a1 ++ "," ++ jsDouble a2 ++ "," ++ jsDouble a3 ++ "," ++ jsDouble a4 ++ "," ++ jsDouble a5 ++ "," ++ jsDouble a6 ++ ")" + show (Translate (a1,a2)) = "translate(" ++ jsDouble a1 ++ "," ++ jsDouble a2 ++ ")" -- DSL -arc :: (Float,Float,Float,Float,Float,Bool) -> Canvas () +arc :: (Double, Double, Double, Double, Double, Bool) -> Canvas () arc = Method . Arc -arcTo :: (Float,Float,Float,Float,Float) -> Canvas () +arcTo :: (Double, Double, Double, Double, Double) -> Canvas () arcTo = Method . ArcTo beginPath :: () -> Canvas () beginPath () = Method BeginPath -bezierCurveTo :: (Float,Float,Float,Float,Float,Float) -> Canvas () +bezierCurveTo :: (Double, Double, Double, Double, Double, Double) -> Canvas () bezierCurveTo = Method . BezierCurveTo --- | 'drawImage' takes 2, 4 or 8 floats arguments -drawImage :: Image image => (image,[Float]) -> Canvas () -drawImage = Method . DrawImage - -clearRect :: (Float,Float,Float,Float) -> Canvas () +clearRect :: (Double, Double, Double, Double) -> Canvas () clearRect = Method . ClearRect clip :: () -> Canvas () @@ -75,102 +71,107 @@ closePath :: () -> Canvas () closePath () = Method ClosePath +-- | drawImage' takes 2, 4, or 8 'Double' arguments. See 'drawImageAt', 'drawImageSize', and 'drawImageCrop' for variants with exact numbers of arguments. +drawImage :: Image image => (image,[Double]) -> Canvas () +drawImage = Method . DrawImage + fill :: () -> Canvas () fill () = Method Fill -fillRect :: (Float,Float,Float,Float) -> Canvas () +fillRect :: (Double, Double, Double, Double) -> Canvas () fillRect = Method . FillRect fillStyle :: Style style => style -> Canvas () fillStyle = Method . FillStyle -fillText :: (Text,Float,Float) -> Canvas () +fillText :: (Text, Double, Double) -> Canvas () fillText = Method . FillText font :: Text -> Canvas () font = Method . Font -globalAlpha :: Float -> Canvas () +globalAlpha :: Double -> Canvas () globalAlpha = Method . GlobalAlpha globalCompositeOperation :: Text -> Canvas () globalCompositeOperation = Method . GlobalCompositeOperation -lineCap :: Text -> Canvas () +lineCap :: LineEndCap -> Canvas () lineCap = Method . LineCap -lineJoin :: Text -> Canvas () +lineJoin :: LineJoinCorner -> Canvas () lineJoin = Method . LineJoin -lineTo :: (Float,Float) -> Canvas () +lineTo :: (Double, Double) -> Canvas () lineTo = Method . LineTo -lineWidth :: Float -> Canvas () +lineWidth :: Double -> Canvas () lineWidth = Method . LineWidth -miterLimit :: Float -> Canvas () +miterLimit :: Double -> Canvas () miterLimit = Method . MiterLimit -moveTo :: (Float,Float) -> Canvas () +moveTo :: (Double, Double) -> Canvas () moveTo = Method . MoveTo -putImageData :: (ImageData,[Float]) -> Canvas () +-- | 'putImageData' takes 2 or 6 'Double' arguments. See `putImageDataAt' and `putImageDataDirty' for variants with exact numbers of arguments. +putImageData :: (ImageData, [Double]) -> Canvas () putImageData = Method . PutImageData -quadraticCurveTo :: (Float,Float,Float,Float) -> Canvas () +quadraticCurveTo :: (Double, Double, Double, Double) -> Canvas () quadraticCurveTo = Method . QuadraticCurveTo -rect :: (Float,Float,Float,Float) -> Canvas () +rect :: (Double, Double, Double, Double) -> Canvas () rect = Method . Rect restore :: () -> Canvas () restore () = Method Restore -rotate :: Float -> Canvas () +rotate :: Double -> Canvas () rotate = Method . Rotate -scale :: (Float,Float) -> Canvas () -scale = Method . Scale - save :: () -> Canvas () save () = Method Save -setTransform :: (Float,Float,Float,Float,Float,Float) -> Canvas () +scale :: (Double, Double) -> Canvas () +scale = Method . Scale + +setTransform :: (Double, Double, Double, Double, Double, Double) -> Canvas () setTransform = Method . SetTransform +shadowBlur :: Double -> Canvas () +shadowBlur = Method . ShadowBlur + +shadowColor :: CanvasColor canvasColor => canvasColor -> Canvas () +shadowColor = Method . ShadowColor + +shadowOffsetX :: Double -> Canvas () +shadowOffsetX = Method . ShadowOffsetX + +shadowOffsetY :: Double -> Canvas () +shadowOffsetY = Method . ShadowOffsetY + stroke :: () -> Canvas () stroke () = Method Stroke -strokeRect :: (Float,Float,Float,Float) -> Canvas () +strokeRect :: (Double, Double, Double, Double) -> Canvas () strokeRect = Method . StrokeRect -strokeText :: (Text,Float,Float) -> Canvas () -strokeText = Method . StrokeText - strokeStyle :: Style style => style -> Canvas () strokeStyle = Method . StrokeStyle -shadowBlur :: Float -> Canvas () -shadowBlur = Method . ShadowBlur - -shadowColor :: Text -> Canvas () -shadowColor = Method . ShadowColor - -shadowOffsetX :: Float -> Canvas () -shadowOffsetX = Method . ShadowOffsetX - -shadowOffsetY :: Float -> Canvas () -shadowOffsetY = Method . ShadowOffsetY +strokeText :: (Text,Double, Double) -> Canvas () +strokeText = Method . StrokeText -textAlign :: Text -> Canvas () +textAlign :: TextAnchorAlignment -> Canvas () textAlign = Method . TextAlign -textBaseline :: Text -> Canvas () +textBaseline :: TextBaselineAlignment -> Canvas () textBaseline = Method . TextBaseline -transform :: (Float,Float,Float,Float,Float,Float) -> Canvas () +transform :: (Double, Double, Double, Double, Double, Double) -> Canvas () transform = Method . Transform -translate :: (Float,Float) -> Canvas () +translate :: (Double, Double) -> Canvas () translate = Method . Translate diff --git a/Graphics/Blank/JavaScript.hs b/Graphics/Blank/JavaScript.hs --- a/Graphics/Blank/JavaScript.hs +++ b/Graphics/Blank/JavaScript.hs @@ -2,51 +2,75 @@ module Graphics.Blank.JavaScript where -import Data.List -import Data.Word (Word8) -import Numeric -import Data.Text (Text) +import Control.Applicative +import Data.Char (isControl, isAscii, ord) +import Data.Colour +import Data.Colour.SRGB +import Data.Default.Class +import Data.Ix +import Data.List +import Data.String +import Data.Text (Text, unpack) +import Data.Word (Word8) + import qualified Data.Vector.Unboxed as V -import Data.Vector.Unboxed (Vector) +import Data.Vector.Unboxed (Vector) +import Numeric + +import Text.ParserCombinators.ReadP (skipSpaces, string) +import Text.ParserCombinators.ReadPrec +import Text.Read + ------------------------------------------------------------- --- TODO: close off +-- TODO: close off class Image a where jsImage :: a -> String width :: Num b => a -> b height :: Num b => a -> b -instance Image CanvasImage where +instance Image CanvasImage where jsImage = jsCanvasImage - width (CanvasImage _ w _) = fromIntegral w + width (CanvasImage _ w _) = fromIntegral w height (CanvasImage _ _ h) = fromIntegral h - + -- The Image of a canvas is the the canvas context, not the DOM entry, so -- you need to indirect back to the DOM here. instance Image CanvasContext where jsImage = (++ ".canvas") . jsCanvasContext - width (CanvasContext _ w _) = fromIntegral w + width (CanvasContext _ w _) = fromIntegral w height (CanvasContext _ _ h) = fromIntegral h -- instance Element Video -- Not supported ----------------------------------------------------------------------------- --- TODO: close off +-- TODO: close off class Style a where jsStyle :: a -> String -instance Style Text where { jsStyle = jsText } -instance Style CanvasGradient where { jsStyle = jsCanvasGradient } -instance Style CanvasPattern where { jsStyle = jsCanvasPattern } +instance Style Text where { jsStyle = jsText } +instance Style CanvasGradient where { jsStyle = jsCanvasGradient } +instance Style CanvasPattern where { jsStyle = jsCanvasPattern } +instance Style (Colour Double) where { jsStyle = jsColour } +instance Style (AlphaColour Double) where { jsStyle = jsAlphaColour } +class Style a => CanvasColor a + +jsCanvasColor :: CanvasColor color => color -> String +jsCanvasColor = jsStyle + +instance CanvasColor Text +instance CanvasColor (Colour Double) +instance CanvasColor (AlphaColour Double) + ------------------------------------------------------------- -- | A handle to an offscreen canvas. CanvasContext can not be destroyed. data CanvasContext = CanvasContext Int Int Int - deriving (Show,Eq,Ord) + deriving (Show,Eq,Ord) -- | A handle to the Image. CanvasImages can not be destroyed. data CanvasImage = CanvasImage Int Int Int deriving (Show,Eq,Ord) @@ -59,11 +83,173 @@ ------------------------------------------------------------- +-- | The direction in which a 'CanvasPattern' repeats. +data RepeatDirection = Repeat -- ^ The pattern repeats both horizontally + -- and vertically. + | RepeatX -- ^ The pattern repeats only horizontally. + | RepeatY -- ^ The pattern repeats only vertically. + | NoRepeat -- ^ The pattern displays only once and + -- does not repeat. + deriving Eq + +instance Default RepeatDirection where + def = Repeat + +instance IsString RepeatDirection where + fromString = read + +instance Read RepeatDirection where + readPrec = parens . lift $ do + skipSpaces + (string "repeat" >> return Repeat) + <|> (string "repeat-x" >> return RepeatX) + <|> (string "repeat-y" >> return RepeatY) + <|> (string "no-repeat" >> return NoRepeat) + +instance Show RepeatDirection where + showsPrec _ rd = showString $ case rd of + Repeat -> "repeat" + RepeatX -> "repeat-x" + RepeatY -> "repeat-y" + NoRepeat -> "no-repeat" + +-- | The style of the caps on the endpoints of a line. +data LineEndCap = ButtCap -- ^ Flat edges + | RoundCap -- ^ Semicircular end caps + | SquareCap -- ^ Square end caps + deriving Eq + +instance Default LineEndCap where + def = ButtCap + +instance IsString LineEndCap where + fromString = read + +instance Read LineEndCap where + readPrec = parens $ do + Ident s <- lexP + case s of + "butt" -> return ButtCap + "round" -> return RoundCap + "square" -> return SquareCap + _ -> pfail + +instance Show LineEndCap where + showsPrec _ le = showString $ case le of + ButtCap -> "butt" + RoundCap -> "round" + SquareCap -> "square" + +-- | The style of corner that is created when two lines join. +data LineJoinCorner = BevelCorner -- ^ A filled triangle with a beveled edge + -- connects two lines. + | RoundCorner -- ^ A filled arc connects two lines. + | MiterCorner -- ^ A filled triangle with a sharp edge + -- connects two lines. + deriving Eq + +instance Default LineJoinCorner where + def = MiterCorner + +instance IsString LineJoinCorner where + fromString = read + +instance Read LineJoinCorner where + readPrec = parens $ do + Ident s <- lexP + case s of + "bevel" -> return BevelCorner + "round" -> return RoundCorner + "miter" -> return MiterCorner + _ -> pfail + +instance Show LineJoinCorner where + showsPrec _ corner = showString $ case corner of + BevelCorner -> "bevel" + RoundCorner -> "round" + MiterCorner -> "miter" + +-- | The anchor point for text in the current 'DeviceContext'. +data TextAnchorAlignment = StartAnchor -- ^ The text is anchored at either its left edge + -- (if the canvas is left-to-right) or its right + -- edge (if the canvas is right-to-left). + | EndAnchor -- ^ The text is anchored at either its right edge + -- (if the canvas is left-to-right) or its left + -- edge (if the canvas is right-to-left). + | CenterAnchor -- ^ The text is anchored in its center. + | LeftAnchor -- ^ The text is anchored at its left edge. + | RightAnchor -- ^ the text is anchored at its right edge. + deriving Eq + +instance Default TextAnchorAlignment where + def = StartAnchor + +instance IsString TextAnchorAlignment where + fromString = read + +instance Read TextAnchorAlignment where + readPrec = parens $ do + Ident s <- lexP + case s of + "start" -> return StartAnchor + "end" -> return EndAnchor + "center" -> return CenterAnchor + "left" -> return LeftAnchor + "right" -> return RightAnchor + _ -> pfail + +instance Show TextAnchorAlignment where + showsPrec _ align = showString $ case align of + StartAnchor -> "start" + EndAnchor -> "end" + CenterAnchor -> "center" + LeftAnchor -> "left" + RightAnchor -> "right" + +-- | The baseline alignment used when drawing text in the current 'DeviceContext'. +-- The baselines are ordered from highest ('Top') to lowest ('Bottom'). +data TextBaselineAlignment = TopBaseline + | HangingBaseline + | MiddleBaseline + | AlphabeticBaseline + | IdeographicBaseline + | BottomBaseline + deriving (Bounded, Eq, Ix, Ord) + +instance Default TextBaselineAlignment where + def = AlphabeticBaseline + +instance IsString TextBaselineAlignment where + fromString = read + +instance Read TextBaselineAlignment where + readPrec = parens $ do + Ident s <- lexP + case s of + "top" -> return TopBaseline + "hanging" -> return HangingBaseline + "middle" -> return MiddleBaseline + "alphabetic" -> return AlphabeticBaseline + "ideographic" -> return IdeographicBaseline + "bottom" -> return BottomBaseline + _ -> pfail + +instance Show TextBaselineAlignment where + showsPrec _ bl = showString $ case bl of + TopBaseline -> "top" + HangingBaseline -> "hanging" + MiddleBaseline -> "middle" + AlphabeticBaseline -> "alphabetic" + IdeographicBaseline -> "ideographic" + BottomBaseline -> "bottom" + +------------------------------------------------------------- + -- | 'ImageData' is a transliteration of the JavaScript ImageData, -- There are two 'Int's, and one (unboxed) 'Vector' of 'Word8's. -- width, height, data can be projected from 'ImageData', -- 'Vector.length' can be used to find the length. --- +-- -- Note: 'ImageData' lives on the server, not the client. data ImageData = ImageData !Int !Int !(Vector Word8) deriving (Show, Eq, Ord) @@ -73,32 +259,47 @@ class JSArg a where showJS :: a -> String -instance JSArg Float where - showJS a = showFFloat (Just 3) a "" +instance JSArg (AlphaColour Double) where + showJS aCol + | a >= 1 = jsColour rgbCol + | a <= 0 = jsLiteralString "rgba(0,0,0,0)" + | otherwise = jsLiteralString $ "rgba(" + ++ show r ++ "," + ++ show g ++ "," + ++ show b ++ "," + ++ jsDouble a ++ ")" + where + a = alphaChannel aCol + rgbCol = darken (recip a) $ aCol `over` black + RGB r g b = toSRGB24 rgbCol -jsFloat :: Float -> String -jsFloat = showJS +jsAlphaColour :: AlphaColour Double -> String +jsAlphaColour = showJS -instance JSArg Int where - showJS a = show a +instance JSArg Bool where + showJS True = "true" + showJS False = "false" +jsBool :: Bool -> String +jsBool = showJS + instance JSArg CanvasContext where showJS (CanvasContext n _ _) = "canvasbuffers[" ++ show n ++ "]" jsCanvasContext :: CanvasContext -> String -jsCanvasContext = showJS +jsCanvasContext = showJS instance JSArg CanvasImage where showJS (CanvasImage n _ _) = "images[" ++ show n ++ "]" jsCanvasImage :: CanvasImage -> String -jsCanvasImage = showJS +jsCanvasImage = showJS instance JSArg CanvasGradient where showJS (CanvasGradient n) = "gradients[" ++ show n ++ "]" jsCanvasGradient :: CanvasGradient -> String -jsCanvasGradient = showJS +jsCanvasGradient = showJS instance JSArg CanvasPattern where showJS (CanvasPattern n) = "patterns[" ++ show n ++ "]" @@ -106,6 +307,18 @@ jsCanvasPattern :: CanvasPattern -> String jsCanvasPattern = showJS +instance JSArg (Colour Double) where + showJS = jsLiteralString . sRGB24show + +jsColour :: Colour Double -> String +jsColour = showJS + +instance JSArg Double where + showJS a = showFFloat (Just 3) a "" + +jsDouble :: Double -> String +jsDouble = showJS + instance JSArg ImageData where showJS (ImageData w h d) = "ImageData(" ++ show w ++ "," ++ show h ++ ",[" ++ vs ++ "])" where @@ -114,18 +327,86 @@ jsImageData :: ImageData -> String jsImageData = showJS -instance JSArg Bool where - showJS True = "true" - showJS False = "false" +instance JSArg Int where + showJS a = show a -jsBool :: Bool -> String -jsBool = showJS +instance JSArg LineEndCap where + showJS = jsLiteralString . show -instance JSArg Text where - showJS str = show str +jsLineEndCap :: LineEndCap -> String +jsLineEndCap = showJS +instance JSArg LineJoinCorner where + showJS = jsLiteralString . show + +jsLineJoinCorner :: LineJoinCorner -> String +jsLineJoinCorner = showJS + +jsList :: (a -> String) -> [a] -> String +jsList js = concat . intersperse "," . map js + +instance JSArg RepeatDirection where + showJS = jsLiteralString . show + +jsRepeatDirection :: RepeatDirection -> String +jsRepeatDirection = showJS + +instance JSArg Text where + showJS = jsLiteralString . unpack + jsText :: Text -> String jsText = showJS -jsList :: (a -> String) -> [a] -> String -jsList js = concat . intersperse "," . map js +instance JSArg TextAnchorAlignment where + showJS = jsLiteralString . show + +jsTextAnchorAlignment :: TextAnchorAlignment -> String +jsTextAnchorAlignment = showJS + +instance JSArg TextBaselineAlignment where + showJS = jsLiteralString . show + +jsTextBaselineAlignment :: TextBaselineAlignment -> String +jsTextBaselineAlignment = showJS + +-- The following was from our Sunroof compiler. +-- ------------------------------------------------------------- +-- String Conversion Utilities: Haskell -> JS +-- ------------------------------------------------------------- + +-- | Transform a Haskell string into a string representing a JS string literal. +jsLiteralString :: String -> String +jsLiteralString = jsQuoteString . jsEscapeString + +-- | Add quotes to a string. +jsQuoteString :: String -> String +jsQuoteString s = "\"" ++ s ++ "\"" + +-- | Transform a character to a string that represents its JS +-- unicode escape sequence. +jsUnicodeChar :: Char -> String +jsUnicodeChar c = + let hex = showHex (ord c) "" + in ('\\':'u': replicate (4 - length hex) '0') ++ hex + +-- | Correctly replace Haskell characters by the JS escape sequences. +jsEscapeString :: String -> String +jsEscapeString [] = [] +jsEscapeString (c:cs) = case c of + -- Backslash has to remain backslash in JS. + '\\' -> '\\' : '\\' : jsEscapeString cs + -- Special control sequences. + '\0' -> jsUnicodeChar '\0' ++ jsEscapeString cs -- Ambigous with numbers + '\a' -> jsUnicodeChar '\a' ++ jsEscapeString cs -- Non JS + '\b' -> '\\' : 'b' : jsEscapeString cs + '\f' -> '\\' : 'f' : jsEscapeString cs + '\n' -> '\\' : 'n' : jsEscapeString cs + '\r' -> '\\' : 'r' : jsEscapeString cs + '\t' -> '\\' : 't' : jsEscapeString cs + '\v' -> '\\' : 'v' : jsEscapeString cs + '\"' -> '\\' : '\"' : jsEscapeString cs + '\'' -> '\\' : '\'' : jsEscapeString cs + -- Non-control ASCII characters can remain as they are. + c' | not (isControl c') && isAscii c' -> c' : jsEscapeString cs + -- All other non ASCII signs are escaped to unicode. + c' -> jsUnicodeChar c' ++ jsEscapeString cs diff --git a/Graphics/Blank/Style.hs b/Graphics/Blank/Style.hs --- a/Graphics/Blank/Style.hs +++ b/Graphics/Blank/Style.hs @@ -1,13 +1,841 @@ --- | These are overloaded versions of 'strokeStyle' and 'fillStyle'. - module Graphics.Blank.Style - ( strokeStyle + ( -- * Overloaded versions of 'Canvas' functions + strokeStyle , fillStyle - , Style + , shadowColor + , addColorStop + , Style(..) + , CanvasColor + -- * 'CanvasColor' creation + , Alpha + , Percentage + , rgb + , rgbPercent + , rgba + , rgbaPercent + , hsl + , hsla + -- * @colour@ reexports + , readColourName + , aliceblue + , antiquewhite + , aqua + , aquamarine + , azure + , beige + , bisque + , black + , blanchedalmond + , blue + , blueviolet + , brown + , burlywood + , cadetblue + , chartreuse + , chocolate + , coral + , cornflowerblue + , cornsilk + , crimson + , cyan + , darkblue + , darkcyan + , darkgoldenrod + , darkgray + , darkgreen + , darkgrey + , darkkhaki + , darkmagenta + , darkolivegreen + , darkorange + , darkorchid + , darkred + , darksalmon + , darkseagreen + , darkslateblue + , darkslategray + , darkslategrey + , darkturquoise + , darkviolet + , deeppink + , deepskyblue + , dimgray + , dimgrey + , dodgerblue + , firebrick + , floralwhite + , forestgreen + , fuchsia + , gainsboro + , ghostwhite + , gold + , goldenrod + , gray + , green + , grey + , greenyellow + , honeydew + , hotpink + , indianred + , indigo + , ivory + , khaki + , lavender + , lavenderblush + , lawngreen + , lemonchiffon + , lightblue + , lightcoral + , lightcyan + , lightgoldenrodyellow + , lightgray + , lightgreen + , lightgrey + , lightpink + , lightsalmon + , lightseagreen + , lightskyblue + , lightslategray + , lightslategrey + , lightsteelblue + , lightyellow + , lime + , limegreen + , linen + , magenta + , maroon + , mediumaquamarine + , mediumblue + , mediumorchid + , mediumpurple + , mediumseagreen + , mediumslateblue + , mediumspringgreen + , mediumturquoise + , mediumvioletred + , midnightblue + , mintcream + , mistyrose + , moccasin + , navajowhite + , navy + , oldlace + , olive + , olivedrab + , orange + , orangered + , orchid + , palegoldenrod + , palegreen + , paleturquoise + , palevioletred + , papayawhip + , peachpuff + , peru + , pink + , plum + , powderblue + , purple + , red + , rosybrown + , royalblue + , saddlebrown + , salmon + , sandybrown + , seagreen + , seashell + , sienna + , silver + , skyblue + , slateblue + , slategray + , slategrey + , snow + , springgreen + , steelblue + , tan + , teal + , thistle + , tomato + , turquoise + , violet + , wheat + , white + , whitesmoke + , yellow + , yellowgreen + , rebeccapurple + , transparent ) where -import Graphics.Blank.Generated -import Graphics.Blank.JavaScript +import qualified Data.Colour as Colour +import Data.Colour hiding (black, transparent) +import qualified Data.Colour.Names as Names +import Data.Colour.RGBSpace +import qualified Data.Colour.RGBSpace.HSL as HSL +import Data.Colour.SRGB +import Data.Word +import Graphics.Blank.Canvas +import Graphics.Blank.Generated +import Graphics.Blank.JavaScript +import Prelude hiding (tan) +-- | +-- A value ranging from 0.0 to 1.0. A color with an alpha value of 0.0 is 'transparent', +-- and a color with an alpha value of 1.0 is opaque. +type Alpha = Double + +-- | A value ranging from 0.0 to 100.0. +type Percentage = Double + +-- | +-- Specifies a 'Colour' by its red, green, and blue components, where each component +-- is an integer between 0 and 255. +rgb :: Word8 -> Word8 -> Word8 -> Colour Double +rgb = sRGB24 + +-- | +-- Specifies a 'Colour' by its red, green, and blue components, where each component +-- is given by a percentage of 255. +rgbPercent :: Percentage -> Percentage -> Percentage -> Colour Double +rgbPercent r g b = sRGB (r/100) (g/100) (b/100) + +-- | +-- Specifies an 'AlphaColour' by its RGB components and an alpha value. +-- +-- @ +-- 'rgba' r g b 0.0 = 'transparent' +-- @ +rgba :: Word8 -> Word8 -> Word8 -> Alpha -> AlphaColour Double +rgba r g b = withOpacity $ rgb r g b + +-- | +-- Specifies an 'AlphaColour' by its RGB component percentages and an alpha value. +-- +-- @ +-- 'rgbaPercent' r g b 0.0 = 'transparent' +-- @ +rgbaPercent :: Percentage -> Percentage -> Percentage -> Alpha -> AlphaColour Double +rgbaPercent r g b = withOpacity $ rgbPercent r g b + +-- | +-- Specifies a 'Colour' by its hue (which ranges from 0° to 360°), saturation, and +-- value. +hsl :: Int -> Percentage -> Percentage -> Colour Double +hsl h s l = uncurryRGB sRGB $ HSL.hsl (realToFrac h) (s/100) (l/100) + +-- | +-- Specifies an 'AlphaColour' by its HSV values and an alpha value. +-- +-- @ +-- 'hsla' h s v 0.0 = 'transparent' +-- @ +hsla :: Int -> Percentage -> Percentage -> Alpha -> AlphaColour Double +hsla h s l = withOpacity $ hsl h s l + +-- | +-- Takes a string naming a 'Colour' (must be all lowercase) and returns it. Fails if +-- the name is not recognized. +readColourName :: Monad m => String -> m (Colour Double) +readColourName "rebeccapurple" = return rebeccapurple +readColourName name = Names.readColourName name + +-- | @#F0F8FF@, @rgb(240, 248, 255)@, @hsl(208, 100%, 97%)@ +aliceblue :: Colour Double +aliceblue = Names.aliceblue + +-- | @#FAEBD7@, @rgb(250, 235, 215)@, @hsl(34, 78%, 91%)@ +antiquewhite :: Colour Double +antiquewhite = Names.antiquewhite + +-- | @#00FFFF@, @rgb(0, 255, 255)@, @hsl(180, 100%, 50%)@. Same as 'cyan'. +aqua :: Colour Double +aqua = Names.aqua + +-- | @#7FFFD4@, @rgb(127, 255, 212)@, @hsl(160, 100%, 75%)@ +aquamarine :: Colour Double +aquamarine = Names.aquamarine + +-- | @#F0FFFF@, @rgb(240, 255, 255)@, @hsl(180, 100%, 97%)@ +azure :: Colour Double +azure = Names.azure + +-- | @#F5F5DC@, @rgb(245, 245, 220)@, @hsl(60, 56%, 91%)@ +beige :: Colour Double +beige = Names.beige + +-- | @#FFE4C4@, @rgb(255, 228, 196)@, @hsl(33, 100%, 88%)@ +bisque :: Colour Double +bisque = Names.bisque + +-- | @#000000@, @rgb(0, 0, 0)@, @hsl(0, 0%, 0%)@ +black :: Colour Double +black = Colour.black + +-- | @#FFEBCD@, @rgb(255, 235, 205)@, @hsl(36, 100%, 90%)@ +blanchedalmond :: Colour Double +blanchedalmond = Names.blanchedalmond + +-- | @#0000FF@, @rgb(0, 0, 255)@, @hsl(240, 100%, 50%)@ +blue :: Colour Double +blue = Names.blue + +-- | @#8A2BE2@, @rgb(138, 43, 226)@, @hsl(271, 76%, 53%)@ +blueviolet :: Colour Double +blueviolet = Names.blueviolet + +-- | @#A52A2A@, @rgb(165, 42, 42)@, @hsl(0, 59%, 41%)@ +brown :: Colour Double +brown = Names.brown + +-- | @#DEB887@, @rgb(222, 184, 135)@, @hsl(34, 57%, 70%)@ +burlywood :: Colour Double +burlywood = Names.burlywood + +-- | @#5F9EA0@, @rgb(95, 158, 160)@, @hsl(182, 25%, 50%)@ +cadetblue :: Colour Double +cadetblue = Names.cadetblue + +-- | @#7FFF00@, @rgb(127, 255, 0)@, @hsl(90, 100%, 50%)@ +chartreuse :: Colour Double +chartreuse = Names.chartreuse + +-- | @#D2691E@, @rgb(210, 105, 30)@, @hsl(25, 75%, 47%)@ +chocolate :: Colour Double +chocolate = Names.chocolate + +-- | @#FF7F50@, @rgb(255, 127, 80)@, @hsl(16, 100%, 66%)@ +coral :: Colour Double +coral = Names.coral + +-- | @#6495ED@, @rgb(100, 149, 237)@, @hsl(219, 79%, 66%)@ +cornflowerblue :: Colour Double +cornflowerblue = Names.cornflowerblue + +-- | @#FFF8DC@, @rgb(255, 248, 220)@, @hsl(48, 100%, 93%)@ +cornsilk :: Colour Double +cornsilk = Names.cornsilk + +-- | @#DC143C@, @rgb(220, 20, 60)@, @hsl(348, 83%, 58%)@ +crimson :: Colour Double +crimson = Names.crimson + +-- | @#00FFFF@, @rgb(0, 255, 255)@, @hsl(180, 100%, 50%)@. Same as 'aqua'. +cyan :: Colour Double +cyan = Names.cyan + +-- | @#00008B@, @rgb(0, 0, 139)@, @hsl(240, 100%, 27%)@ +darkblue :: Colour Double +darkblue = Names.darkblue + +-- | @#008B8B@, @rgb(0, 139, 139)@, @hsl(180, 100%, 27%)@ +darkcyan :: Colour Double +darkcyan = Names.darkcyan + +-- | @#B8860B@, @rgb(184, 134, 11)@, @hsl(43, 89%, 38%)@ +darkgoldenrod :: Colour Double +darkgoldenrod = Names.darkgoldenrod + +-- | @#A9A9A9@, @rgb(169, 169, 169)@, @hsl(0, 0%, 66%)@. Same as 'darkgrey'. +darkgray :: Colour Double +darkgray = Names.darkgray + +-- | @#006400@, @rgb(0, 100, 0)@, @hsl(120, 100%, 20%)@ +darkgreen :: Colour Double +darkgreen = Names.darkgreen + +-- | @#A9A9A9@, @rgb(169, 169, 169)@, @hsl(0, 0%, 66%)@. Same as 'darkgray'. +darkgrey :: Colour Double +darkgrey = Names.darkgrey + +-- | @#BDB76B@, @rgb(189, 183, 107)@, @hsl(56, 38%, 58%)@ +darkkhaki :: Colour Double +darkkhaki = Names.darkkhaki + +-- | @#8B008B@, @rgb(139, 0, 139)@, @hsl(300, 100%, 27%)@ +darkmagenta :: Colour Double +darkmagenta = Names.darkmagenta + +-- | @#556B2F@, @rgb(85, 107, 47)@, @hsl(82, 39%, 30%)@ +darkolivegreen :: Colour Double +darkolivegreen = Names.darkolivegreen + +-- | @#FF8C00@, @rgb(255, 140, 0)@, @hsl(33, 100%, 50%)@ +darkorange :: Colour Double +darkorange = Names.darkorange + +-- | @#9932CC@, @rgb(153, 50, 204)@, @hsl(280, 61%, 50%)@ +darkorchid :: Colour Double +darkorchid = Names.darkorchid + +-- | @#8B0000@, @rgb(139, 0, 0)@, @hsl(0, 100%, 27%)@ +darkred :: Colour Double +darkred = Names.darkred + +-- | @#E9967A@, @rgb(233, 150, 122)@, @hsl(15, 72%, 70%)@ +darksalmon :: Colour Double +darksalmon = Names.darksalmon + +-- | @#8FBC8F@, @rgb(143, 188, 143)@, @hsl(120, 25%, 65%)@ +darkseagreen :: Colour Double +darkseagreen = Names.darkseagreen + +-- | @#483D8B@, @rgb(72, 61, 139)@, @hsl(248, 39%, 39%)@ +darkslateblue :: Colour Double +darkslateblue = Names.darkslateblue + +-- | @#2F4F4F@, @rgb(47, 79, 79)@, @hsl(180, 25%, 25%)@. Same as 'darkslategrey'. +darkslategray :: Colour Double +darkslategray = Names.darkslategray + +-- | @#2F4F4F@, @rgb(47, 79, 79)@, @hsl(180, 25%, 25%)@. Same as 'darkslategray'. +darkslategrey :: Colour Double +darkslategrey = Names.darkslategrey + +-- | @#00CED1@, @rgb(0, 206, 209)@, @hsl(181, 100%, 41%)@ +darkturquoise :: Colour Double +darkturquoise = Names.darkturquoise + +-- | @#9400D3@, @rgb(148, 0, 211)@, @hsl(282, 100%, 41%)@ +darkviolet :: Colour Double +darkviolet = Names.darkviolet + +-- | @#FF1493@, @rgb(255, 20, 147)@, @hsl(328, 100%, 54%)@ +deeppink :: Colour Double +deeppink = Names.deeppink + +-- | @#00BFFF@, @rgb(0, 191, 255)@, @hsl(195, 100%, 50%)@ +deepskyblue :: Colour Double +deepskyblue = Names.deepskyblue + +-- | @#696969@, @rgb(105, 105, 105)@, @hsl(0, 0%, 41%)@. Same as 'darkgrey'. +dimgray :: Colour Double +dimgray = Names.dimgray + +-- | @#696969@, @rgb(105, 105, 105)@, @hsl(0, 0%, 41%)@. Same as 'darkgray'. +dimgrey :: Colour Double +dimgrey = Names.dimgrey + +-- | @#1E90FF@, @rgb(30, 144, 255)@, @hsl(210, 100%, 56%)@ +dodgerblue :: Colour Double +dodgerblue = Names.dodgerblue + +-- | @#B22222@, @rgb(178, 34, 34)@, @hsl(0, 68%, 42%)@ +firebrick :: Colour Double +firebrick = Names.firebrick + +-- | @#FFFAF0@, @rgb(255, 250, 240)@, @hsl(40, 100%, 97%)@ +floralwhite :: Colour Double +floralwhite = Names.floralwhite + +-- | @#228B22@, @rgb(34, 139, 34)@, @hsl(120, 61%, 34%)@ +forestgreen :: Colour Double +forestgreen = Names.forestgreen + +-- | @#FF00FF@, @rgb(255, 0, 255)@, @hsl(300, 100%, 50%)@. Same as 'magenta'. +fuchsia :: Colour Double +fuchsia = Names.fuchsia + +-- | @#DCDCDC@, @rgb(220, 220, 220)@, @hsl(0, 0%, 86%)@ +gainsboro :: Colour Double +gainsboro = Names.gainsboro + +-- | @#F8F8FF@, @rgb(248, 248, 255)@, @hsl(240, 100%, 99%)@ +ghostwhite :: Colour Double +ghostwhite = Names.ghostwhite + +-- | @#FFD700@, @rgb(255, 215, 0)@, @hsl(51, 100%, 50%)@ +gold :: Colour Double +gold = Names.gold + +-- | @#DAA520@, @rgb(218, 165, 32)@, @hsl(43, 74%, 49%)@ +goldenrod :: Colour Double +goldenrod = Names.goldenrod + +-- | @#808080@, @rgb(128, 128, 128)@, @hsl(0, 0%, 50%)@. Same as 'grey'. +gray :: Colour Double +gray = Names.gray + +-- | @#008000@, @rgb(0, 128, 0)@, @hsl(120, 100%, 25%)@ +green :: Colour Double +green = Names.green + +-- | @#808080@, @rgb(128, 128, 128)@, @hsl(0, 0%, 50%)@. Same as 'gray'. +grey :: Colour Double +grey = Names.grey + +-- | @#ADFF2F@, @rgb(173, 255, 47)@, @hsl(84, 100%, 59%)@ +greenyellow :: Colour Double +greenyellow = Names.greenyellow + +-- | @#F0FFF0@, @rgb(240, 255, 240)@, @hsl(120, 100%, 97%)@ +honeydew :: Colour Double +honeydew = Names.honeydew + +-- | @#FF69B4@, @rgb(255, 105, 180)@, @hsl(330, 100%, 71%)@ +hotpink :: Colour Double +hotpink = Names.hotpink + +-- | @#CD5C5C@, @rgb(205, 92, 92)@, @hsl(0, 53%, 58%)@ +indianred :: Colour Double +indianred = Names.indianred + +-- | @#4B0082@, @rgb(75, 0, 130)@, @hsl(275, 100%, 25%)@ +indigo :: Colour Double +indigo = Names.indigo + +-- | @#FFFFF0@, @rgb(255, 255, 240)@, @hsl(60, 100%, 97%)@ +ivory :: Colour Double +ivory = Names.ivory + +-- | @#F0E68C@, @rgb(240, 230, 140)@, @hsl(54, 77%, 75%)@ +khaki :: Colour Double +khaki = Names.khaki + +-- | @#E6E6FA@, @rgb(230, 230, 250)@, @hsl(240, 67%, 94%)@ +lavender :: Colour Double +lavender = Names.lavender + +-- | @#FFF0F5@, @rgb(255, 240, 245)@, @hsl(340, 100%, 97%)@ +lavenderblush :: Colour Double +lavenderblush = Names.lavenderblush + +-- | @#7CFC00@, @rgb(124, 252, 0)@, @hsl(90, 100%, 49%)@ +lawngreen :: Colour Double +lawngreen = Names.lawngreen + +-- | @#FFFACD@, @rgb(255, 250, 205)@, @hsl(54, 100%, 90%)@ +lemonchiffon :: Colour Double +lemonchiffon = Names.lemonchiffon + +-- | @#ADD8E6@, @rgb(173, 216, 230)@, @hsl(195, 53%, 79%)@ +lightblue :: Colour Double +lightblue = Names.lightblue + +-- | @#F08080@, @rgb(240, 128, 128)@, @hsl(0, 79%, 72%)@ +lightcoral :: Colour Double +lightcoral = Names.lightcoral + +-- | @#E0FFFF@, @rgb(224, 255, 255)@, @hsl(180, 100%, 94%)@ +lightcyan :: Colour Double +lightcyan = Names.lightcyan + +-- | @#FAFAD2@, @rgb(250, 250, 210)@, @hsl(60, 80%, 90%)@ +lightgoldenrodyellow :: Colour Double +lightgoldenrodyellow = Names.lightgoldenrodyellow + +-- | @#D3D3D3@, @rgb(211, 211, 211)@, @hsl(0, 0%, 83%)@. Same as 'lightgrey'. +lightgray :: Colour Double +lightgray = Names.lightgray + +-- | @#90EE90@, @rgb(144, 238, 144)@, @hsl(120, 73%, 75%)@ +lightgreen :: Colour Double +lightgreen = Names.lightgreen + +-- | @#D3D3D3@, @rgb(211, 211, 211)@, @hsl(0, 0%, 83%)@. Same as 'lightgrey'. +lightgrey :: Colour Double +lightgrey = Names.lightgrey + +-- | @#FFB6C1@, @rgb(255, 182, 193)@, @hsl(351, 100%, 86%)@ +lightpink :: Colour Double +lightpink = Names.lightpink + +-- | @#FFA07A@, @rgb(255, 160, 122)@, @hsl(17, 100%, 74%)@ +lightsalmon :: Colour Double +lightsalmon = Names.lightsalmon + +-- | @#20B2AA@, @rgb(32, 178, 170)@, @hsl(177, 70%, 41%)@ +lightseagreen :: Colour Double +lightseagreen = Names.lightseagreen + +-- | @#87CEFA@, @rgb(135, 206, 250)@, @hsl(203, 92%, 75%)@ +lightskyblue :: Colour Double +lightskyblue = Names.lightskyblue + +-- | @#778899@, @rgb(119, 136, 153)@, @hsl(210, 14%, 53%)@. Same as 'lightslategrey'. +lightslategray :: Colour Double +lightslategray = Names.lightslategray + +-- | @#778899@, @rgb(119, 136, 153)@, @hsl(210, 14%, 53%)@. Same as 'lightslategray'. +lightslategrey :: Colour Double +lightslategrey = Names.lightslategrey + +-- | @#B0C4DE@, @rgb(176, 196, 222)@, @hsl(214, 41%, 78%)@ +lightsteelblue :: Colour Double +lightsteelblue = Names.lightsteelblue + +-- | @#FFFFE0@, @rgb(255, 255, 224)@, @hsl(60, 100%, 94%)@ +lightyellow :: Colour Double +lightyellow = Names.lightyellow + +-- | @#00FF00@, @rgb(0, 255, 0)@, @hsl(120, 100%, 50%)@ +lime :: Colour Double +lime = Names.lime + +-- | @#32CD32@, @rgb(50, 205, 50)@, @hsl(120, 61%, 50%)@ +limegreen :: Colour Double +limegreen = Names.limegreen + +-- | @#FAF0E6@, @rgb(250, 240, 230)@, @hsl(30, 67%, 94%)@ +linen :: Colour Double +linen = Names.linen + +-- | @#FF00FF@, @rgb(255, 0, 255)@, @hsl(300, 100%, 50%)@. Same as 'fuchsia'. +magenta :: Colour Double +magenta = Names.magenta + +-- | @#800000@, @rgb(128, 0, 0)@, @hsl(0, 100%, 25%)@ +maroon :: Colour Double +maroon = Names.maroon + +-- | @#66CDAA@, @rgb(102, 205, 170)@, @hsl(160, 51%, 60%)@ +mediumaquamarine :: Colour Double +mediumaquamarine = Names.mediumaquamarine + +-- | @#0000CD@, @rgb(0, 0, 205)@, @hsl(240, 100%, 40%)@ +mediumblue :: Colour Double +mediumblue = Names.mediumblue + +-- | @#BA55D3@, @rgb(186, 85, 211)@, @hsl(288, 59%, 58%)@ +mediumorchid :: Colour Double +mediumorchid = Names.mediumorchid + +-- | @#9370DB@, @rgb(147, 112, 219)@, @hsl(260, 60%, 65%)@ +mediumpurple :: Colour Double +mediumpurple = Names.mediumpurple + +-- | @#3CB371@, @rgb(60, 179, 113)@, @hsl(147, 50%, 47%)@ +mediumseagreen :: Colour Double +mediumseagreen = Names.mediumseagreen + +-- | @#7B68EE@, @rgb(123, 104, 238)@, @hsl(249, 80%, 67%)@ +mediumslateblue :: Colour Double +mediumslateblue = Names.mediumslateblue + +-- | @#00FA9A@, @rgb(0, 250, 154)@, @hsl(157, 100%, 49%)@ +mediumspringgreen :: Colour Double +mediumspringgreen = Names.mediumspringgreen + +-- | @#48D1CC@, @rgb(72, 209, 204)@, @hsl(178, 60%, 55%)@ +mediumturquoise :: Colour Double +mediumturquoise = Names.turquoise + +-- | @#C71585@, @rgb(199, 21, 133)@, @hsl(322, 81%, 43%)@ +mediumvioletred :: Colour Double +mediumvioletred = Names.mediumvioletred + +-- | @#191970@, @rgb(25, 25, 112)@, @hsl(240, 64%, 27%)@ +midnightblue :: Colour Double +midnightblue = Names.midnightblue + +-- | @#F5FFFA@, @rgb(245, 255, 250)@, @hsl(150, 100%, 98%)@ +mintcream :: Colour Double +mintcream = Names.mintcream + +-- | @#FFE4E1@, @rgb(255, 228, 225)@, @hsl(6, 100%, 94%)@ +mistyrose :: Colour Double +mistyrose = Names.mistyrose + +-- | @#FFE4B5@, @rgb(255, 228, 181)@, @hsl(38, 100%, 85%)@ +moccasin :: Colour Double +moccasin = Names.moccasin + +-- | @#FFDEAD@, @rgb(255, 222, 173)@, @hsl(36, 100%, 84%)@ +navajowhite :: Colour Double +navajowhite = Names.navajowhite + +-- | @#000080@, @rgb(0, 0, 128)@, @hsl(240, 100%, 25%)@ +navy :: Colour Double +navy = Names.navy + +-- | @#FDF5E6@, @rgb(253, 245, 230)@, @hsl(39, 85%, 95%)@ +oldlace :: Colour Double +oldlace = Names.oldlace + +-- | @#808000@, @rgb(128, 128, 0)@, @hsl(60, 100%, 25%)@ +olive :: Colour Double +olive = Names.olive + +-- | @#6B8E23@, @rgb(107, 142, 35)@, @hsl(80, 60%, 35%)@ +olivedrab :: Colour Double +olivedrab = Names.olivedrab + +-- | @#FFA500@, @rgb(255, 165, 0)@, @hsl(39, 100%, 50%)@ +orange :: Colour Double +orange = Names.orange + +-- | @#FF4500@, @rgb(255, 69, 0)@, @hsl(16, 100%, 50%)@ +orangered :: Colour Double +orangered = Names.orangered + +-- | @#DA70D6@, @rgb(218, 112, 214)@, @hsl(302, 59%, 65%)@ +orchid :: Colour Double +orchid = Names.orchid + +-- | @#EEE8AA@, @rgb(238, 232, 170)@, @hsl(55, 67%, 80%)@ +palegoldenrod :: Colour Double +palegoldenrod = Names.palegoldenrod + +-- | @#98FB98@, @rgb(152, 251, 152)@, @hsl(120, 93%, 79%)@ +palegreen :: Colour Double +palegreen = Names.palegreen + +-- | @#AFEEEE@, @rgb(175, 238, 238)@, @hsl(180, 65%, 81%)@ +paleturquoise :: Colour Double +paleturquoise = Names.paleturquoise + +-- | @#DB7093@, @rgb(219, 112, 147)@, @hsl(340, 60%, 65%)@ +palevioletred :: Colour Double +palevioletred = Names.palevioletred + +-- | @#FFEFD5@, @rgb(255, 239, 213)@, @hsl(37, 100%, 92%)@ +papayawhip :: Colour Double +papayawhip = Names.papayawhip + +-- | @#FFDAB9@, @rgb(255, 218, 185)@, @hsl(28, 100%, 86%)@ +peachpuff :: Colour Double +peachpuff = Names.peachpuff + +-- | @#CD853F@, @rgb(205, 133, 63)@, @hsl(30, 59%, 53%)@ +peru :: Colour Double +peru = Names.peru + +-- | @#FFC0CB@, @rgb(255, 192, 203)@, @hsl(350, 100%, 88%)@ +pink :: Colour Double +pink = Names.pink + +-- | @#DDA0DD@, @rgb(221, 160, 221)@, @hsl(300, 47%, 75%)@ +plum :: Colour Double +plum = Names.plum + +-- | @#B0E0E6@, @rgb(176, 224, 230)@, @hsl(187, 52%, 80%)@ +powderblue :: Colour Double +powderblue = Names.powderblue + +-- | @#800080@, @rgb(128, 0, 128)@, @hsl(300, 100%, 25%)@ +purple :: Colour Double +purple = Names.purple + +-- | @#FF0000@, @rgb(255, 0, 0)@, @hsl(0, 100%, 50%)@ +red :: Colour Double +red = Names.red + +-- | @#BC8F8F@, @rgb(188, 143, 143)@, @hsl(0, 25%, 65%)@ +rosybrown :: Colour Double +rosybrown = Names.rosybrown + +-- | @#4169E1@, @rgb(65, 105, 225)@, @hsl(225, 73%, 57%)@ +royalblue :: Colour Double +royalblue = Names.royalblue + +-- | @#8B4513@, @rgb(139, 69, 19)@, @hsl(25, 76%, 31%)@ +saddlebrown :: Colour Double +saddlebrown = Names.saddlebrown + +-- | @#FA8072@, @rgb(250, 128, 114)@, @hsl(6, 93%, 71%)@ +salmon :: Colour Double +salmon = Names.salmon + +-- | @#F4A460@, @rgb(244, 164, 96)@, @hsl(28, 87%, 67%)@ +sandybrown :: Colour Double +sandybrown = Names.sandybrown + +-- | @#2E8B57@, @rgb(46, 139, 87)@, @hsl(146, 50%, 36%)@ +seagreen :: Colour Double +seagreen = Names.seagreen + +-- | @#FFF5EE@, @rgb(255, 245, 238)@, @hsl(25, 100%, 97%)@ +seashell :: Colour Double +seashell = Names.seashell + +-- | @#A0522D@, @rgb(160, 82, 45)@, @hsl(19, 56%, 40%)@ +sienna :: Colour Double +sienna = Names.sienna + +-- | @#C0C0C0@, @rgb(192, 192, 192)@, @hsl(0, 0%, 75%)@ +silver :: Colour Double +silver = Names.silver + +-- | @#87CEEB@, @rgb(135, 206, 235)@, @hsl(197, 71%, 73%)@ +skyblue :: Colour Double +skyblue = Names.skyblue + +-- | @#6A5ACD@, @rgb(106, 90, 205)@, @hsl(248, 53%, 58%)@ +slateblue :: Colour Double +slateblue = Names.slateblue + +-- | @#708090@, @rgb(112, 128, 144)@, @hsl(210, 13%, 50%)@. Same as 'slategrey'. +slategray :: Colour Double +slategray = Names.slategray + +-- | @#708090@, @rgb(112, 128, 144)@, @hsl(210, 13%, 50%)@. Same as 'slategray'. +slategrey :: Colour Double +slategrey = Names.slategrey + +-- | @#FFFAFA@, @rgb(255, 250, 250)@, @hsl(0, 100%, 99%)@ +snow :: Colour Double +snow = Names.snow + +-- | @#00FF7F@, @rgb(0, 255, 127)@, @hsl(150, 100%, 50%)@ +springgreen :: Colour Double +springgreen = Names.springgreen + +-- | @#4682B4@, @rgb(70, 130, 180)@, @hsl(207, 44%, 49%)@ +steelblue :: Colour Double +steelblue = Names.steelblue + +-- | @#D2B48C@, @rgb(210, 180, 140)@, @hsl(34, 44%, 69%)@ +tan :: Colour Double +tan = Names.tan + +-- | @#008080@, @rgb(0, 128, 128)@, @hsl(180, 100%, 25%)@ +teal :: Colour Double +teal = Names.teal + +-- | @#D8BFD8@, @rgb(216, 191, 216)@, @hsl(300, 24%, 80%)@ +thistle :: Colour Double +thistle = Names.thistle + +-- | @#FF6347@, @rgb(255, 99, 71)@, @hsl(9, 100%, 64%)@ +tomato :: Colour Double +tomato = Names.tomato + +-- | @#40E0D0@, @rgb(64, 224, 208)@, @hsl(174, 72%, 56%)@ +turquoise :: Colour Double +turquoise = Names.turquoise + +-- | @#EE82EE@, @rgb(238, 130, 238)@, @hsl(300, 76%, 72%)@ +violet :: Colour Double +violet = Names.violet + +-- | @#F5DEB3@, @rgb(245, 222, 179)@, @hsl(39, 77%, 83%)@ +wheat :: Colour Double +wheat = Names.wheat + +-- | @#FFFFFF@, @rgb(255, 255, 255)@, @hsl(0, 100%, 100%)@ +white :: Colour Double +white = Names.white + +-- | @#F5F5F5@, @rgb(245, 245, 245)@, @hsl(0, 0%, 96%)@ +whitesmoke :: Colour Double +whitesmoke = Names.whitesmoke + +-- | @#FFFF00@, @rgb(255, 255, 0)@, @hsl(60, 100%, 50%)@ +yellow :: Colour Double +yellow = Names.yellow + +-- | @#9ACD32@, @rgb(154, 205, 50)@, @hsl(80, 61%, 50%)@ +yellowgreen :: Colour Double +yellowgreen = Names.yellowgreen + +-- | @#663399@, @rgb(102, 51, 153)@, @hsl(270, 50%, 40%)@ +rebeccapurple :: Colour Double +rebeccapurple = sRGB24 102 51 153 + +-- | +-- This 'AlphaColour' is entirely transparent and has no associated +-- color channel (i.e., @rgba(0, 0, 0, 0.0)@ or @hsla(0, 0%, 0%, 0.0)@). +transparent :: AlphaColour Double +transparent = Colour.transparent diff --git a/Graphics/Blank/Utils.hs b/Graphics/Blank/Utils.hs --- a/Graphics/Blank/Utils.hs +++ b/Graphics/Blank/Utils.hs @@ -1,9 +1,18 @@ +{-# LANGUAGE OverloadedStrings #-} module Graphics.Blank.Utils where +import Data.ByteString.Base64 -- Not sure why to use this, vs this *.URL version. This one works, though. +import qualified Data.ByteString as B +import Data.Monoid +import Data.Text(Text) +import qualified Data.Text as Text +import Data.Text.Encoding (decodeUtf8, encodeUtf8) + import Graphics.Blank.Canvas import Graphics.Blank.Generated import Graphics.Blank.JavaScript + -- | Clear the screen. Restores the default transformation matrix. clearCanvas :: Canvas () clearCanvas = do @@ -12,13 +21,13 @@ clearRect (0,0,width me,height me) -- | Wrap a canvas computation in 'save' / 'restore'. -saveRestore :: Canvas () -> Canvas () +saveRestore :: Canvas a -> Canvas a saveRestore m = do save () - m + r <- m restore () - - + return r + infixr 0 # -- | The @#@-operator is the Haskell analog to the @.@-operator @@ -26,6 +35,78 @@ -- -- > grd # addColorStop(0, "#8ED6FF"); -- --- This can be seen as equivalent of @document.addColorStop(0, "#8ED6FF")@. +-- This can be seen as equivalent of @grd.addColorStop(0, "#8ED6FF")@. (#) :: a -> (a -> Canvas b) -> Canvas b (#) obj act = act obj + +-- | Read a file, and generate a data URL. +-- +-- > url <- readDataURL "image/png" "image/foo.png" +-- +readDataURL :: Text -> FilePath -> IO Text +readDataURL mime_type filePath = do + dat <- B.readFile filePath + return $ "data:" <> mime_type <> ";base64," <> decodeUtf8 (encode dat) + +-- | Find the mime type for a data URL. +-- +-- > > dataURLMimeType "data:image/png;base64,iVBORw..." +-- > "image/png" +-- +dataURLMimeType :: Text -> Text +dataURLMimeType txt + | dat /= "data" = error "dataURLMimeType: no 'data:'" + | not (Text.null rest0) && not (Text.null rest2) = mime_type + | otherwise = error "dataURLMimeType: bad parse" + where + (dat,rest0) = Text.span (/= ':') txt + Just (_,rest1) = Text.uncons rest0 + (mime_type,rest2) = Text.span (/= ';') rest1 + +-- | Write a data URL to a given file. + +writeDataURL :: FilePath -> Text -> IO () +writeDataURL fileName + = B.writeFile fileName + . decodeLenient + . encodeUtf8 + . Text.tail + . Text.dropWhile (/= ',') + +-- | Draws an image onto the canvas at the given x- and y-coordinates. +drawImageAt :: Image image => (image, Double, Double) -> Canvas () +drawImageAt (img, dx, dy) = Method $ DrawImage (img, [dx, dy]) + +-- | Acts like 'drawImageAt', but with two extra 'Double' arguments. The third and fourth +-- 'Double's specify the width and height of the image, respectively. +drawImageSize :: Image image => (image, Double, Double, Double, Double) -> Canvas () +drawImageSize (img, dx, dy, dw, dh) = Method $ DrawImage (img, [dx, dy, dw, dh]) + +-- | Acts like 'drawImageSize', but with four extra 'Double' arguments before the arguments +-- of 'drawImageSize'. The first and second 'Double's specify the x- and y-coordinates at +-- which the image begins to crop. The third and fourth 'Double's specify the width and +-- height of the cropped image. +-- +-- @ +-- 'drawImageCrop' img 0 0 dw dh dx dy dw dh = 'drawImageSize' = dx dy dw dh +-- @ +drawImageCrop :: Image image => (image, Double, Double, Double, Double, Double, Double, Double, Double) -> Canvas () +drawImageCrop (img, sx, sy, sw, sh, dx, dy, dw, dh) + = Method $ DrawImage (img, [sx, sy, sw, sh, dx, dy, dw, dh]) + +-- | Writes 'ImageData' to the canvas at the given x- and y-coordinates. +putImageDataAt :: (ImageData, Double, Double) -> Canvas () +putImageDataAt (imgData, dx, dy) = Method $ PutImageData (imgData, [dx, dy]) + +-- | Acts like 'putImageDataDirty', but with four extra 'Double' arguments that specify +-- which region of the 'ImageData' (the dirty rectangle) should be drawn. The third +-- and fourth 'Double's specify the dirty rectangle's x- and y- coordinates, and the +-- fifth and sixth 'Double's specify the dirty rectangle's width and height. +-- +-- @ +-- 'putImageDataDirty' imgData dx dy 0 0 w h = 'putImageDataAt' imgData dx dy +-- where (w, h) = case imgData of ImageData w' h' _ -> (w', h') +-- @ +putImageDataDirty :: (ImageData, Double, Double, Double, Double, Double, Double) -> Canvas () +putImageDataDirty (imgData, dx, dy, dirtyX, dirtyY, dirtyWidth, dirtyHeight) + = Method $ PutImageData (imgData, [dx, dy, dirtyX, dirtyY, dirtyWidth, dirtyHeight]) diff --git a/blank-canvas.cabal b/blank-canvas.cabal --- a/blank-canvas.cabal +++ b/blank-canvas.cabal @@ -1,5 +1,5 @@ Name: blank-canvas -Version: 0.4.0 +Version: 0.5 Synopsis: HTML5 Canvas Graphics Library Description: blank-canvas is a Haskell binding to the complete @@ -11,7 +11,7 @@ images. . @ - {-# LANGUAGE OverloadedStrings #-} + {-# LANGUAGE OverloadedStrings #-} module Main where import Graphics.Blank -- import the blank canvas . @@ -30,7 +30,7 @@ . License: BSD3 License-file: LICENSE -Author: Andy Gill +Author: Andy Gill and Ryan Scott Maintainer: andygill@ku.edu Copyright: Copyright (c) 2014 The University of Kansas Homepage: https://github.com/ku-fpg/blank-canvas/wiki @@ -39,14 +39,16 @@ Build-type: Simple Stability: beta Extra-source-files: README.md + Changelog.md Cabal-version: >= 1.10 data-files: static/index.html static/jquery.js static/jquery-json.js + Library - Exposed-modules: Graphics.Blank, + Exposed-modules: Graphics.Blank, Graphics.Blank.GHCi, Graphics.Blank.Style other-modules: Graphics.Blank.Canvas, @@ -58,25 +60,27 @@ Paths_blank_canvas default-language: Haskell2010 - build-depends: base >= 4.3.1 && < 4.8, - bytestring == 0.10.*, - aeson == 0.7.*, - containers == 0.5.*, - kansas-comet == 0.3.*, - scotty == 0.8.*, - http-types == 0.8.*, - text >= 1.1 && < 1.2, - network >= 2.4 && < 2.6, - transformers >= 0.3 && < 0.5, - wai == 3.*, - wai-extra == 3.*, - warp == 3.*, - stm >= 2.2 && < 2.5, - vector >= 0.10 && < 0.11 + build-depends: aeson >= 0.7 && < 0.9, + base64-bytestring == 1.0.*, + base >= 4.3.1 && < 4.8, + bytestring == 0.10.*, + colour >= 2.2 && < 3.0, + containers == 0.5.*, + data-default-class == 0.0.*, + http-types == 0.8.*, + kansas-comet == 0.3.*, + scotty >= 0.8 && < 0.10, + stm >= 2.2 && < 2.5, + text >= 1.1 && < 1.3, + transformers >= 0.3 && < 0.5, + wai == 3.*, + wai-extra >= 3.0.1 && < 3.1, + warp == 3.*, + vector >= 0.10 && < 0.11 GHC-options: -Wall -fno-warn-orphans -fno-warn-warnings-deprecations + GHC-prof-options: -Wall -fno-warn-orphans -fno-warn-warnings-deprecations -auto-all -fsimpl-tick-factor=100000 source-repository head type: git location: git://github.com/ku-fpg/blank-canvas.git - diff --git a/static/index.html b/static/index.html --- a/static/index.html +++ b/static/index.html @@ -43,9 +43,9 @@ } function ToDataURL(u,c) { $.kc.reply(u,c.canvas.toDataURL()); - + } - function NewImage(src) { + function NewImage(src) { return function (u,c) { var img = new Image(); var count = images.push(img); @@ -54,52 +54,52 @@ }; img.onerror = function() { alert("Image " + src + " not found.\nAdd as a static file to fix this."); }; img.src = src; - } + } } - function CreateLinearGradient(x0,y0,x1,y1) { + function CreateLinearGradient(x0,y0,x1,y1) { return function (u,c) { var count = gradients.push(c.createLinearGradient(x0,y0,x1,y1)); $.kc.reply(u,count - 1); - } + } } - function CreateRadialGradient(x0,y0,r0,x1,y1,r1) { + function CreateRadialGradient(x0,y0,r0,x1,y1,r1) { return function (u,c) { var count = gradients.push(c.createRadialGradient(x0,y0,r0,x1,y1,r1)); $.kc.reply(u,count - 1); - } + } } - function CreatePattern(img,src) { + function CreatePattern(img,src) { return function (u,c) { var count = patterns.push(c.createPattern(img,src)); $.kc.reply(u,count - 1); - } + } } - function MeasureText(txt) { + function MeasureText(txt) { return function (u,c) { - $.kc.reply(u,c.measureText(txt)); - } + $.kc.reply(u,{ width: c.measureText(txt).width }); + } } - function IsPointInPath(x,y) { + function IsPointInPath(x,y) { return function (u,c) { $.kc.reply(u,c.isPointInPath(x,y)); - } + } } - function NewCanvas(w,h) { + function NewCanvas(w,h) { return function (u,c) { var canvas = document.createElement('canvas'); canvas.width = w; canvas.height = h; var count = canvasbuffers.push(canvas.getContext("2d")); - $.kc.reply(u,[count - 1,w,h]); - } + $.kc.reply(u,[count - 1,w,h]); + } } - function GetImageData(sx,sy,sw,sh) { + function GetImageData(sx,sy,sw,sh) { return function (u,c) { var img = c.getImageData(sx,sy,sw,sh); var arr = []; @@ -110,25 +110,31 @@ , height: img.height , data: arr }); - } + } } - function Trigger(e) { - $.kc.event({ eMetaKey: e.eMetaKey, - ePageXY : e.ePageXY, - eType : e.eType, - eWhich : e.eWhich - }); + function Sync(u,c) { + $.kc.reply(u,[]); } + + function Trigger(e) { + var o = {}; + o.metaKey = e.metaKey; + o.type = e.type; + if (e.pageXY != undefined) { + o.pageXY = e.pageXY; + } + if (e.pageX != undefined && e.pageY != undefined) { + o.pageXY = [e.pageX,e.pageY]; + } + if (e.which != undefined) { + o.which = e.which; + } + $.kc.event(o); + } function register(name) { - $(document).bind(name,function (e){ - $.kc.event({ eMetaKey: e.metaKey, - ePageXY : [e.pageX,e.pageY], - eType : e.type, - eWhich : e.which - }); - }); - } + $(document).bind(name,Trigger); + } function redraw() { $.ajax({ url: "/canvas/" + session, type: "GET", @@ -136,10 +142,10 @@ success: function success() { redraw(); } - }); + }); } - - function ImageData(w,h,dat) { + + function ImageData(w,h,dat) { var imgData = canvasbuffers[0].createImageData(w,h); for(var i = 0;i < dat.length;i ++) { imgData.data[i] = dat[i]; @@ -169,8 +175,8 @@ $("#canvas").replaceWith( ''); - $("#canvas").css("width",w + "px"); - $("#canvas").css("height",h + "px"); + $("#canvas").css("width",w + "px"); + $("#canvas").css("height",h + "px"); c = getContext("2d"); canvasbuffers.push(c); $.kc.connect("/blank");