module Graphics.UI.Threepenny.Canvas (
    -- * Synopsis
    -- | Partial binding to the HTML5 canvas API.

    -- * Documentation
    Canvas
    , Vector, Point
    , Color(..), ColorStop, Gradient, FillStyle
    , drawImage, clearCanvas
    , solidColor, htmlColor
    , linearGradient, horizontalLinearGradient, verticalLinearGradient
    , fillRect, fillStyle, strokeStyle, lineWidth, textFont
    , TextAlign(..), textAlign
    , beginPath, moveTo, lineTo, closePath, arc, arc'
    , fill, stroke, fillText, strokeText
    ) where

import Data.Char (toUpper)
import Data.List(intercalate)
import Numeric (showHex)

import Graphics.UI.Threepenny.Core

{-----------------------------------------------------------------------------
    Canvas
------------------------------------------------------------------------------}
type Canvas = Element

type Vector = Point
type Point  = (Double, Double)
data Color  = RGB  { Color -> Int
red :: Int, Color -> Int
green :: Int, Color -> Int
blue :: Int }
            | RGBA { red :: Int, green :: Int, blue :: Int, Color -> Double
alpha :: Double }
            deriving (Color -> Color -> Bool
(Color -> Color -> Bool) -> (Color -> Color -> Bool) -> Eq Color
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Color -> Color -> Bool
== :: Color -> Color -> Bool
$c/= :: Color -> Color -> Bool
/= :: Color -> Color -> Bool
Eq, Int -> Color -> ShowS
[Color] -> ShowS
Color -> String
(Int -> Color -> ShowS)
-> (Color -> String) -> ([Color] -> ShowS) -> Show Color
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Color -> ShowS
showsPrec :: Int -> Color -> ShowS
$cshow :: Color -> String
show :: Color -> String
$cshowList :: [Color] -> ShowS
showList :: [Color] -> ShowS
Show)

type ColorStop = (Double,  Color)

data Gradient  
    -- | defines a linear gradient 
    -- see <http://www.w3schools.com/tags/canvas_createlineargradient.asp> 
    = LinearGradient 
      { Gradient -> Vector
upperLeft  :: Vector -- ^ the left-upper point where the gradient should begin
      , Gradient -> Double
gradWidth  :: Double -- ^ the width of the gradient
      , Gradient -> Double
gradHeight :: Double -- ^ the height of the gradient
      , Gradient -> [ColorStop]
colorStops :: [ColorStop] -- ^ the gradients color stops
      } deriving (Int -> Gradient -> ShowS
[Gradient] -> ShowS
Gradient -> String
(Int -> Gradient -> ShowS)
-> (Gradient -> String) -> ([Gradient] -> ShowS) -> Show Gradient
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Gradient -> ShowS
showsPrec :: Int -> Gradient -> ShowS
$cshow :: Gradient -> String
show :: Gradient -> String
$cshowList :: [Gradient] -> ShowS
showList :: [Gradient] -> ShowS
Show, Gradient -> Gradient -> Bool
(Gradient -> Gradient -> Bool)
-> (Gradient -> Gradient -> Bool) -> Eq Gradient
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Gradient -> Gradient -> Bool
== :: Gradient -> Gradient -> Bool
$c/= :: Gradient -> Gradient -> Bool
/= :: Gradient -> Gradient -> Bool
Eq)

data FillStyle
    = SolidColor Color
    | HtmlColor String    -- Html representation of a color
    | Gradient Gradient
    deriving (Int -> FillStyle -> ShowS
[FillStyle] -> ShowS
FillStyle -> String
(Int -> FillStyle -> ShowS)
-> (FillStyle -> String)
-> ([FillStyle] -> ShowS)
-> Show FillStyle
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FillStyle -> ShowS
showsPrec :: Int -> FillStyle -> ShowS
$cshow :: FillStyle -> String
show :: FillStyle -> String
$cshowList :: [FillStyle] -> ShowS
showList :: [FillStyle] -> ShowS
Show, FillStyle -> FillStyle -> Bool
(FillStyle -> FillStyle -> Bool)
-> (FillStyle -> FillStyle -> Bool) -> Eq FillStyle
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FillStyle -> FillStyle -> Bool
== :: FillStyle -> FillStyle -> Bool
$c/= :: FillStyle -> FillStyle -> Bool
/= :: FillStyle -> FillStyle -> Bool
Eq) 


