static-canvas 0.1.0.0 → 0.2.0.0
raw patch · 5 files changed
+189/−163 lines, 5 filesdep ~freedep ~mtlPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: free, mtl
API changes (from Hackage documentation)
+ Graphics.Static: buildScript' :: Int -> Int -> Text -> CanvasFree () -> Builder
+ Graphics.Static: writeCanvasScript' :: FilePath -> Int -> Int -> Text -> CanvasFree () -> IO ()
- Graphics.Static: evalScript :: CanvasFree a -> Builder
+ Graphics.Static: evalScript :: Text -> CanvasFree a -> Builder
Files
- README.md +1/−1
- src/Graphics/Static.hs +35/−12
- src/Graphics/Static/Interpreter.hs +149/−146
- src/Graphics/Static/Types.hs +1/−1
- static-canvas.cabal +3/−3
README.md view
@@ -1,4 +1,4 @@-# static-canvas+# static-canvas [](https://hackage.haskell.org/package/static-canvas) A simple DSL for writing HTML5 Canvas in haskell and converting it to Javascript. By static we mean non-interactive, so the parts of the Canvas API that need to query the browser for run time information
src/Graphics/Static.hs view
@@ -7,7 +7,7 @@ -- License : BSD-style (see LICENSE) -- Maintainer : jeffrey.rosenbluth@gmail.com ----- A simple DSL for creating HTML5 Canvas with haskell.+-- A small DSL for creating HTML5 Canvas with haskell. -- -- <<http://i.imgur.com/HGjSpJ6.png>> --@@ -32,7 +32,6 @@ -- The static-canvas API shadows the actual Javascript API, and thus the -- best place to look for a more detailed definition of the canvas functions -- including the definitions of it's aruments see <http://www.w3.org/TR/2dcontext/>.--- Javascript functions tranliterate readily e.g. @moveTo(x, y);@ becomes @moveTo x y@. ------------------------------------------------------------------------------- module Graphics.Static@@ -40,8 +39,10 @@ -- * Building and Writing evalScript , buildScript+ , buildScript' , buildDoc , writeCanvasScript+ , writeCanvasScript' , writeCanvasDoc -- * HTML5 Canvas API , CanvasFree@@ -120,7 +121,7 @@ import Data.Monoid import Prelude hiding (writeFile) import Data.Text (Text)-import Data.Text.Lazy.Builder (Builder, toLazyText)+import Data.Text.Lazy.Builder (Builder, toLazyText, fromText) import Data.Text.Lazy.IO (writeFile) import Graphics.Static.Interpreter import Graphics.Static.Javascript@@ -130,27 +131,49 @@ -- Building and writing ------------------------------------------------------------------------------- +-- | Write a canvas document to a file. writeCanvasDoc :: FilePath -> Int -> Int -> CanvasFree () -> IO ()-writeCanvasDoc path w h canvas = writeFile path (toLazyText $ buildDoc w h canvas)+writeCanvasDoc path w h canvas =+ writeFile path (toLazyText $ buildDoc w h canvas) +-- | Write a canvas script element to a file. writeCanvasScript :: FilePath -> Int -> Int -> CanvasFree () -> IO ()-writeCanvasScript path w h canvas = writeFile path (toLazyText $ buildScript w h canvas)+writeCanvasScript path w h = writeCanvasScript' path w h "" +-- | More general version of 'writeCanvasScript', that takes a unique identifier+-- as an additional parameter so that multiple canvas elements can be included+-- in the same html document.+writeCanvasScript' :: FilePath -> Int -> Int -> Text -> CanvasFree () -> IO ()+writeCanvasScript' path w h uniqId canvas =+ writeFile path (toLazyText $ buildScript' w h uniqId canvas)++-- | Create a 'Builder' representing a canvas document. buildDoc :: Int -> Int -> CanvasFree () -> Builder buildDoc w h canvas = "<!DOCTYPE HTML><html><body>" <> (buildScript w h canvas) <> "</body></html>" +-- | Create a 'Builder' representing a canvas script. buildScript :: Int -> Int -> CanvasFree () -> Builder-buildScript w h canvas- = "<canvas id=\"theStaticCanvas\" width=\"" <> jsInt w+buildScript w h = buildScript' w h ""++-- | More general version of 'buildScript', that takes a unique identifier+-- as an additional parameter so that multiple canvas elements can be included+-- in the same html document.+buildScript' :: Int -> Int -> Text -> CanvasFree () -> Builder+buildScript' w h uniqId canvas+ = "<canvas id=\"" <> uId <> "StaticCanvas\" width=\"" <> jsInt w <> "\" height=\"" <> jsInt h <> "\"></canvas>" <> "<script>"- <> "var canvas = document.getElementById('theStaticCanvas');"- <> "var ctx = canvas.getContext('2d');"- <> (evalScript canvas)+ <> "(function () {"+ <> "var canvas = document.getElementById('"<> uId <> "StaticCanvas');"+ <> "var " <> uId <> "Ctx = canvas.getContext('2d');"+ <> (evalScript uniqId canvas)+ <> "}());" <> "</script>"+ where+ uId = fromText uniqId ------------------------------------------------------------------------------- -- Color utilities@@ -258,8 +281,8 @@ -- being called. For example -- -- > image = do--- > img <- newImage "http://www.staticcanvas.com/picture.png"--- > onImageLoad img (drawImageAt img 0 0)+-- > img <- newImage "http://www.staticcanvas.com/picture.png"+-- > onImageLoad img (drawImageAt img 0 0) onImageLoad :: Int -> CanvasFree () -> CanvasFree () onImageLoad a1 a2 = liftF $ OnImageLoad a1 a2 ()
src/Graphics/Static/Interpreter.hs view
@@ -19,13 +19,16 @@ import Control.Monad.Free.Church (fromF) import Control.Monad.State import Control.Monad.Writer+import Data.Text (Text) import Data.Text.Lazy.Builder (Builder, fromText, singleton) import Graphics.Static.Javascript import Graphics.Static.Types -- | Evaluate a static-canvas program and return the javascript code in a 'Builder'.-evalScript :: CanvasFree a -> Builder-evalScript c = (evalState . execWriterT . runScript . eval . fromF) c 0+-- The first parameter should be a unique identifier to avoid name clashes with+-- other canvas elements in the html document.+evalScript :: Text -> CanvasFree a -> Builder+evalScript t c = (evalState . execWriterT . runScript . eval t . fromF) c 0 record :: [Builder] -> Script () record = tell . mconcat@@ -38,246 +41,246 @@ -------------------------------------------------------------------------------- -eval :: Free Canvas a -> Script a+eval :: Text -> Free Canvas a -> Script a -eval (Free (AddColorStop a1 a2 a3 c)) = do+eval uniqId (Free (AddColorStop a1 a2 a3 c)) = do record [jsStyle a3, ".addColorStop(" , jsDouble a1, comma, jsColor a2, ");"]- eval c+ eval uniqId c -eval (Free (Arc a1 a2 a3 a4 a5 a6 c)) = do- record ["ctx.arc("+eval uniqId (Free (Arc a1 a2 a3 a4 a5 a6 c)) = do+ record [fromText uniqId, "Ctx.arc(" , jsDouble a1, comma, jsDouble a2, comma , jsDouble a3, comma, jsDouble a4, comma , jsDouble a5, comma, jsBool a6 , ");"]- eval c+ eval uniqId c -eval (Free (ArcTo a1 a2 a3 a4 a5 c)) = do- record ["ctx.arcTo("+eval uniqId (Free (ArcTo a1 a2 a3 a4 a5 c)) = do+ record [fromText uniqId, "Ctx.arcTo(" , jsDouble a1, comma, jsDouble a2, comma , jsDouble a3, comma, jsDouble a4, comma , jsDouble a5, comma, ");"]- eval c+ eval uniqId c -eval (Free (BeginPath c)) = do- tell "ctx.beginPath();"- eval c+eval uniqId (Free (BeginPath c)) = do+ record [fromText uniqId, "Ctx.beginPath();"]+ eval uniqId c -eval (Free (BezierCurveTo a1 a2 a3 a4 a5 a6 c)) = do- record ["ctx.bezierCurveTo("+eval uniqId (Free (BezierCurveTo a1 a2 a3 a4 a5 a6 c)) = do+ record [fromText uniqId, "Ctx.bezierCurveTo(" , jsDouble a1, comma, jsDouble a2, comma , jsDouble a3, comma, jsDouble a4, comma , jsDouble a5, comma, jsDouble a6, ");"]- eval c+ eval uniqId c -eval (Free (ClearRect a1 a2 a3 a4 c)) = do- record ["ctx.clearRect("+eval uniqId (Free (ClearRect a1 a2 a3 a4 c)) = do+ record [fromText uniqId, "Ctx.clearRect(" , jsDouble a1, comma, jsDouble a2, comma , jsDouble a3, comma, jsDouble a4, ");"]- eval c+ eval uniqId c -eval (Free (Clip c)) = do- tell "ctx.clip();"- eval c+eval uniqId (Free (Clip c)) = do+ record [fromText uniqId, "Ctx.clip();"]+ eval uniqId c -eval (Free (ClosePath c)) = do- tell "ctx.closePath();"- eval c+eval uniqId (Free (ClosePath c)) = do+ record [fromText uniqId, "Ctx.closePath();"]+ eval uniqId c -eval (Free (CreateLinearGradient a1 a2 a3 a4 k)) = do+eval uniqId (Free (CreateLinearGradient a1 a2 a3 a4 k)) = do i <- inc- record ["var gradient_", jsInt i, " = ctx.createLinearGradient("+ record ["var gradient_", jsInt i, " = ", fromText uniqId, "Ctx.createLinearGradient(" , jsDouble a1, comma, jsDouble a2, comma , jsDouble a3, comma, jsDouble a4, ");"]- eval (k (GradientStyle (LG i)))+ eval uniqId (k (GradientStyle (LG i))) -eval (Free (CreatePattern a1 a2 k)) = do+eval uniqId (Free (CreatePattern a1 a2 k)) = do i <- inc- record ["var pattern_", jsInt i, " = ctx.createPattern(image_"+ record ["var pattern_", jsInt i, " = ", fromText uniqId, "Ctx.createPattern(image_" , jsInt a1, comma, jsRepeat a2, ");"]- eval (k (PatternStyle i))+ eval uniqId (k (PatternStyle i)) -eval (Free (CreateRadialGradient a1 a2 a3 a4 a5 a6 k)) = do+eval uniqId (Free (CreateRadialGradient a1 a2 a3 a4 a5 a6 k)) = do i <- inc- record ["var gradient_", jsInt i, " = ctx.createRadialGradient("+ record ["var gradient_", jsInt i, " = ", fromText uniqId, "Ctx.createRadialGradient(" , jsDouble a1, comma, jsDouble a2, comma , jsDouble a3, comma, jsDouble a4, comma , jsDouble a5, comma, jsDouble a6, ");"]- eval (k (GradientStyle (RG i)))+ eval uniqId (k (GradientStyle (RG i))) -eval (Free (DrawImageAt a1 a2 a3 c)) = do- record ["ctx.drawImage(image_", jsInt a1, comma+eval uniqId (Free (DrawImageAt a1 a2 a3 c)) = do+ record [fromText uniqId, "Ctx.drawImage(image_", jsInt a1, comma , jsDouble a2, comma, jsDouble a3, ");"]- eval c+ eval uniqId c -eval (Free (DrawImageSize a1 a2 a3 a4 a5 c)) = do- record ["ctx.drawImage(image_", jsInt a1, comma+eval uniqId (Free (DrawImageSize a1 a2 a3 a4 a5 c)) = do+ record [fromText uniqId, "Ctx.drawImage(image_", jsInt a1, comma , jsDouble a2, comma, jsDouble a3, comma , jsDouble a4, comma, jsDouble a5, ");"]- eval c+ eval uniqId c -eval (Free (DrawImageCrop a1 a2 a3 a4 a5 a6 a7 a8 a9 c)) = do- record ["ctx.drawImage(image_", jsInt a1, comma+eval uniqId (Free (DrawImageCrop a1 a2 a3 a4 a5 a6 a7 a8 a9 c)) = do+ record [fromText uniqId, "Ctx.drawImage(image_", jsInt a1, comma , jsDouble a2, comma, jsDouble a3, comma , jsDouble a4, comma, jsDouble a5, comma , jsDouble a6, comma, jsDouble a7, comma , jsDouble a8, comma, jsDouble a9, ");"]- eval c+ eval uniqId c -eval (Free (Fill c)) = do- tell "ctx.fill();"- eval c+eval uniqId (Free (Fill c)) = do+ record [fromText uniqId, "Ctx.fill();"]+ eval uniqId c -eval (Free (FillRect a1 a2 a3 a4 c)) = do- record ["ctx.fillRect("+eval uniqId (Free (FillRect a1 a2 a3 a4 c)) = do+ record [fromText uniqId, "Ctx.fillRect(" , jsDouble a1, comma, jsDouble a2, comma , jsDouble a3, comma, jsDouble a4, ");"]- eval c+ eval uniqId c -eval (Free (FillStyle a1 c)) = do- record ["ctx.fillStyle = (", jsStyle a1, ");"]- eval c+eval uniqId (Free (FillStyle a1 c)) = do+ record [fromText uniqId, "Ctx.fillStyle = (", jsStyle a1, ");"]+ eval uniqId c -eval (Free (FillText a1 a2 a3 c)) = do- record ["ctx.fillText('", fromText a1, singleton '\'', comma+eval uniqId (Free (FillText a1 a2 a3 c)) = do+ record [fromText uniqId, "Ctx.fillText('", fromText a1, singleton '\'', comma , jsDouble a2, comma , jsDouble a3, ");"]- eval c+ eval uniqId c -eval (Free (Font a1 c)) = do- record ["ctx.font = ('", fromText a1, "');"]- eval c+eval uniqId (Free (Font a1 c)) = do+ record [fromText uniqId, "Ctx.font = ('", fromText a1, "');"]+ eval uniqId c -eval (Free (GlobalAlpha a1 c)) = do- record ["ctx.globalAlpha = (", jsDouble a1, ");"]- eval c+eval uniqId (Free (GlobalAlpha a1 c)) = do+ record [fromText uniqId, "Ctx.globalAlpha = (", jsDouble a1, ");"]+ eval uniqId c -eval (Free (GlobalCompositeOperation a1 c)) = do- record ["ctx.globalCompositeOperation = ('", jsComposite a1, "');"]- eval c+eval uniqId (Free (GlobalCompositeOperation a1 c)) = do+ record [fromText uniqId, "Ctx.globalCompositeOperation = ('", jsComposite a1, "');"]+ eval uniqId c -eval (Free (LineCap a1 c)) = do- record ["ctx.lineCap = ('", jsLineCap a1, "');"]- eval c+eval uniqId (Free (LineCap a1 c)) = do+ record [fromText uniqId, "Ctx.lineCap = ('", jsLineCap a1, "');"]+ eval uniqId c -eval (Free (LineJoin a1 c)) = do- record ["ctx.lineJoin = ('", jsLineJoin a1, "');"]- eval c+eval uniqId (Free (LineJoin a1 c)) = do+ record [fromText uniqId, "Ctx.lineJoin = ('", jsLineJoin a1, "');"]+ eval uniqId c -eval (Free (LineTo a1 a2 c)) = do- record ["ctx.lineTo(", jsDouble a1, comma, jsDouble a2, ");"]- eval c+eval uniqId (Free (LineTo a1 a2 c)) = do+ record [fromText uniqId, "Ctx.lineTo(", jsDouble a1, comma, jsDouble a2, ");"]+ eval uniqId c -eval (Free (LineWidth a1 c)) = do- record ["ctx.lineWidth = (", jsDouble a1, ");"]- eval c+eval uniqId (Free (LineWidth a1 c)) = do+ record [fromText uniqId, "Ctx.lineWidth = (", jsDouble a1, ");"]+ eval uniqId c -eval (Free (MiterLimit a1 c)) = do- record ["ctx.miterLimit = (", jsDouble a1, ");"]- eval c+eval uniqId (Free (MiterLimit a1 c)) = do+ record [fromText uniqId, "Ctx.miterLimit = (", jsDouble a1, ");"]+ eval uniqId c -eval (Free (MoveTo a1 a2 c)) = do- record ["ctx.moveTo(", jsDouble a1, comma, jsDouble a2, ");"]- eval c+eval uniqId (Free (MoveTo a1 a2 c)) = do+ record [fromText uniqId, "Ctx.moveTo(", jsDouble a1, comma, jsDouble a2, ");"]+ eval uniqId c -eval (Free (NewImage a1 k)) = do+eval uniqId (Free (NewImage a1 k)) = do i <- inc record ["var image_", jsInt i, " = new Image(); image_" , jsInt i, ".src = ('", fromText a1, "');"]- eval (k i)+ eval uniqId (k i) -eval (Free (OnImageLoad a1 a2 c)) = do- record ["image_", jsInt a1, ".onload = function() {", evalScript a2, "};"]- eval c+eval uniqId (Free (OnImageLoad a1 a2 c)) = do+ record ["image_", jsInt a1, ".onload = function() {", evalScript uniqId a2, "};"]+ eval uniqId c -eval (Free (QuadraticCurveTo a1 a2 a3 a4 c)) = do- record ["ctx.quadraticCurveTo("+eval uniqId (Free (QuadraticCurveTo a1 a2 a3 a4 c)) = do+ record [fromText uniqId, "Ctx.quadraticCurveTo(" , jsDouble a1, comma, jsDouble a2, comma , jsDouble a3, comma, jsDouble a4, ");"]- eval c+ eval uniqId c -eval (Free (Rect a1 a2 a3 a4 c)) = do- record ["ctx.rect(", jsDouble a1, comma+eval uniqId (Free (Rect a1 a2 a3 a4 c)) = do+ record [fromText uniqId, "Ctx.rect(", jsDouble a1, comma , jsDouble a2, comma , jsDouble a3, comma , jsDouble a4, ");"]- eval c+ eval uniqId c -eval (Free (Restore c)) = do- tell "ctx.restore();"- eval c+eval uniqId (Free (Restore c)) = do+ record [fromText uniqId, "Ctx.restore();"]+ eval uniqId c -eval (Free (Rotate a1 c)) = do- record ["ctx.rotate(", jsDouble a1, ");"]- eval c+eval uniqId (Free (Rotate a1 c)) = do+ record [fromText uniqId, "Ctx.rotate(", jsDouble a1, ");"]+ eval uniqId c -eval (Free (Save c)) = do- tell "ctx.save();"- eval c+eval uniqId (Free (Save c)) = do+ record [fromText uniqId, "Ctx.save();"]+ eval uniqId c -eval (Free (Scale a1 a2 c)) = do- record ["ctx.scale(", jsDouble a1, comma, jsDouble a2, ");"]- eval c+eval uniqId (Free (Scale a1 a2 c)) = do+ record [fromText uniqId, "Ctx.scale(", jsDouble a1, comma, jsDouble a2, ");"]+ eval uniqId c -eval (Free (SetTransform a1 a2 a3 a4 a5 a6 c)) = do- record ["ctx.setTransform("+eval uniqId (Free (SetTransform a1 a2 a3 a4 a5 a6 c)) = do+ record [fromText uniqId, "Ctx.setTransform(" , jsDouble a1, comma, jsDouble a2, comma , jsDouble a3, comma, jsDouble a4, comma , jsDouble a5, comma, jsDouble a6, ");"]- eval c+ eval uniqId c -eval (Free (ShadowColor a1 c)) = do- record ["ctx.shadowColor = ('", jsColor a1, "');"]- eval c+eval uniqId (Free (ShadowColor a1 c)) = do+ record [fromText uniqId, "Ctx.shadowColor = ('", jsColor a1, "');"]+ eval uniqId c -eval (Free (ShadowBlur a1 c)) = do- record ["ctx.shadowBlur = (", jsDouble a1, ");"]- eval c+eval uniqId (Free (ShadowBlur a1 c)) = do+ record [fromText uniqId, "Ctx.shadowBlur = (", jsDouble a1, ");"]+ eval uniqId c -eval (Free (ShadowOffsetX a1 c)) = do- record ["ctx.shadowOffsetX = (", jsDouble a1, ");"]- eval c+eval uniqId (Free (ShadowOffsetX a1 c)) = do+ record [fromText uniqId, "Ctx.shadowOffsetX = (", jsDouble a1, ");"]+ eval uniqId c -eval (Free (ShadowOffsetY a1 c)) = do- record ["ctx.shadowOffsetY = (", jsDouble a1, ");"]- eval c+eval uniqId (Free (ShadowOffsetY a1 c)) = do+ record [fromText uniqId, "Ctx.shadowOffsetY = (", jsDouble a1, ");"]+ eval uniqId c -eval (Free (Stroke c)) = do- tell "ctx.stroke();"- eval c+eval uniqId (Free (Stroke c)) = do+ record [fromText uniqId, "Ctx.stroke();"]+ eval uniqId c -eval (Free (StrokeRect a1 a2 a3 a4 c)) = do- record ["ctx.strokeRect("+eval uniqId (Free (StrokeRect a1 a2 a3 a4 c)) = do+ record [fromText uniqId, "Ctx.strokeRect(" , jsDouble a1, comma, jsDouble a2, comma , jsDouble a3, comma, jsDouble a4, ");"]- eval c+ eval uniqId c -eval (Free (StrokeStyle a1 c)) = do- record ["ctx.strokeStyle = (", jsStyle a1, ");"]- eval c+eval uniqId (Free (StrokeStyle a1 c)) = do+ record [fromText uniqId, "Ctx.strokeStyle = (", jsStyle a1, ");"]+ eval uniqId c -eval (Free (StrokeText a1 a2 a3 c)) = do- record ["ctx.strokeText('", fromText a1, singleton '\''+eval uniqId (Free (StrokeText a1 a2 a3 c)) = do+ record [fromText uniqId, "Ctx.strokeText('", fromText a1, singleton '\'' , comma, jsDouble a2, comma, jsDouble a3, ");"]- eval c+ eval uniqId c -eval (Free (TextAlign a1 c)) = do- record ["ctx.textAlign = ('", jsTextAlign a1, "');"]- eval c+eval uniqId (Free (TextAlign a1 c)) = do+ record [fromText uniqId, "Ctx.textAlign = ('", jsTextAlign a1, "');"]+ eval uniqId c -eval (Free (TextBaseline a1 c)) = do- record ["ctx.textBaseline = ('", jsTextBaseline a1, "');"]- eval c+eval uniqId (Free (TextBaseline a1 c)) = do+ record [fromText uniqId, "Ctx.textBaseline = ('", jsTextBaseline a1, "');"]+ eval uniqId c -eval (Free (Transform a1 a2 a3 a4 a5 a6 c)) = do- record ["ctx.transform("+eval uniqId (Free (Transform a1 a2 a3 a4 a5 a6 c)) = do+ record [fromText uniqId, "Ctx.transform(" , jsDouble a1, comma, jsDouble a2, comma , jsDouble a3, comma, jsDouble a4, comma , jsDouble a5, comma, jsDouble a6, ");"]- eval c+ eval uniqId c -eval (Free (Translate a1 a2 c)) = do- record ["translate(", jsDouble a1, comma, jsDouble a2, ");"]- eval c+eval uniqId (Free (Translate a1 a2 c)) = do+ record [fromText uniqId, "Ctx.translate(", jsDouble a1, comma, jsDouble a2, ");"]+ eval uniqId c -eval (Pure x) = return x+eval uniqId (Pure x) = return x
src/Graphics/Static/Types.hs view
@@ -9,7 +9,7 @@ -- License : BSD-style (see LICENSE) -- Maintainer : jeffrey.rosenbluth@gmail.com ----- A simple DSL for creating HTML5 Canvas.+-- A small DSL for creating HTML5 Canvas. -- -------------------------------------------------------------------------------
static-canvas.cabal view
@@ -1,5 +1,5 @@ name: static-canvas-version: 0.1.0.0+version: 0.2.0.0 synopsis: DSL to generate HTML5 Canvas javascript. description: A simple DSL for writing HTML5 Canvas in haskell and converting it@@ -29,8 +29,8 @@ Graphics.Static.Interpreter Graphics.Static.Javascript build-depends: base >=4.5 && < 4.9,- mtl >= 2.2 && < 2.3,- free >= 4.10 && < 4.11,+ mtl >= 2.1 && < 2.3,+ free >= 4.9 && < 4.11, text >=0.11 && < 1.3, double-conversion >= 2.0 && < 2.1 hs-source-dirs: src