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
import qualified Data.Aeson as JSON

{-----------------------------------------------------------------------------
    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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Color -> Color -> Bool
$c/= :: Color -> Color -> Bool
== :: Color -> Color -> Bool
$c== :: Color -> Color -> Bool
Eq, Int -> Color -> ShowS
[Color] -> ShowS
Color -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Color] -> ShowS
$cshowList :: [Color] -> ShowS
show :: Color -> String
$cshow :: Color -> String
showsPrec :: Int -> Color -> ShowS
$cshowsPrec :: Int -> 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Gradient] -> ShowS
$cshowList :: [Gradient] -> ShowS
show :: Gradient -> String
$cshow :: Gradient -> String
showsPrec :: Int -> Gradient -> ShowS
$cshowsPrec :: Int -> Gradient -> ShowS
Show, Gradient -> Gradient -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Gradient -> Gradient -> Bool
$c/= :: Gradient -> Gradient -> Bool
== :: Gradient -> Gradient -> Bool
$c== :: 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FillStyle] -> ShowS
$cshowList :: [FillStyle] -> ShowS
show :: FillStyle -> String
$cshow :: FillStyle -> String
showsPrec :: Int -> FillStyle -> ShowS
$cshowsPrec :: Int -> FillStyle -> ShowS
Show, FillStyle -> FillStyle -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FillStyle -> FillStyle -> Bool
$c/= :: FillStyle -> FillStyle -> Bool
== :: FillStyle -> FillStyle -> Bool
$c== :: 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 forall a b. (a -> b) -> a -> b
$ 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 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a b. (a -> b) -> a -> b
$ 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 = 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 forall a b. (a -> b) -> a -> b
$ forall a. FFI a => String -> a
ffi String
cmd Canvas
canvas
        where cmd :: String
cmd = String
"var ctx=%1.getContext('2d'); var grd=" forall a. [a] -> [a] -> [a]
++ Gradient -> String
fsStr Gradient
fs forall a. [a] -> [a] -> [a]
++ Gradient -> String
cStops Gradient
fs 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(" forall a. [a] -> [a] -> [a]
++ [Double] -> String
pStr [Double
x0, Double
y0, Double
x0forall a. Num a => a -> a -> a
+Double
w, Double
y0forall a. Num a => a -> a -> a
+Double
h] forall a. [a] -> [a] -> [a]
++ String
");"
              cStops :: Gradient -> String
cStops (LinearGradient Vector
_ Double
_ Double
_ [ColorStop]
sts) = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {a}. Show a => (a, Color) -> String
addStop [ColorStop]
sts
              addStop :: (a, Color) -> String
addStop (a
p,Color
c)                     = String
"grd.addColorStop(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
p forall a. [a] -> [a] -> [a]
++ String
",'" forall a. [a] -> [a] -> [a]
++ Color -> String
rgbString Color
c forall a. [a] -> [a] -> [a]
++ String
"');"
              pStr :: [Double] -> String
pStr                              = forall a. [a] -> [[a]] -> [a]
intercalate String
"," forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show
assignFillStyle (SolidColor Color
color) Canvas
canvas =
    JSFunction () -> UI ()
runFunction forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ 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 = 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 = 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 = 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TextAlign -> TextAlign -> Bool
$c/= :: TextAlign -> TextAlign -> Bool
== :: TextAlign -> TextAlign -> Bool
$c== :: TextAlign -> TextAlign -> Bool
Eq, Int -> TextAlign -> ShowS
[TextAlign] -> ShowS
TextAlign -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TextAlign] -> ShowS
$cshowList :: [TextAlign] -> ShowS
show :: TextAlign -> String
$cshow :: TextAlign -> String
showsPrec :: Int -> TextAlign -> ShowS
$cshowsPrec :: Int -> TextAlign -> ShowS
Show, ReadPrec [TextAlign]
ReadPrec TextAlign
Int -> ReadS TextAlign
ReadS [TextAlign]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [TextAlign]
$creadListPrec :: ReadPrec [TextAlign]
readPrec :: ReadPrec TextAlign
$creadPrec :: ReadPrec TextAlign
readList :: ReadS [TextAlign]
$creadList :: ReadS [TextAlign]
readsPrec :: Int -> ReadS TextAlign
$creadsPrec :: Int -> ReadS 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 = 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 forall a b. (a -> b) -> a -> b
$ Attr Canvas String
textAlignStr
    where
    textAlignStr :: Attr Canvas String
    textAlignStr :: Attr Canvas String
textAlignStr = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
text (Double
x,Double
y) Canvas
canvas =
  JSFunction () -> UI ()
runFunction forall a b. (a -> b) -> a -> b
$ forall a. FFI a => String -> a
ffi String
"%1.getContext('2d').fillText(%2, %3, %4)" Canvas
canvas String
text 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
text (Double
x,Double
y) Canvas
canvas =
  JSFunction () -> UI ()
runFunction forall a b. (a -> b) -> a -> b
$ forall a. FFI a => String -> a
ffi String
"%1.getContext('2d').strokeText(%2, %3, %4)" Canvas
canvas String
text 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
"#" forall a. [a] -> [a] -> [a]
++ forall {a}. (Integral a, Show a) => a -> String
sh Int
r forall a. [a] -> [a] -> [a]
++ forall {a}. (Integral a, Show a) => a -> String
sh Int
g forall a. [a] -> [a] -> [a]
++ forall {a}. (Integral a, Show a) => a -> String
sh Int
b
    (RGBA Int
r Int
g Int
b Double
a) -> String
"rgba(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
r forall a. [a] -> [a] -> [a]
++ String
"," forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
g forall a. [a] -> [a] -> [a]
++ String
"," forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
b forall a. [a] -> [a] -> [a]
++ String
"," forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Double
a forall a. [a] -> [a] -> [a]
++ String
")"
    where sh :: a -> String
sh a
i  = ShowS
pad forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper forall a b. (a -> b) -> a -> b
$ forall a. (Integral a, Show a) => a -> ShowS
showHex a
i String
""
          pad :: ShowS
pad String
s
            | forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s  forall a. Eq a => a -> a -> Bool
== Int
0 = String
"00"
            | forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s  forall a. Eq a => a -> a -> Bool
== Int
1 = Char
'0' forall a. a -> [a] -> [a]
: String
s
            | forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s  forall a. Eq a => a -> a -> Bool
== Int
2 = String
s
            | Bool
otherwise      =  forall a. Int -> [a] -> [a]
take Int
2 String
s