{-----------------------------------------------------------------------------
    Image drawing
------------------------------------------------------------------------------}

-- | Draw the image of an image element onto the canvas at a specified position.
drawImage :: Element -> Vector -> Canvas -> UI ()
drawImage :: Canvas -> Vector -> Canvas -> UI ()
drawImage Canvas
image (Double
x,Double
y) Canvas
canvas =
    JSFunction () -> UI ()
runFunction (JSFunction () -> UI ()) -> JSFunction () -> UI ()
forall a b. (a -> b) -> a -> b
$ String -> Canvas -> Canvas -> Double -> Double -> JSFunction ()
forall a. FFI a => String -> a
ffi String
"%1.getContext('2d').drawImage(%2,%3,%4)" Canvas
canvas Canvas
image Double
x Double
y

{-----------------------------------------------------------------------------
    Fill Styles
------------------------------------------------------------------------------}

-- | creates a solid-color fillstyle
solidColor :: Color -> FillStyle
solidColor :: Color -> FillStyle
solidColor Color
rgb = Color -> FillStyle
SolidColor Color
rgb

-- | Solid color represented as a HTML string.
htmlColor :: String -> FillStyle
htmlColor :: String -> FillStyle
htmlColor = String -> FillStyle
HtmlColor

-- | creates a linear gradient fill style
linearGradient :: Point       -- ^ The upper-left coordinate of the gradient
               -> Double      -- ^ The width of the gradient
               -> Double      -- ^ The height of the gradient
               -> [ColorStop] -- ^ the color-stops for the gradient
               -> FillStyle
linearGradient :: Vector -> Double -> Double -> [ColorStop] -> FillStyle
linearGradient (Double
x0, Double
y0) Double
w Double
h [ColorStop]
sts = Gradient -> FillStyle
Gradient (Gradient -> FillStyle) -> Gradient -> FillStyle
forall a b. (a -> b) -> a -> b
$ Vector -> Double -> Double -> [ColorStop] -> Gradient
LinearGradient (Double
x0,Double
y0) Double
w Double
h [ColorStop]
sts

-- | creates a simple horizontal gradient
horizontalLinearGradient:: Point  -- ^ The upper-left coordinate of the gradient
                        -> Double -- ^ The width of the gradient
                        -> Color  -- ^ The starting color of the gradient
                        -> Color  -- ^ The ending color of the gradient
                        -> FillStyle
horizontalLinearGradient :: Vector -> Double -> Color -> Color -> FillStyle
horizontalLinearGradient Vector
pt Double
w Color
c0 Color
c1 = Vector -> Double -> Double -> [ColorStop] -> FillStyle
linearGradient Vector
pt Double
w Double
0 [(Double
0, Color
c0), (Double
1, Color
c1)]

-- | creates a simple vertical gradient
verticalLinearGradient:: Point  -- ^ The upper-left coordinate of the gradient
                      -> Double -- ^ The height of the gradient
                      -> Color  -- ^ The starting color of the gradient
                      -> Color  -- ^ The ending color of the gradient
                      -> FillStyle
verticalLinearGradient :: Vector -> Double -> Color -> Color -> FillStyle
verticalLinearGradient Vector
pt Double
h Color
c0 Color
c1 = Vector -> Double -> Double -> [ColorStop] -> FillStyle
linearGradient Vector
pt Double
0 Double
h [(Double
0, Color
c0), (Double
1, Color
c1)]

{-----------------------------------------------------------------------------
    general
------------------------------------------------------------------------------}

-- | Clear the canvas
clearCanvas :: Canvas -> UI ()
clearCanvas :: Canvas -> UI ()
clearCanvas = JSFunction () -> UI ()
runFunction (JSFunction () -> UI ())
-> (Canvas -> JSFunction ()) -> Canvas -> UI ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Canvas -> JSFunction ()
forall a. FFI a => String -> a
ffi String
"%1.getContext('2d').clear()"


