{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE JavaScriptFFI #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}

{-
  Copyright 2020 The CodeWorld Authors. All rights reserved.
  Licensed under the Apache License, Version 2.0 (the "License");
  you may not use this file except in compliance with the License.
  You may obtain a copy of the License at
      http://www.apache.org/licenses/LICENSE-2.0
  Unless required by applicable law or agreed to in writing, software
  distributed under the License is distributed on an "AS IS" BASIS,
  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  See the License for the specific language governing permissions and
  limitations under the License.
-}

module CodeWorld.CanvasM where

import Control.Monad.Reader
import Data.Text (Text)

#ifdef ghcjs_HOST_OS

import Data.JSString.Text
import GHCJS.DOM
import GHCJS.DOM.Document
import GHCJS.DOM.Element
import GHCJS.DOM.Node
import GHCJS.DOM.NonElementParentNode
import GHCJS.Types
import qualified JavaScript.Web.Canvas as Canvas
import qualified JavaScript.Web.Canvas.Internal as Canvas

#else

import Data.Text (pack)
import qualified Graphics.Blank as Canvas
import Graphics.Blank (Canvas)
import Text.Printf

#endif

class (Monad m, MonadIO m) => MonadCanvas m where
  type Image m

  save :: m ()
  restore :: m ()
  transform ::
    Double -> Double -> Double -> Double -> Double -> Double -> m ()
  translate :: Double -> Double -> m ()
  scale :: Double -> Double -> m ()
  newImage :: Int -> Int -> m (Image m)
  builtinImage :: Text -> m (Maybe (Image m))
  withImage :: Image m -> m a -> m a
  drawImage :: Image m -> Int -> Int -> Int -> Int -> m ()
  drawImgURL :: Text -> Text -> Double -> Double -> m ()
  globalCompositeOperation :: Text -> m ()
  globalAlpha :: Double -> m ()
  lineWidth :: Double -> m ()
  strokeColor :: Int -> Int -> Int -> Double -> m ()
  fillColor :: Int -> Int -> Int -> Double -> m ()
  font :: Text -> m ()
  textCenter :: m ()
  textMiddle :: m ()
  beginPath :: m ()
  closePath :: m ()
  moveTo :: (Double, Double) -> m ()
  lineTo :: (Double, Double) -> m ()
  quadraticCurveTo :: (Double, Double) -> (Double, Double) -> m ()
  bezierCurveTo ::
    (Double, Double) -> (Double, Double) -> (Double, Double) -> m ()
  arc :: Double -> Double -> Double -> Double -> Double -> Bool -> m ()
  rect :: Double -> Double -> Double -> Double -> m ()
  clip :: m ()
  fill :: m ()
  stroke :: m ()
  fillRect :: Double -> Double -> Double -> Double -> m ()
  fillText :: Text -> (Double, Double) -> m ()
  measureText :: Text -> m Double
  isPointInPath :: (Double, Double) -> m Bool
  isPointInStroke :: (Double, Double) -> m Bool
  getScreenWidth :: m Double
  getScreenHeight :: m Double

saveRestore :: MonadCanvas m => m a -> m a
saveRestore :: forall (m :: * -> *) a. MonadCanvas m => m a -> m a
saveRestore m a
m = do
  forall (m :: * -> *). MonadCanvas m => m ()
save
  a
r <- m a
m
  forall (m :: * -> *). MonadCanvas m => m ()
restore
  forall (m :: * -> *) a. Monad m => a -> m a
return a
r

#if defined(ghcjs_HOST_OS)

data CanvasM a = CanvasM
    { unCanvasM :: (Double, Double) -> Canvas.Context -> IO a
    } deriving (Functor)

runCanvasM :: (Double, Double) -> Canvas.Context -> CanvasM a -> IO a
runCanvasM dim ctx m = unCanvasM m dim ctx

instance Applicative CanvasM where
    pure x = CanvasM (\_ _ -> return x)
    f <*> x = CanvasM (\dim ctx -> unCanvasM f dim ctx <*> unCanvasM x dim ctx)

instance Monad CanvasM where
    return = pure
    m >>= f = CanvasM $ \dim ctx -> do
        x <- unCanvasM m dim ctx
        unCanvasM (f x) dim ctx

foreign import javascript "$6.drawImage($1, $2, $3, $4, $5);"
    js_drawImage :: Element -> Double -> Double -> Double -> Double -> Canvas.Context -> IO ()

foreign import javascript "$2.globalCompositeOperation = $1;"
    js_globalCompositeOperation :: JSString -> Canvas.Context -> IO ()

foreign import javascript "$2.globalAlpha = $1;"
    js_globalAlpha :: Double -> Canvas.Context -> IO ()

foreign import javascript "$r = $3.isPointInPath($1, $2);"
    js_isPointInPath :: Double -> Double -> Canvas.Context -> IO Bool

foreign import javascript "$r = $3.isPointInStroke($1, $2);"
    js_isPointInStroke :: Double -> Double -> Canvas.Context -> IO Bool

foreign import javascript interruptible "$1.onload = $c; $1.src = $2;"
    js_loadImage :: Element -> JSString -> IO ()

instance MonadIO CanvasM where
    liftIO action = CanvasM $ \_ _ -> action

createOrGetImage :: Text -> Text -> IO Element
createOrGetImage name url = do
    Just doc <- currentDocument
    maybeImg <- getElementById doc name
    case maybeImg of
        Just img -> return img
        Nothing -> do
            img <- createElement doc (textToJSString "img")
            setAttribute img (textToJSString "style") (textToJSString "display: none")
            setAttribute img (textToJSString "id") name
            Just body <- getBody doc
            _ <- appendChild body img
            js_loadImage img (textToJSString url)
            return img

instance MonadCanvas CanvasM where
    type Image CanvasM = Canvas.Canvas
    save = CanvasM (const Canvas.save)
    restore = CanvasM (const Canvas.restore)
    transform a b c d e f = CanvasM (const (Canvas.transform a b c d e f))
    translate x y = CanvasM (const (Canvas.translate x y))
    scale x y = CanvasM (const (Canvas.scale x y))
    newImage w h = liftIO (Canvas.create w h)
    builtinImage name = liftIO $ do
        Just doc <- currentDocument
        canvas <- getElementById doc (textToJSString name)
        return (Canvas.Canvas . unElement <$> canvas)
    withImage img m = liftIO $ do
        ctx <- Canvas.getContext img
        w <- realToFrac <$> Canvas.width img
        h <- realToFrac <$> Canvas.height img
        unCanvasM m (w, h) ctx
    drawImage (Canvas.Canvas c) x y w h =
        CanvasM (const (Canvas.drawImage (Canvas.Image c) x y w h))
    drawImgURL name url w h = CanvasM $ \ _ ctx -> do
        img <- createOrGetImage name url
        js_drawImage img (-w/2) (-h/2) w h ctx
    globalCompositeOperation op =
        CanvasM (const (js_globalCompositeOperation (textToJSString op)))
    globalAlpha a = CanvasM (const (js_globalAlpha a))
    lineWidth w = CanvasM (const (Canvas.lineWidth w))
    strokeColor r g b a = CanvasM (const (Canvas.strokeStyle r g b a))
    fillColor r g b a = CanvasM (const (Canvas.fillStyle r g b a))
    font t = CanvasM (const (Canvas.font (textToJSString t)))
    textCenter = CanvasM (const (Canvas.textAlign Canvas.Center))
    textMiddle = CanvasM (const (Canvas.textBaseline Canvas.Middle))
    beginPath = CanvasM (const Canvas.beginPath)
    closePath = CanvasM (const Canvas.closePath)
    moveTo (x, y) = CanvasM (const (Canvas.moveTo x y))
    lineTo (x, y) = CanvasM (const (Canvas.lineTo x y))
    quadraticCurveTo (x1, y1) (x2, y2) =
        CanvasM (const (Canvas.quadraticCurveTo x1 y1 x2 y2))
    bezierCurveTo (x1, y1) (x2, y2) (x3, y3) =
        CanvasM (const (Canvas.bezierCurveTo x1 y1 x2 y2 x3 y3))
    arc x y r a1 a2 dir = CanvasM (const (Canvas.arc x y r a1 a2 dir))
    rect x y w h = CanvasM (const (Canvas.rect x y w h))
    clip = CanvasM (const Canvas.clip)
    fill = CanvasM (const Canvas.fill)
    stroke = CanvasM (const Canvas.stroke)
    fillRect x y w h = CanvasM (const (Canvas.fillRect x y w h))
    fillText t (x, y) = CanvasM (const (Canvas.fillText (textToJSString t) x y))
    measureText t = CanvasM (const (Canvas.measureText (textToJSString t)))
    isPointInPath (x, y) = CanvasM (const (js_isPointInPath x y))
    isPointInStroke (x, y) = CanvasM (const (js_isPointInStroke x y))
    getScreenWidth = CanvasM $ \(w, _) _ -> return w
    getScreenHeight = CanvasM $ \(_, h) _ -> return h

#else

-- Unfortunately, the Canvas monad from blank-canvas lacks a MonadIO instance.
-- We can recover it by inserting send calls where needed.  This looks a lot
-- like a free monad, but we want our own interpreter logic, so it's written
-- by hand.

data CanvasM a = CanvasOp (Maybe Canvas.CanvasContext) (Canvas (CanvasM a))
               | NativeOp (Canvas.DeviceContext -> IO (CanvasM a))
               | PureOp a
    deriving (forall a b. a -> CanvasM b -> CanvasM a
forall a b. (a -> b) -> CanvasM a -> CanvasM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> CanvasM b -> CanvasM a
$c<$ :: forall a b. a -> CanvasM b -> CanvasM a
fmap :: forall a b. (a -> b) -> CanvasM a -> CanvasM b
$cfmap :: forall a b. (a -> b) -> CanvasM a -> CanvasM b
Functor)

doCanvas :: Maybe Canvas.CanvasContext -> Canvas a -> Canvas a
doCanvas :: forall a. Maybe CanvasContext -> Canvas a -> Canvas a
doCanvas Maybe CanvasContext
Nothing Canvas a
m = Canvas a
m
doCanvas (Just CanvasContext
ctx) Canvas a
m = forall a. CanvasContext -> Canvas a -> Canvas a
Canvas.with CanvasContext
ctx Canvas a
m

interpCanvas :: CanvasM a -> Canvas (CanvasM a)
interpCanvas :: forall a. CanvasM a -> Canvas (CanvasM a)
interpCanvas (CanvasOp Maybe CanvasContext
mctx Canvas (CanvasM a)
op) = forall a. Maybe CanvasContext -> Canvas a -> Canvas a
doCanvas Maybe CanvasContext
mctx Canvas (CanvasM a)
op forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. CanvasM a -> Canvas (CanvasM a)
interpCanvas
interpCanvas CanvasM a
other = forall (m :: * -> *) a. Monad m => a -> m a
return CanvasM a
other

runCanvasM :: Canvas.DeviceContext -> CanvasM a -> IO a
runCanvasM :: forall a. DeviceContext -> CanvasM a -> IO a
runCanvasM DeviceContext
_    (PureOp   a
a)   = forall (m :: * -> *) a. Monad m => a -> m a
return a
a
runCanvasM DeviceContext
dctx (NativeOp DeviceContext -> IO (CanvasM a)
fm) = DeviceContext -> IO (CanvasM a)
fm DeviceContext
dctx forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. DeviceContext -> CanvasM a -> IO a
runCanvasM DeviceContext
dctx
runCanvasM DeviceContext
dctx CanvasM a
m             = forall a. DeviceContext -> Canvas a -> IO a
Canvas.send DeviceContext
dctx (forall a. CanvasM a -> Canvas (CanvasM a)
interpCanvas CanvasM a
m) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. DeviceContext -> CanvasM a -> IO a
runCanvasM DeviceContext
dctx

instance Applicative CanvasM where
    pure :: forall a. a -> CanvasM a
pure = forall a. a -> CanvasM a
PureOp

    (CanvasOp Maybe CanvasContext
mctx1 Canvas (CanvasM (a -> b))
f) <*> :: forall a b. CanvasM (a -> b) -> CanvasM a -> CanvasM b
<*> (CanvasOp Maybe CanvasContext
mctx2 Canvas (CanvasM a)
x) = forall a. Maybe CanvasContext -> Canvas (CanvasM a) -> CanvasM a
CanvasOp Maybe CanvasContext
mctx1 (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>) Canvas (CanvasM (a -> b))
f forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Maybe CanvasContext -> Canvas a -> Canvas a
doCanvas Maybe CanvasContext
mctx2 Canvas (CanvasM a)
x)
    CanvasM (a -> b)
