diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -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 diff --git a/Graphics/Blank.hs b/Graphics/Blank.hs --- a/Graphics/Blank.hs +++ b/Graphics/Blank.hs @@ -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 +. +@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 for the JavaScript + -- | See 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 diff --git a/Graphics/Blank/Canvas.hs b/Graphics/Blank/Canvas.hs --- a/Graphics/Blank/Canvas.hs +++ b/Graphics/Blank/Canvas.hs @@ -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 () -- . Command :: Command -> Canvas () -- - 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 diff --git a/Graphics/Blank/Cursor.hs b/Graphics/Blank/Cursor.hs new file mode 100644 --- /dev/null +++ b/Graphics/Blank/Cursor.hs @@ -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 diff --git a/Graphics/Blank/DeviceContext.hs b/Graphics/Blank/DeviceContext.hs --- a/Graphics/Blank/DeviceContext.hs +++ b/Graphics/Blank/DeviceContext.hs @@ -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 +-- @@ and +-- @@ +-- are conflated in @blank-canvas@. Therefore, there is no +-- @@ 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) diff --git a/Graphics/Blank/Events.hs b/Graphics/Blank/Events.hs --- a/Graphics/Blank/Events.hs +++ b/Graphics/Blank/Events.hs @@ -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 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 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 - diff --git a/Graphics/Blank/Font.hs b/Graphics/Blank/Font.hs new file mode 100644 --- /dev/null +++ b/Graphics/Blank/Font.hs @@ -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 diff --git a/Graphics/Blank/GHCi.hs b/Graphics/Blank/GHCi.hs --- a/Graphics/Blank/GHCi.hs +++ b/Graphics/Blank/GHCi.hs @@ -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. diff --git a/Graphics/Blank/Generated.hs b/Graphics/Blank/Generated.hs --- a/Graphics/Blank/Generated.hs +++ b/Graphics/Blank/Generated.hs @@ -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 - diff --git a/Graphics/Blank/JavaScript.hs b/Graphics/Blank/JavaScript.hs --- a/Graphics/Blank/JavaScript.hs +++ b/Graphics/Blank/JavaScript.hs @@ -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 +-- @@. +-- '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' diff --git a/Graphics/Blank/Parser.hs b/Graphics/Blank/Parser.hs new file mode 100644 --- /dev/null +++ b/Graphics/Blank/Parser.hs @@ -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' diff --git a/Graphics/Blank/Style.hs b/Graphics/Blank/Style.hs --- a/Graphics/Blank/Style.hs +++ b/Graphics/Blank/Style.hs @@ -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 diff --git a/Graphics/Blank/Types.hs b/Graphics/Blank/Types.hs new file mode 100644 --- /dev/null +++ b/Graphics/Blank/Types.hs @@ -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 diff --git a/Graphics/Blank/Types/CSS.hs b/Graphics/Blank/Types/CSS.hs new file mode 100644 --- /dev/null +++ b/Graphics/Blank/Types/CSS.hs @@ -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 diff --git a/Graphics/Blank/Types/Cursor.hs b/Graphics/Blank/Types/Cursor.hs new file mode 100644 --- /dev/null +++ b/Graphics/Blank/Types/Cursor.hs @@ -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 +-- . +data Cursor = Auto -- ^ The browser determines the cursor to display based on the + -- current context. + | Default -- ^ <> + | None -- ^ No cursor is rendered. + | 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 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 diff --git a/Graphics/Blank/Types/Font.hs b/Graphics/Blank/Types/Font.hs new file mode 100644 --- /dev/null +++ b/Graphics/Blank/Types/Font.hs @@ -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 diff --git a/Graphics/Blank/Utils.hs b/Graphics/Blank/Utils.hs --- a/Graphics/Blank/Utils.hs +++ b/Graphics/Blank/Utils.hs @@ -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. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c)2014, The University of Kansas +Copyright (c) 2014-2015, The University of Kansas All rights reserved. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 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. | diff --git a/blank-canvas.cabal b/blank-canvas.cabal --- a/blank-canvas.cabal +++ b/blank-canvas.cabal @@ -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 + . + @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. . @ - {-# LANGUAGE OverloadedStrings #-} + {-# LANGUAGE OverloadedStrings #-} module Main where import Graphics.Blank -- import the blank canvas . @@ -20,14 +20,14 @@ moveTo(50,50) lineTo(200,100) lineWidth 10 - strokeStyle "red" + strokeStyle \"red\" stroke() -- this draws the ink into the canvas @ - . + . <> - . - For more details, read the . - . + . + For more details, read the . + . 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 diff --git a/static/index.html b/static/index.html --- a/static/index.html +++ b/static/index.html @@ -11,7 +11,7 @@