{-----------------------------------------------------------------------------
    fill primitives
------------------------------------------------------------------------------}


-- | Draw a filled rectangle.
--
-- The 'fillStyle' attribute determines the color.
fillRect
    :: Point    -- ^ upper left corner
    -> Double   -- ^ width in pixels
    -> Double   -- ^ height in pixels
    -> Canvas -> UI ()
fillRect :: Vector -> Double -> Double -> Canvas -> UI ()
fillRect (Double
x,Double
y) Double
w Double
h Canvas
canvas =
  JSFunction () -> UI ()
runFunction (JSFunction () -> UI ()) -> JSFunction () -> UI ()
forall a b. (a -> b) -> a -> b
$ String
-> Canvas -> Double -> Double -> Double -> Double -> JSFunction ()
forall a. FFI a => String -> a
ffi String
"%1.getContext('2d').fillRect(%2, %3, %4, %5)" Canvas
canvas Double
x Double
y Double
w Double
h

-- | The Fillstyle to use inside shapes.
-- write-only as I could not find how to consistently read the fillstyle
fillStyle :: WriteAttr Canvas FillStyle
fillStyle :: WriteAttr Canvas FillStyle
fillStyle = (FillStyle -> Canvas -> UI ()) -> WriteAttr Canvas FillStyle
forall i x. (i -> x -> UI ()) -> WriteAttr x i
mkWriteAttr FillStyle -> Canvas -> UI ()
assignFillStyle

-- | sets the current fill style of the canvas context
assignFillStyle :: FillStyle -> Canvas -> UI ()
assignFillStyle :: FillStyle -> Canvas -> UI ()
assignFillStyle (Gradient Gradient
fs) Canvas
canvas =
    JSFunction () -> UI ()
runFunction (JSFunction () -> UI ()) -> JSFunction () -> UI ()
forall a b. (a -> b) -> a -> b
$ String -> Canvas -> JSFunction ()
forall a. FFI a => String -> a
ffi String
cmd Canvas
canvas
        where cmd :: String
cmd = String
"var ctx=%1.getContext('2d'); var grd=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Gradient -> String
fsStr Gradient
fs String -> ShowS
forall a. [a] -> [a] -> [a]
++ Gradient -> String
cStops Gradient
fs String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"ctx.fillStyle=grd;"
              fsStr :: Gradient -> String
fsStr (LinearGradient (Double
x0, Double
y0) Double
w Double
h [ColorStop]
_) 
                                                = String
"ctx.createLinearGradient(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Double] -> String
pStr [Double
x0, Double
y0, Double
x0Double -> Double -> Double
forall a. Num a => a -> a -> a
+Double
w, Double
y0Double -> Double -> Double
forall a. Num a => a -> a -> a
+Double
h] String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
");"
              cStops :: Gradient -> String
cStops (LinearGradient Vector
_ Double
_ Double
_ [ColorStop]
sts) = (ColorStop -> String) -> [ColorStop] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ColorStop -> String
forall {a}. Show a => (a, Color) -> String
addStop [ColorStop]
sts
              addStop :: (a, Color) -> String
addStop (a
p,Color
c)                     = String
"grd.addColorStop(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
",'" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Color -> String
rgbString Color
c String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"');"
              pStr :: [Double] -> String
pStr                              = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," ([String] -> String)
-> ([Double] -> [String]) -> [Double] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> String) -> [Double] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Double -> String
forall a. Show a => a -> String
show
assignFillStyle (SolidColor Color
color) Canvas
canvas =
    JSFunction () -> UI ()
runFunction (JSFunction () -> UI ()) -> JSFunction () -> UI ()
forall a b. (a -> b) -> a -> b
$ String -> Canvas -> String -> JSFunction ()
forall a. FFI a => String -> a
ffi String
"%1.getContext('2d').fillStyle=%2" Canvas
canvas (Color -> String
rgbString Color
color)
assignFillStyle (HtmlColor  String
color) Canvas
canvas =
    JSFunction () -> UI ()
runFunction (JSFunction () -> UI ()) -> JSFunction () -> UI ()
forall a b. (a -> b) -> a -> b
$ String -> Canvas -> String -> JSFunction ()
forall a. FFI a => String -> a
ffi String
"%1.getContext('2d').fillStyle=%2" Canvas
canvas String
color