f <*> CanvasM a
x = CanvasM (a -> b)
f forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` CanvasM a
x

instance Monad CanvasM where
    return :: forall a. a -> CanvasM a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure
    PureOp a
x >>= :: forall a b. CanvasM a -> (a -> CanvasM b) -> CanvasM b
>>= a -> CanvasM b
f = a -> CanvasM b
f a
x
    NativeOp DeviceContext -> IO (CanvasM a)
op >>= a -> CanvasM b
f = forall a. (DeviceContext -> IO (CanvasM a)) -> CanvasM a
NativeOp forall a b. (a -> b) -> a -> b
$ \DeviceContext
dctx -> do
        CanvasM a
next <- DeviceContext -> IO (CanvasM a)
op DeviceContext
dctx
        forall (m :: * -> *) a. Monad m => a -> m a
return (CanvasM a
next forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> CanvasM b
f)
    CanvasOp Maybe CanvasContext
mctx Canvas (CanvasM a)
op >>= a -> CanvasM b
f = forall a. Maybe CanvasContext -> Canvas (CanvasM a) -> CanvasM a
CanvasOp Maybe CanvasContext
mctx forall a b. (a -> b) -> a -> b
$ forall a b.
Canvas (CanvasM a) -> (a -> CanvasM b) -> Canvas (CanvasM b)
bindCanvas (forall a. Maybe CanvasContext -> Canvas a -> Canvas a
doCanvas Maybe CanvasContext
mctx Canvas (CanvasM a)
op) a -> CanvasM b
f

bindCanvas :: Canvas (CanvasM a) -> (a -> CanvasM b) -> Canvas (CanvasM b)
bindCanvas :: forall a b.
Canvas (CanvasM a) -> (a -> CanvasM b) -> Canvas (CanvasM b)
bindCanvas Canvas (CanvasM a)
m a -> CanvasM b
cont = do
    CanvasM a
next <- Canvas (CanvasM a)
m
    case CanvasM a
next of
        CanvasOp Maybe CanvasContext
mctx Canvas (CanvasM a)
op -> forall a b.
Canvas (CanvasM a) -> (a -> CanvasM b) -> Canvas (CanvasM b)
bindCanvas (forall a. Maybe CanvasContext -> Canvas a -> Canvas a
doCanvas Maybe CanvasContext
mctx Canvas (CanvasM a)
op) a -> CanvasM b
cont
        CanvasM a
_                -> forall (m :: * -> *) a. Monad m => a -> m a
return (CanvasM a
next forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> CanvasM b
cont)

instance MonadIO CanvasM where
    liftIO :: forall a. IO a -> CanvasM a
liftIO IO a
x = forall a. (DeviceContext -> IO (CanvasM a)) -> CanvasM a
NativeOp forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a. a -> CanvasM a
PureOp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a
x

liftCanvas :: Canvas a -> CanvasM a
liftCanvas :: forall a. Canvas a -> CanvasM a
liftCanvas Canvas a
m = forall a. Maybe CanvasContext -> Canvas (CanvasM a) -> CanvasM a
CanvasOp forall a. Maybe a
Nothing (forall a. a -> CanvasM a
PureOp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Canvas a
m)

instance MonadCanvas CanvasM where
    type Image CanvasM = Canvas.CanvasContext

    save :: CanvasM ()
save = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ () -> Canvas ()
Canvas.save ()
    restore :: CanvasM ()
restore = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ () -> Canvas ()
Canvas.restore ()
    transform :: Double
-> Double -> Double -> Double -> Double -> Double -> CanvasM ()
transform Double
a Double
b Double
c Double
d Double
e Double
f = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ (Double, Double, Double, Double, Double, Double) -> Canvas ()
Canvas.transform (Double
a, Double
b, Double
c, Double
d, Double
e, Double
f)
    translate :: Double -> Double -> CanvasM ()
translate Double
x Double
y = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ (Double, Double) -> Canvas ()
Canvas.translate (Double
x, Double
y)
    scale :: Double -> Double -> CanvasM ()
scale Double
x Double
y = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ (Double, Double) -> Canvas ()
Canvas.scale (Double
x, Double
y)
    newImage :: Int -> Int -> CanvasM (Image CanvasM)
newImage Int
w Int
h = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ (Int, Int) -> Canvas CanvasContext
Canvas.newCanvas (Int
w, Int
h)
    builtinImage :: Text -> CanvasM (Maybe (Image CanvasM))
builtinImage Text
_name = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

    withImage :: forall a. Image CanvasM -> CanvasM a -> CanvasM a
withImage Image CanvasM
ctx (CanvasOp Maybe CanvasContext
Nothing Canvas (CanvasM a)
m) = forall a. Maybe CanvasContext -> Canvas (CanvasM a) -> CanvasM a
CanvasOp (forall a. a -> Maybe a
Just Image CanvasM
ctx) Canvas (CanvasM a)
m
    withImage Image CanvasM
_   (CanvasOp Maybe CanvasContext
mctx Canvas (CanvasM a)
m)    = forall a. Maybe CanvasContext -> Canvas (CanvasM a) -> CanvasM a
CanvasOp Maybe CanvasContext
mctx Canvas (CanvasM a)
m
    withImage Image CanvasM
ctx (NativeOp DeviceContext -> IO (CanvasM a)
fm)        = forall a. (DeviceContext -> IO (CanvasM a)) -> CanvasM a
NativeOp forall a b. (a -> b) -> a -> b
$ \DeviceContext
dctx -> forall (m :: * -> *) a. MonadCanvas m => Image m -> m a -> m a
withImage Image CanvasM
ctx forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DeviceContext -> IO (CanvasM a)
fm DeviceContext
dctx
    withImage Image CanvasM
_   (PureOp a
x)           = forall a. a -> CanvasM a
PureOp a
x

    drawImage :: Image CanvasM -> Int -> Int -> Int -> Int -> CanvasM ()
drawImage Image CanvasM
img Int
x Int
y Int
w Int
h = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$
        forall image.
Image image =>
(image, Double, Double, Double, Double) -> Canvas ()
Canvas.drawImageSize
            ( Image CanvasM
img
            , forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x
            , forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
y
            , forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w
            , forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h)

    drawImgURL :: Text -> Text -> Double -> Double -> CanvasM ()
drawImgURL Text
_name Text
_url Double
_w Double
_h = forall (m :: * -> *) a. Monad m => a -> m a
return ()

    globalCompositeOperation :: Text -> CanvasM ()
globalCompositeOperation Text
op = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ Text -> Canvas ()
Canvas.globalCompositeOperation Text
op
    globalAlpha :: Double -> CanvasM ()
globalAlpha Double
a = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ Double -> Canvas ()
Canvas.globalAlpha Double
a
    lineWidth :: Double -> CanvasM ()
lineWidth Double
w = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ Double -> Canvas ()
Canvas.lineWidth Double
w
    strokeColor :: Int -> Int -> Int -> Double -> CanvasM ()
strokeColor Int
r Int
g Int
b Double
a = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ Text -> Canvas ()
Canvas.strokeStyle
        (String -> Text
pack (forall r. PrintfType r => String -> r
printf String
"rgba(%d,%d,%d,%.2f)" Int
r Int
g Int
b Double
a))
    fillColor :: Int -> Int -> Int -> Double -> CanvasM ()
fillColor Int
r Int
g Int
b Double
a = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ Text -> Canvas ()
Canvas.fillStyle
        (String -> Text
pack (forall r. PrintfType r => String -> r
printf String
"rgba(%d,%d,%d,%.2f)" Int
r Int
g Int
b Double
a))
    font :: Text -> CanvasM ()
font Text
t = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ Text -> Canvas ()
Canvas.font Text
t
    textCenter :: CanvasM ()
textCenter = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ TextAnchorAlignment -> Canvas ()
Canvas.textAlign TextAnchorAlignment
Canvas.CenterAnchor
    textMiddle :: CanvasM ()
textMiddle = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ TextBaselineAlignment -> Canvas ()
Canvas.textBaseline TextBaselineAlignment
Canvas.MiddleBaseline
    beginPath :: CanvasM ()
beginPath = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ () -> Canvas ()
Canvas.beginPath ()
    closePath :: CanvasM ()
closePath = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ () -> Canvas ()
Canvas.closePath ()
    moveTo :: (Double, Double) -> CanvasM ()
moveTo (Double
x, Double
y) = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ (Double, Double) -> Canvas ()
Canvas.moveTo (Double
x, Double
y)
    lineTo :: (Double, Double) -> CanvasM ()
lineTo (Double
x, Double
y) = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ (Double, Double) -> Canvas ()
Canvas.lineTo (Double
x, Double
y)
    quadraticCurveTo :: (Double, Double) -> (Double, Double) -> CanvasM ()
quadraticCurveTo (Double
x1, Double
y1) (Double
x2, Double
y2) = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$
        (Double, Double, Double, Double) -> Canvas ()
Canvas.quadraticCurveTo (Double
x1, Double
y1, Double
x2, Double
y2)
    bezierCurveTo :: (Double, Double)
-> (Double, Double) -> (Double, Double) -> CanvasM ()
bezierCurveTo (Double
x1, Double
y1) (Double
x2, Double
y2) (Double
x3, Double
y3) = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$
        (Double, Double, Double, Double, Double, Double) -> Canvas ()
Canvas.bezierCurveTo (Double
x1, Double
y1, Double
x2, Double
y2, Double
x3, Double
y3)
    arc :: Double
-> Double -> Double -> Double -> Double -> Bool -> CanvasM ()
arc Double
x Double
y Double
r Double
a1 Double
a2 Bool
dir = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$
        (Double, Double, Double, Double, Double, Bool) -> Canvas ()
Canvas.arc (Double
x, Double
y, Double
r, Double
a1, Double
a2, Bool
dir)
    rect :: Double -> Double -> Double -> Double -> CanvasM ()
rect Double
x Double
y Double
w Double
h = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ (Double, Double, Double, Double) -> Canvas ()
Canvas.rect (Double
x, Double
y, Double
w, Double
h)
    clip :: CanvasM ()
clip = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ () -> Canvas ()
Canvas.clip ()
    fill :: CanvasM ()
fill = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ () -> Canvas ()
Canvas.fill ()
    stroke :: CanvasM ()
stroke = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ () -> Canvas ()
Canvas.stroke ()
    fillRect :: Double -> Double -> Double -> Double -> CanvasM ()
fillRect Double
x Double
y Double
w Double
h = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ (Double, Double, Double, Double) -> Canvas ()
Canvas.fillRect (Double
x, Double
y, Double
w, Double
h)
    fillText :: Text -> (Double, Double) -> CanvasM ()
fillText Text
t (Double
x, Double
y) = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ (Text, Double, Double) -> Canvas ()
Canvas.fillText (Text
t, Double
x, Double
y)
    measureText :: Text -> CanvasM Double
measureText Text
t = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ do
        Canvas.TextMetrics Double
w <- Text -> Canvas TextMetrics
Canvas.measureText Text
t
        forall (m :: * -> *) a. Monad m => a -> m a
return Double
w
    isPointInPath :: (Double, Double) -> CanvasM Bool
isPointInPath (Double
x, Double
y) = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ (Double, Double) -> Canvas Bool
Canvas.isPointInPath (Double
x, Double
y)
    isPointInStroke :: (Double, Double) -> CanvasM Bool
isPointInStroke (Double, Double)
_ = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    getScreenWidth :: CanvasM Double
getScreenWidth = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ forall image a. (Image image, Num a) => image -> a
Canvas.width forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Canvas CanvasContext
Canvas.myCanvasContext
    getScreenHeight :: CanvasM Double
getScreenHeight = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ forall image a. (Image image, Num a) => image -> a
Canvas.height forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Canvas CanvasContext
Canvas.myCanvasContext

#endif