content: {-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances,
               GADTs, CPP, GeneralizedNewtypeDeriving #-}
  {-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
  -- | Basic Canvas graphics library.
  module Haste.Graphics.Canvas (
      -- * Basic types and classes
      Bitmap, Canvas, Shape, Picture, Point, Vector, Angle, Rect (..), Color (..),
      Ctx, AnyImageBuffer (..),
      ImageBuffer (..), BitmapSource (..),
  
      -- *  Obtaining a canvas
      getCanvasById, getCanvas, createCanvas,
  
      -- * Rendering and reading canvases
      render, renderOnTop, buffer, toDataURL,
  
      -- * Colors and opacity
      setStrokeColor, setFillColor, color, opacity,
  
      -- * Matrix operations
      translate, scale, rotate,
      -- * Drawing shapes
      stroke, fill, clip,
      lineWidth, line, path, rect, circle, arc,
  
      -- * Rendering text
      font, text,
  
      -- * Extending the library
      withContext
    ) where
  import Control.Monad.IO.Class
  import Data.Maybe (fromJust)
  import Haste
  import Haste.DOM.JSString
  import Haste.DOM.Core
  import Haste.Events.Core
  import Haste.Concurrent (CIO) -- for SPECIALISE pragma
  import Haste.Prim.Foreign (ToAny (..), FromAny (..), ffi)
  
  jsHasCtx2D :: Elem -> IO Bool
  jsHasCtx2D = ffi "(function(e){return !!e.getContext;})"
  
  jsGetCtx2D :: Elem -> IO Ctx
  jsGetCtx2D = ffi "(function(e){return e.getContext('2d');})"
  
  jsBeginPath :: Ctx -> IO ()
  jsBeginPath = ffi "(function(ctx){ctx.beginPath();})"
  
  jsMoveTo :: Ctx -> Double -> Double -> IO ()
  jsMoveTo = ffi "(function(ctx,x,y){ctx.moveTo(x,y);})"
  
  jsLineTo :: Ctx -> Double -> Double -> IO ()
  jsLineTo = ffi "(function(ctx,x,y){ctx.lineTo(x,y);})"
  
  jsStroke :: Ctx -> IO ()
  jsStroke = ffi "(function(ctx){ctx.stroke();})"
  
  jsFill :: Ctx -> IO ()
  jsFill = ffi "(function(ctx){ctx.fill();})"
  
  jsRotate :: Ctx -> Double -> IO ()
  jsRotate = ffi "(function(ctx,rad){ctx.rotate(rad);})"
  
  jsTranslate :: Ctx -> Double -> Double -> IO ()
  jsTranslate = ffi "(function(ctx,x,y){ctx.translate(x,y);})"
  
  jsScale :: Ctx -> Double -> Double -> IO ()
  jsScale = ffi "(function(ctx,x,y){ctx.scale(x,y);})"
  
  jsPushState :: Ctx -> IO ()
  jsPushState = ffi "(function(ctx){ctx.save();})"
  
  jsPopState :: Ctx -> IO ()
  jsPopState = ffi "(function(ctx){ctx.restore();})"
  
  jsResetCanvas :: Elem -> IO ()
  jsResetCanvas = ffi "(function(e){e.width = e.width;})"
  
  jsDrawImage :: Ctx -> Elem -> Double -> Double -> IO ()
  jsDrawImage = ffi "(function(ctx,i,x,y){ctx.drawImage(i,x,y);})"
  
  jsDrawImageClipped :: Ctx -> Elem
                     -> Double -> Double
                     -> Double -> Double -> Double -> Double
                     -> IO ()
  jsDrawImageClipped = ffi "(function(ctx, img, x, y, cx, cy, cw, ch){\
  ctx.drawImage(img, cx, cy, cw, ch, x, y, cw, ch);})"
  
  jsDrawImageScaled :: Ctx -> Elem
                    -> Double -> Double -> Double -> Double
                    -> IO ()
  jsDrawImageScaled = ffi "(function(ctx, img, x, y, w, h){\
  ctx.drawImage(img, x, y, w, h);})"
  
  jsDrawText :: Ctx -> JSString -> Double -> Double -> IO ()
  jsDrawText = ffi "(function(ctx,s,x,y){ctx.fillText(s,x,y);})"
  
  jsClip :: Ctx -> IO ()
  jsClip = ffi "(function(ctx){ctx.clip();})"
  
  jsArc :: Ctx -> Double -> Double
               -> Double
               -> Double -> Double
               -> IO ()
  jsArc = ffi "(function(ctx, x, y, radius, fromAngle, toAngle){\
  ctx.arc(x, y, radius, fromAngle, toAngle);})"
  
  jsCanvasToDataURL :: Elem -> IO URL
  jsCanvasToDataURL = ffi "(function(e){return e.toDataURL('image/png');})"
  
  -- | A bitmap, backed by an IMG element.
  --   JS representation is a reference to the backing IMG element.
  newtype Bitmap = Bitmap Elem
    deriving (ToAny, FromAny)
  
  -- | Any type that contains a buffered image which can be drawn onto a canvas.
  class ImageBuffer a where
    -- | Draw the image buffer with its top left corner at the specified point.
    draw :: a -> Point -> Picture ()
    -- | Draw a portion of the image buffer with its top left corner at the
    --   specified point.
    drawClipped :: a -> Point -> Rect -> Picture ()
    -- | Draw the image buffer within given rectangle.
    drawScaled :: a -> Rect -> Picture ()
  
  instance ImageBuffer Canvas where
    draw (Canvas _ buf) (x, y) = Picture $ \ctx -> jsDrawImage ctx buf x y
    drawClipped (Canvas _ buf) (x, y) (Rect cx cy cw ch) = Picture $ \ctx ->
      jsDrawImageClipped ctx buf x y cx cy cw ch
    drawScaled (Canvas _ buf) (Rect x y w h) = Picture $ \ctx ->
      jsDrawImageScaled ctx buf x y w h
  
  instance ImageBuffer Bitmap where
    draw (Bitmap buf) (x, y) = Picture $ \ctx -> jsDrawImage ctx buf x y
    drawClipped (Bitmap buf) (x, y) (Rect cx cy cw ch) = Picture $ \ctx ->
      jsDrawImageClipped ctx buf x y cx cy cw ch
    drawScaled (Bitmap buf) (Rect x y w h) = Picture $ \ctx ->
      jsDrawImageScaled ctx buf x y w h
  
  -- | Any type that can be used to obtain a bitmap.
  class BitmapSource src where
    -- | Load a bitmap from some kind of bitmap source.
    loadBitmap :: MonadIO m => src -> m Bitmap
  
  instance BitmapSource URL where
    loadBitmap url = liftIO $ do
      img <- newElem "img"
      setProp img "src" url
      loadBitmap img
  
  instance BitmapSource Elem where
    loadBitmap = return . Bitmap
  
  data AnyImageBuffer where
    AnyImageBuffer :: ImageBuffer a => a -> AnyImageBuffer
  
  instance ImageBuffer AnyImageBuffer where
    draw (AnyImageBuffer buf) = draw buf
    drawClipped (AnyImageBuffer buf) = drawClipped buf
    drawScaled (AnyImageBuffer buf) = drawScaled buf
  
  instance IsElem Canvas where
    elemOf (Canvas _ctx e) = e
    fromElem               = getCanvas
  
  instance EventSource Canvas where
    eventSource = eventSource . elemOf
  
  instance IsElem Bitmap where
    elemOf (Bitmap e) = e
  
  -- | A point in the plane.
  type Point = (Double, Double)
  
  -- | A two dimensional vector.
  type Vector = (Double, Double)
  
  -- | An angle, given in radians.
  type Angle = Double
  
  -- | A rectangle.
  data Rect = Rect {rect_x :: !Double,
                    rect_y :: !Double,
                    rect_w :: !Double,
                    rect_h :: !Double}
  
  -- | A color, specified using its red, green and blue components, with an
  --   optional alpha component.
  data Color = RGB  !Int !Int !Int
             | RGBA !Int !Int !Int !Double
  
  -- | Somewhat efficient conversion from Color to JSString.
  color2JSString :: Color -> JSString
  color2JSString (RGB r g b) =
    catJSStr "" ["rgb(", toJSString r, ",", toJSString g, ",", toJSString b, ")"]
  color2JSString (RGBA r g b a) =
    catJSStr "" ["rgba(", toJSString r, ",",
                          toJSString g, ",",
                          toJSString b, ",",
                          toJSString a, ")"]
  
  -- | A drawing context; part of a canvas.
  --   JS representation is the drawing context object itself.
  newtype Ctx = Ctx JSAny
    deriving (ToAny, FromAny)
  
  -- | A canvas; a viewport into which a picture can be rendered.
  --   The origin of the coordinate system used by the canvas is the top left
  --   corner of the canvas element.
  --   JS representation is a reference to the backing canvas element.
  data Canvas = Canvas !Ctx !Elem
  
  instance FromAny Canvas where
    fromAny c = do
      mcan <- fromAny c >>= fromElem
      case mcan of
        Just can -> return can
        _        -> error "Attempted to turn a non-canvas element into a Canvas!"
  
  instance ToAny Canvas where
    toAny (Canvas _ el) = toAny el
  
  -- | A picture that can be drawn onto a canvas.
  newtype Picture a = Picture {unP :: Ctx -> IO a}
  
  -- | A shape which can be either stroked or filled to yield a picture.
  newtype Shape a = Shape {unS :: Ctx -> IO a}
  
  instance Functor Picture where
    fmap f p = Picture $ \ctx ->
      unP p ctx >>= return . f
  
  instance Applicative Picture where
    pure a = Picture $ \_ -> return a
  
    pfab <*> pa = Picture $ \ctx -> do
      fab <- unP pfab ctx
      a   <- unP pa   ctx
      return (fab a)
  
  instance Monad Picture where
    return x = Picture $ \_ -> return x
    Picture m >>= f = Picture $ \ctx -> do
      x <- m ctx
      unP (f x) ctx
  
  instance Functor Shape where
    fmap f s = Shape $ \ctx ->
      unS s ctx >>= return . f
  
  instance Applicative Shape where
    pure a = Shape $ \_ -> return a
  
    sfab <*> sa = Shape $ \ctx -> do
      fab <- unS sfab ctx
      a   <- unS sa   ctx
      return (fab a)
  
  instance Monad Shape where
    return x = Shape $ \_ -> return x
    Shape m >>= f = Shape $ \ctx -> do
      x <- m ctx
      unS (f x) ctx
  
  -- | Create a 2D drawing context from a DOM element identified by its ID.
  getCanvasById :: MonadIO m => String -> m (Maybe Canvas)
  getCanvasById eid = liftIO $ do
    e <- elemById (toJSString eid)
    maybe (return Nothing) getCanvas e
  
  {-# DEPRECATED getCanvas "use the more general fromElem instead." #-}
  -- | Create a 2D drawing context from a DOM element.
  getCanvas :: MonadIO m => Elem -> m (Maybe Canvas)
  getCanvas e = liftIO $ do
    hasCtx <- jsHasCtx2D e
    case hasCtx of
      True -> do
        ctx <- jsGetCtx2D e
        return $ Just $ Canvas ctx e
      _    -> return Nothing
  
  -- | Create an off-screen buffer of the specified size.
  createCanvas :: MonadIO m => Int -> Int -> m Canvas
  createCanvas w h = liftIO $ do
    buf <- newElem "canvas"
    setProp buf "width" (toJSString w)
    setProp buf "height" (toJSString h)
    fromJust <$> getCanvas buf
  
  -- | Clear a canvas, then draw a picture onto it.
  {-# SPECIALISE render :: Canvas -> Picture a -> IO a #-}
  {-# SPECIALISE render :: Canvas -> Picture a -> CIO a #-}
  render :: MonadIO m => Canvas -> Picture a -> m a
  render (Canvas ctx el) (Picture p) = liftIO $ do
    jsResetCanvas el
    p ctx
  
  -- | Draw a picture onto a canvas without first clearing it.
  {-# SPECIALISE renderOnTop :: Canvas -> Picture a -> IO a #-}
  {-# SPECIALISE renderOnTop :: Canvas -> Picture a -> CIO a #-}
  renderOnTop :: MonadIO m => Canvas -> Picture a -> m a
  renderOnTop (Canvas ctx _) (Picture p) = liftIO $ p ctx
  
  -- | Generate a data URL from the contents of a canvas.
  toDataURL :: MonadIO m => Canvas -> m URL
  toDataURL (Canvas _ el) = liftIO $ jsCanvasToDataURL el
  
  -- | Create a new off-screen buffer and store the given picture in it.
  buffer :: MonadIO m => Int -> Int -> Picture () -> m Bitmap
  buffer w h pict = liftIO $ do
    buf@(Canvas _ el) <- createCanvas w h
    render buf pict
    return $ Bitmap el
  
  -- | Perform a computation over the drawing context of the picture.
  --   This is handy for operations which are either impossible, hard or
  --   inefficient to express using the Haste.Graphics.Canvas API.
  withContext :: (Ctx -> IO a) -> Picture a
  withContext f = Picture $ \ctx -> f ctx
  
  -- | Set a new color for strokes.
  setStrokeColor :: Color -> Picture ()
  setStrokeColor c = Picture $ \(Ctx ctx) -> do
    setProp (Elem ctx) "strokeStyle" (color2JSString c)
  
  -- | Set a new fill color.
  setFillColor :: Color -> Picture ()
  setFillColor c = Picture $ \(Ctx ctx) -> do
    setProp (Elem ctx) "fillStyle" (color2JSString c)
  
  -- | Draw a picture with the given opacity.
  opacity :: Double -> Picture () -> Picture ()
  opacity alpha (Picture pict) = Picture $ \(Ctx ctx) -> do
    alpha' <- getProp (Elem ctx) "globalAlpha"
    setProp (Elem ctx) "globalAlpha" (toJSString alpha)
    pict (Ctx ctx)
    setProp (Elem ctx) "globalAlpha" alpha'
  
  -- | Draw the given Picture using the specified Color for both stroke and fill,
  --   then restore the previous stroke and fill colors.
  color :: Color -> Picture () -> Picture ()
  color c (Picture pict) = Picture $ \(Ctx ctx) -> do
      fc <- getProp (Elem ctx) "fillStyle"
      sc <- getProp (Elem ctx) "strokeStyle"
      setProp (Elem ctx) "fillStyle" c'
      setProp (Elem ctx) "strokeStyle" c'
      pict (Ctx ctx)
      setProp (Elem ctx) "fillStyle" fc
      setProp (Elem ctx) "strokeStyle" sc
    where
      c' = color2JSString c
  
  -- | Draw the given picture using a new line width.
  lineWidth :: Double -> Picture () -> Picture ()
  lineWidth w (Picture pict) = Picture $ \(Ctx ctx) -> do
    lw <- getProp (Elem ctx) "lineWidth"
    setProp (Elem ctx) "lineWidth" (toJSString w)
    pict (Ctx ctx)
    setProp (Elem ctx) "lineWidth" lw
  
  -- | Draw the specified picture using the given point as the origin.
  translate :: Vector -> Picture () -> Picture ()
  translate (x, y) (Picture pict) = Picture $ \ctx -> do
    jsPushState ctx
    jsTranslate ctx x y
    pict ctx
    jsPopState ctx
  
  -- | Draw the specified picture rotated @r@ radians clockwise.
  rotate :: Double -> Picture () -> Picture ()
  rotate rad (Picture pict) = Picture $ \ctx -> do
    jsPushState ctx
    jsRotate ctx rad
    pict ctx
    jsPopState ctx
  
  -- | Draw the specified picture scaled as specified by the scale vector.
  scale :: Vector -> Picture () -> Picture ()
  scale (x, y) (Picture pict) = Picture $ \ctx -> do
    jsPushState ctx
    jsScale ctx x y
    pict ctx
    jsPopState ctx
  
  -- | Draw a filled shape.
  fill :: Shape () -> Picture ()
  fill (Shape shape) = Picture $ \ctx -> do
    jsBeginPath ctx
    shape ctx
    jsFill ctx
    
  -- | Draw the contours of a shape.
  stroke :: Shape () -> Picture ()
  stroke (Shape shape) = Picture $ \ctx -> do
    jsBeginPath ctx
    shape ctx
    jsStroke ctx
  
  -- | Draw a picture clipped to the given path.
  clip :: Shape () -> Picture () -> Picture ()
  clip (Shape shape) (Picture pict) = Picture $ \ctx -> do
    jsPushState ctx
    jsBeginPath ctx
    shape ctx
    jsClip ctx
    pict ctx
    jsPopState ctx
  
  -- | Draw a path along the specified points.
  path :: [Point] -> Shape ()
  path ((x1, y1):ps) = Shape $ \ctx -> do
    jsMoveTo ctx x1 y1
    mapM_ (uncurry $ jsLineTo ctx) ps
  path _ =
    return ()
  
  -- | Draw a line between two points.
  line :: Point -> Point -> Shape ()
  line p1 p2 = path [p1, p2]
  
  -- | Draw a rectangle between the two given points.
  rect :: Point -> Point -> Shape ()
  rect (x1, y1) (x2, y2) = path [(x1, y1), (x2, y1), (x2, y2), (x1, y2), (x1, y1)]
  
  -- | Draw a circle shape.
  circle :: Point -> Double -> Shape ()
  circle (x, y) radius = Shape $ \ctx -> do
    jsMoveTo ctx (x+radius) y
    jsArc ctx x y radius (0 :: Double) twoPi
  
  {-# INLINE twoPi #-}
  twoPi :: Double
  twoPi = 2*pi
  
  -- | Draw an arc. An arc is specified as a drawn portion of an imaginary
  --   circle with a center point, a radius, a starting angle and an ending
  --   angle.
  --   For instance, @arc (0, 0) 10 0 pi@ will draw a half circle centered at
  --   (0, 0), with a radius of 10 pixels.
  arc :: Point -> Double -> Angle -> Angle -> Shape ()
  arc (x, y) radius from to = Shape $ \ctx -> jsArc ctx x y radius from to
  
  -- | Draw a picture using a certain font. Obviously only affects text.
  font :: String -> Picture () -> Picture ()
  font f (Picture pict) = Picture $ \(Ctx ctx) -> do
    f' <- getProp (Elem ctx) "font"
    setProp (Elem ctx) "font" (toJSString f)
    pict (Ctx ctx)
    setProp (Elem ctx) "font" f'
  
  -- | Draw some text onto the canvas.
  text :: Point -> String -> Picture ()
  text (x, y) str = Picture $ \ctx -> jsDrawText ctx (toJSString str) x y
  