-- | The color or style to use for the lines around shapes.
-- Default is @#000@ (black).
strokeStyle :: Attr Canvas String
strokeStyle :: Attr Canvas String
strokeStyle = String -> Attr Canvas String
forall a. (FromJS a, ToJS a) => String -> Attr Canvas a
fromObjectProperty String
"getContext('2d').strokeStyle"

-- | The width of lines. Default is @1@.
lineWidth :: Attr Canvas Double
lineWidth :: Attr Canvas Double
lineWidth = String -> Attr Canvas Double
forall a. (FromJS a, ToJS a) => String -> Attr Canvas a
fromObjectProperty String
"getContext('2d').lineWidth"

-- | The font used for 'fillText' and 'strokeText'.
-- Default is @10px sans-serif@.
textFont :: Attr Canvas String
textFont :: Attr Canvas String
textFont = String -> Attr Canvas String
forall a. (FromJS a, ToJS a) => String -> Attr Canvas a
fromObjectProperty String
"getContext('2d').font"

data TextAlign = Start | End | LeftAligned | RightAligned | Center
               deriving (TextAlign -> TextAlign -> Bool
(TextAlign -> TextAlign -> Bool)
-> (TextAlign -> TextAlign -> Bool) -> Eq TextAlign
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TextAlign -> TextAlign -> Bool
== :: TextAlign -> TextAlign -> Bool
$c/= :: TextAlign -> TextAlign -> Bool
/= :: TextAlign -> TextAlign -> Bool
Eq, Int -> TextAlign -> ShowS
[TextAlign] -> ShowS
TextAlign -> String
(Int -> TextAlign -> ShowS)
-> (TextAlign -> String)
-> ([TextAlign] -> ShowS)
-> Show TextAlign
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TextAlign -> ShowS
showsPrec :: Int -> TextAlign -> ShowS
$cshow :: TextAlign -> String
show :: TextAlign -> String
$cshowList :: [TextAlign] -> ShowS
showList :: [TextAlign] -> ShowS
Show, ReadPrec [TextAlign]
ReadPrec TextAlign
Int -> ReadS TextAlign
ReadS [TextAlign]
(Int -> ReadS TextAlign)
-> ReadS [TextAlign]
-> ReadPrec TextAlign
-> ReadPrec [TextAlign]
-> Read TextAlign
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS TextAlign
readsPrec :: Int -> ReadS TextAlign
$creadList :: ReadS [TextAlign]
readList :: ReadS [TextAlign]
$creadPrec :: ReadPrec TextAlign
readPrec :: ReadPrec TextAlign
$creadListPrec :: ReadPrec [TextAlign]
readListPrec :: ReadPrec [TextAlign]
Read)

aToS :: TextAlign -> String
aToS :: TextAlign -> String
aToS TextAlign
algn =
  case TextAlign
algn of
    TextAlign
Start -> String
"start"
    TextAlign
End -> String
"end"
    TextAlign
LeftAligned -> String
"left"
    TextAlign
RightAligned -> String
"right"
    TextAlign
Center -> String
"center"

sToA :: String -> TextAlign
sToA :: String -> TextAlign
sToA String
algn =
  case String
algn of
    String
"start" -> TextAlign
Start
    String
"end" -> TextAlign
End
    String
"left" -> TextAlign
LeftAligned
    String
"right" -> TextAlign
RightAligned
    String
"center" -> TextAlign
Center
    String
_ -> TextAlign
Start

