module Graphics.Static.Interpreter
( evalScript
) where
import Control.Monad.Free (Free(..))
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
evalScript :: Text -> CanvasFree a -> Builder
evalScript t c = (evalState . execWriterT . runScript . eval t . fromF) c 0
record :: [Builder] -> Script ()
record = tell . mconcat
inc :: Script Int
inc = do
n <- get
put (n + 1)
return n
eval :: Text -> Free Canvas a -> Script a
eval uniqId (Free (AddColorStop a1 a2 a3 c)) = do
record [jsStyle a3, ".addColorStop("
, jsDouble a1, comma, jsColor a2, ");"]
eval uniqId c
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 uniqId c
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 uniqId c
eval uniqId (Free (BeginPath c)) = do
record [fromText uniqId, "Ctx.beginPath();"]
eval uniqId c
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 uniqId c
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 uniqId c
eval uniqId (Free (Clip c)) = do
record [fromText uniqId, "Ctx.clip();"]
eval uniqId c
eval uniqId (Free (ClosePath c)) = do
record [fromText uniqId, "Ctx.closePath();"]
eval uniqId c
eval uniqId (Free (CreateLinearGradient a1 a2 a3 a4 k)) = do
i <- inc
record ["var gradient_", jsInt i, " = ", fromText uniqId, "Ctx.createLinearGradient("
, jsDouble a1, comma, jsDouble a2, comma
, jsDouble a3, comma, jsDouble a4, ");"]
eval uniqId (k (GradientStyle (LG i)))
eval uniqId (Free (CreatePattern a1 a2 k)) = do
i <- inc
record ["var pattern_", jsInt i, " = ", fromText uniqId, "Ctx.createPattern(image_"
, jsInt a1, comma, jsRepeat a2, ");"]
eval uniqId (k (PatternStyle i))
eval uniqId (Free (CreateRadialGradient a1 a2 a3 a4 a5 a6 k)) = do
i <- inc
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 uniqId (k (GradientStyle (RG i)))
eval uniqId (Free (DrawImageAt a1 a2 a3 c)) = do
record [fromText uniqId, "Ctx.drawImage(image_", jsInt a1, comma
, jsDouble a2, comma, jsDouble a3, ");"]
eval uniqId c
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 uniqId c
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 uniqId c
eval uniqId (Free (Fill c)) = do
record [fromText uniqId, "Ctx.fill();"]
eval uniqId c
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 uniqId c
eval uniqId (Free (FillStyle a1 c)) = do
record [fromText uniqId, "Ctx.fillStyle = (", jsStyle a1, ");"]
eval uniqId c
eval uniqId (Free (FillText a1 a2 a3 c)) = do
record [fromText uniqId, "Ctx.fillText('", fromText a1, singleton '\'', comma
, jsDouble a2, comma
, jsDouble a3, ");"]
eval uniqId c
eval uniqId (Free (Font a1 c)) = do
record [fromText uniqId, "Ctx.font = ('", fromText a1, "');"]
eval uniqId c
eval uniqId (Free (GlobalAlpha a1 c)) = do
record [fromText uniqId, "Ctx.globalAlpha = (", jsDouble a1, ");"]
eval uniqId c
eval uniqId (Free (GlobalCompositeOperation a1 c)) = do
record [fromText uniqId, "Ctx.globalCompositeOperation = ('", jsComposite a1, "');"]
eval uniqId c
eval uniqId (Free (LineCap a1 c)) = do
record [fromText uniqId, "Ctx.lineCap = ('", jsLineCap a1, "');"]
eval uniqId c
eval uniqId (Free (LineJoin a1 c)) = do
record [fromText uniqId, "Ctx.lineJoin = ('", jsLineJoin a1, "');"]
eval uniqId c
eval uniqId (Free (LineTo a1 a2 c)) = do
record [fromText uniqId, "Ctx.lineTo(", jsDouble a1, comma, jsDouble a2, ");"]
eval uniqId c
eval uniqId (Free (LineWidth a1 c)) = do
record [fromText uniqId, "Ctx.lineWidth = (", jsDouble a1, ");"]
eval uniqId c
eval uniqId (Free (MiterLimit a1 c)) = do
record [fromText uniqId, "Ctx.miterLimit = (", jsDouble a1, ");"]
eval uniqId c
eval uniqId (Free (MoveTo a1 a2 c)) = do
record [fromText uniqId, "Ctx.moveTo(", jsDouble a1, comma, jsDouble a2, ");"]
eval uniqId c
eval uniqId (Free (NewImage a1 k)) = do
i <- inc
record ["var image_", jsInt i, " = new Image(); image_"
, jsInt i, ".src = ('", fromText a1, "');"]
eval uniqId (k i)
eval uniqId (Free (OnImageLoad a1 a2 c)) = do
record ["image_", jsInt a1, ".onload = function() {", evalScript uniqId a2, "};"]
eval uniqId c
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 uniqId c
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 uniqId c
eval uniqId (Free (Restore c)) = do
record [fromText uniqId, "Ctx.restore();"]
eval uniqId c
eval uniqId (Free (Rotate a1 c)) = do
record [fromText uniqId, "Ctx.rotate(", jsDouble a1, ");"]
eval uniqId c
eval uniqId (Free (Save c)) = do
record [fromText uniqId, "Ctx.save();"]
eval uniqId c
eval uniqId (Free (Scale a1 a2 c)) = do
record [fromText uniqId, "Ctx.scale(", jsDouble a1, comma, jsDouble a2, ");"]
eval uniqId c
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 uniqId c
eval uniqId (Free (ShadowColor a1 c)) = do
record [fromText uniqId, "Ctx.shadowColor = ('", jsColor a1, "');"]
eval uniqId c
eval uniqId (Free (ShadowBlur a1 c)) = do
record [fromText uniqId, "Ctx.shadowBlur = (", jsDouble a1, ");"]
eval uniqId c
eval uniqId (Free (ShadowOffsetX a1 c)) = do
record [fromText uniqId, "Ctx.shadowOffsetX = (", jsDouble a1, ");"]
eval uniqId c
eval uniqId (Free (ShadowOffsetY a1 c)) = do
record [fromText uniqId, "Ctx.shadowOffsetY = (", jsDouble a1, ");"]
eval uniqId c
eval uniqId (Free (Stroke c)) = do
record [fromText uniqId, "Ctx.stroke();"]
eval uniqId c
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 uniqId c
eval uniqId (Free (StrokeStyle a1 c)) = do
record [fromText uniqId, "Ctx.strokeStyle = (", jsStyle a1, ");"]
eval uniqId c
eval uniqId (Free (StrokeText a1 a2 a3 c)) = do
record [fromText uniqId, "Ctx.strokeText('", fromText a1, singleton '\''
, comma, jsDouble a2, comma, jsDouble a3, ");"]
eval uniqId c
eval uniqId (Free (TextAlign a1 c)) = do
record [fromText uniqId, "Ctx.textAlign = ('", jsTextAlign a1, "');"]
eval uniqId c
eval uniqId (Free (TextBaseline a1 c)) = do
record [fromText uniqId, "Ctx.textBaseline = ('", jsTextBaseline a1, "');"]
eval uniqId c
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 uniqId 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