-- | The alignment for 'fillText' and 'strokeText'. Default is 'Start'.
textAlign :: Attr Canvas TextAlign
textAlign :: Attr Canvas TextAlign
textAlign = (TextAlign -> String)
-> (String -> TextAlign)
-> Attr Canvas String
-> Attr Canvas TextAlign
forall i' i o o' x.
(i' -> i)
-> (o -> o') -> ReadWriteAttr x i o -> ReadWriteAttr x i' o'
bimapAttr TextAlign -> String
aToS String -> TextAlign
sToA (Attr Canvas String -> Attr Canvas TextAlign)
-> Attr Canvas String -> Attr Canvas TextAlign
forall a b. (a -> b) -> a -> b
$ Attr Canvas String
textAlignStr
    where
    textAlignStr :: Attr Canvas String
    textAlignStr :: Attr Canvas String
textAlignStr = String -> Attr Canvas String
forall a. (FromJS a, ToJS a) => String -> Attr Canvas a
fromObjectProperty String
"getContext('2d').textAlign"

-- | Starts a new path by resetting the list of sub-paths.
-- Call this function when you want to create a new path.
beginPath :: Canvas -> UI()
beginPath :: Canvas -> UI ()
beginPath = JSFunction () -> UI ()
runFunction (JSFunction () -> UI ())
-> (Canvas -> JSFunction ()) -> Canvas -> UI ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Canvas -> JSFunction ()
forall a. FFI a => String -> a
ffi String
"%1.getContext('2d').beginPath()"

-- | Moves the starting point of a new subpath to the @(x,y)@ coordinate.
moveTo :: Point -> Canvas -> UI()
moveTo :: Vector -> Canvas -> UI ()
moveTo (Double
x,Double
y) Canvas
canvas =
  JSFunction () -> UI ()
runFunction (JSFunction () -> UI ()) -> JSFunction () -> UI ()
forall a b. (a -> b) -> a -> b
$ String -> Canvas -> Double -> Double -> JSFunction ()
forall a. FFI a => String -> a
ffi String
"%1.getContext('2d').moveTo(%2, %3)" Canvas
canvas Double
x Double
y

-- | Connects the last point in the subpath to the @(x,y)@ coordinates
-- with a straight line.
lineTo :: Point -> Canvas -> UI()
lineTo :: Vector -> Canvas -> UI ()
lineTo (Double
x,Double
y) Canvas
canvas =
  JSFunction () -> UI ()
runFunction (JSFunction () -> UI ()) -> JSFunction () -> UI ()
forall a b. (a -> b) -> a -> b
$ String -> Canvas -> Double -> Double -> JSFunction ()
forall a. FFI a => String -> a
ffi String
"%1.getContext('2d').lineTo(%2, %3)" Canvas
canvas Double
x Double
y

-- | Draw a straight line from the current point to the start of the
-- path. If the shape has already been closed or has only one point,
-- this function does nothing.
closePath :: Canvas -> UI()
closePath :: Canvas -> UI ()
closePath = JSFunction () -> UI ()
runFunction (JSFunction () -> UI ())
-> (Canvas -> JSFunction ()) -> Canvas -> UI ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Canvas -> JSFunction ()
forall a. FFI a => String -> a
ffi String
"%1.getContext('2d').closePath()"

-- | Add a circular arc to the current path.
arc
    :: Point    -- ^ Center of the circle of which the arc is a part.
    -> Double   -- ^ Radius of the circle of which the arc is a part.
    -> Double   -- ^ Starting angle, in radians.
    -> Double   -- ^ Ending angle, in radians.
    -> Canvas -> UI ()
arc :: Vector -> Double -> Double -> Double -> Canvas -> UI ()
arc (Double
x,Double
y) Double
radius Double
startAngle Double
endAngle Canvas
canvas =
    JSFunction () -> UI ()
runFunction (JSFunction () -> UI ()) -> JSFunction () -> UI ()
forall a b. (a -> b) -> a -> b
$ String
-> Canvas
-> Double
-> Double
-> Double
-> Double
-> Double
-> JSFunction ()
forall a. FFI a => String -> a
ffi String
"%1.getContext('2d').arc(%2, %3, %4, %5, %6)"
        Canvas
canvas Double
x Double
y Double
radius Double
startAngle Double
endAngle

-- | Like 'arc', but with an extra argument that indicates whether
-- we go in counter-clockwise ('True') or clockwise ('False') direction.
arc' :: Point -> Double -> Double -> Double -> Bool -> Canvas -> UI ()
arc' :: Vector -> Double -> Double -> Double -> Bool -> Canvas -> UI ()
arc' (Double
x,Double
y) Double
radius Double
startAngle Double
endAngle Bool
anti Canvas
canvas =
    JSFunction () -> UI ()
runFunction (JSFunction () -> UI ()) -> JSFunction () -> UI ()
forall a b. (a -> b) -> a -> b
$ String
-> Canvas
-> Double
-> Double
-> Double
-> Double
-> Double
-> Bool
-> JSFunction ()
forall a. FFI a => String -> a
ffi String
"%1.getContext('2d').arc(%2, %3, %4, %5, %6, %7)"
        Canvas
canvas Double
x Double
y Double
radius Double
startAngle Double
endAngle Bool
anti

-- | Fills the subpaths with the current fill style.
fill :: Canvas -> UI ()
fill :: Canvas -> UI ()
fill = JSFunction () -> UI ()
runFunction (JSFunction () -> UI ())
-> (Canvas -> JSFunction ()) -> Canvas -> UI ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Canvas -> JSFunction ()
forall a. FFI a => String -> a
ffi String
"%1.getContext('2d').fill()"

-- | Strokes the subpaths with the current stroke style.
stroke :: Canvas -> UI ()
stroke :: Canvas -> UI ()
stroke = JSFunction () -> UI ()
runFunction (JSFunction () -> UI ())
-> (Canvas -> JSFunction ()) -> Canvas -> UI ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Canvas -> JSFunction ()
forall a. FFI a => String -> a
ffi String
"%1.getContext('2d').stroke()"

-- | Render a text in solid color at a certain point on the canvas.
-- 
-- The 'fillStyle' attribute determines the color.
-- The 'textFont' attribute determines the font used.
-- The 'textAlign' attributes determines the position of the text
-- relative to the point.
fillText :: String -> Point -> Canvas -> UI ()
fillText :: String -> Vector -> Canvas -> UI ()
fillText String
t (Double
x,Double
y) Canvas
canvas =
  JSFunction () -> UI ()
runFunction (JSFunction () -> UI ()) -> JSFunction () -> UI ()
forall a b. (a -> b) -> a -> b
$ String -> Canvas -> String -> Double -> Double -> JSFunction ()
forall a. FFI a => String -> a
ffi String
"%1.getContext('2d').fillText(%2, %3, %4)" Canvas
canvas String
t Double
x Double
y

-- | Render the outline of a text at a certain point on the canvas.
-- 
-- The 'strokeStyle' attribute determines the color of the outline.
-- The 'textFont' attribute determines the font used.
-- The 'textAlign' attributes determines the position of the text
-- relative to the point.
strokeText :: String -> Point -> Canvas -> UI ()
strokeText :: String -> Vector -> Canvas -> UI ()
strokeText String
t (Double
x,Double
y) Canvas
canvas =
  JSFunction () -> UI ()
runFunction (JSFunction () -> UI ()) -> JSFunction () -> UI ()
forall a b. (a -> b) -> a -> b
$ String -> Canvas -> String -> Double -> Double -> JSFunction ()
forall a. FFI a => String -> a
ffi String
"%1.getContext('2d').strokeText(%2, %3, %4)" Canvas
canvas String
t Double
x Double
y

{-----------------------------------------------------------------------------
    helper functions
------------------------------------------------------------------------------}

rgbString :: Color -> String
rgbString :: Color -> String
rgbString Color
color =
  case Color
color of
    (RGB Int
r Int
g Int
b) -> String
"#" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall {a}. Integral a => a -> String
sh Int
r String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall {a}. Integral a => a -> String
sh Int
g String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall {a}. Integral a => a -> String
sh Int
b
    (RGBA Int
r Int
g Int
b Double
a) -> String
"rgba(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
r String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"," String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
g String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"," String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
b String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"," String -> ShowS
forall a. [a] -> [a] -> [a]
++ Double -> String
forall a. Show a => a -> String
show Double
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
    where sh :: a -> String
sh a
i  = ShowS
pad ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ a -> ShowS
forall a. Integral a => a -> ShowS
showHex a
i String
""
          pad :: ShowS
pad String
s
            | String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s  Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = String
"00"
            | String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s  Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = Char
'0' Char -> ShowS
forall a. a -> [a] -> [a]
: String
s
            | String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s  Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2 = String
s
            | Bool
otherwise      =  Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
2 String
s