module Haste.Graphics.Canvas (
Bitmap, Canvas, Shape, Picture, Point, Vector, Angle, Rect (..), Color (..),
Ctx, AnyImageBuffer (..),
ImageBuffer (..), BitmapSource (..),
getCanvasById, getCanvas, createCanvas,
render, renderOnTop, buffer, toDataURL,
setStrokeColor, setFillColor, color, opacity, lineWidth,
translate, scale, rotate,
stroke, fill, clip,
line, path, rect, circle, arc,
font, text,
withContext
) where
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
#endif
import Control.Monad.IO.Class
import Data.Maybe (fromJust)
import Haste
import qualified Haste.DOM.JSString as J
import Haste.Concurrent (CIO)
import Haste.Foreign (ToAny (..), FromAny (..))
#ifdef __HASTE__
import Haste.Prim (JSString (..), JSAny (..))
#endif
#ifdef __HASTE__
foreign import ccall jsHasCtx2D :: Elem -> IO Bool
foreign import ccall jsGetCtx2D :: Elem -> IO Ctx
foreign import ccall jsBeginPath :: Ctx -> IO ()
foreign import ccall jsMoveTo :: Ctx -> Double -> Double -> IO ()
foreign import ccall jsLineTo :: Ctx -> Double -> Double -> IO ()
foreign import ccall jsStroke :: Ctx -> IO ()
foreign import ccall jsFill :: Ctx -> IO ()
foreign import ccall jsRotate :: Ctx -> Double -> IO ()
foreign import ccall jsTranslate :: Ctx -> Double -> Double -> IO ()
foreign import ccall jsScale :: Ctx -> Double -> Double -> IO ()
foreign import ccall jsPushState :: Ctx -> IO ()
foreign import ccall jsPopState :: Ctx -> IO ()
foreign import ccall jsResetCanvas :: Elem -> IO ()
foreign import ccall jsDrawImage :: Ctx -> Elem -> Double -> Double -> IO ()
foreign import ccall jsDrawImageClipped :: Ctx -> Elem
-> Double -> Double
-> Double -> Double -> Double -> Double
-> IO ()
foreign import ccall jsDrawText :: Ctx -> JSString -> Double -> Double -> IO ()
foreign import ccall jsClip :: Ctx -> IO ()
foreign import ccall jsArc :: Ctx
-> Double -> Double
-> Double
-> Double -> Double
-> IO ()
foreign import ccall jsCanvasToDataURL :: Elem -> IO JSString
#else
jsHasCtx2D :: Elem -> IO Bool
jsGetCtx2D :: Elem -> IO Ctx
jsBeginPath :: Ctx -> IO ()
jsMoveTo :: Ctx -> Double -> Double -> IO ()
jsLineTo :: Ctx -> Double -> Double -> IO ()
jsStroke :: Ctx -> IO ()
jsFill :: Ctx -> IO ()
jsRotate :: Ctx -> Double -> IO ()
jsTranslate :: Ctx -> Double -> Double -> IO ()
jsScale :: Ctx -> Double -> Double -> IO ()
jsPushState :: Ctx -> IO ()
jsPopState :: Ctx -> IO ()
jsResetCanvas :: Elem -> IO ()
jsDrawImage :: Ctx -> Elem -> Double -> Double -> IO ()
jsDrawImageClipped :: Ctx -> Elem -> Double -> Double
-> Double -> Double -> Double -> Double
-> IO ()
jsDrawText :: Ctx -> JSString -> Double -> Double -> IO ()
jsClip :: Ctx -> IO ()
jsArc :: Ctx -> Double -> Double -> Double -> Double -> Double -> IO ()
jsCanvasToDataURL :: Elem -> IO JSString
jsHasCtx2D = error "Tried to use Canvas in native code!"
jsGetCtx2D = error "Tried to use Canvas in native code!"
jsBeginPath = error "Tried to use Canvas in native code!"
jsMoveTo = error "Tried to use Canvas in native code!"
jsLineTo = error "Tried to use Canvas in native code!"
jsStroke = error "Tried to use Canvas in native code!"
jsFill = error "Tried to use Canvas in native code!"
jsRotate = error "Tried to use Canvas in native code!"
jsTranslate = error "Tried to use Canvas in native code!"
jsScale = error "Tried to use Canvas in native code!"
jsPushState = error "Tried to use Canvas in native code!"
jsPopState = error "Tried to use Canvas in native code!"
jsResetCanvas = error "Tried to use Canvas in native code!"
jsDrawImage = error "Tried to use Canvas in native code!"
jsDrawImageClipped = error "Tried to use Canvas in native code!"
jsDrawText = error "Tried to use Canvas in native code!"
jsClip = error "Tried to use Canvas in native code!"
jsArc = error "Tried to use Canvas in native code!"
jsCanvasToDataURL = error "Tried to use Canvas in native code!"
#endif
newtype Bitmap = Bitmap Elem
deriving (ToAny, FromAny)
class ImageBuffer a where
draw :: a -> Point -> Picture ()
drawClipped :: a -> Point -> 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
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
class BitmapSource src where
loadBitmap :: MonadIO m => src -> m Bitmap
instance BitmapSource URL where
loadBitmap url = liftIO $ do
img <- J.newElem "img"
J.setProp img "src" (toJSString 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
instance IsElem Canvas where
elemOf (Canvas _ctx e) = e
instance IsElem Bitmap where
elemOf (Bitmap e) = e
type Point = (Double, Double)
type Vector = (Double, Double)
type Angle = Double
data Rect = Rect {rect_x :: !Double,
rect_y :: !Double,
rect_w :: !Double,
rect_h :: !Double}
data Color = RGB !Int !Int !Int
| RGBA !Int !Int !Int !Double
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, ")"]
newtype Ctx = Ctx JSAny
deriving (ToAny, FromAny)
data Canvas = Canvas !Ctx !Elem
instance FromAny Canvas where
fromAny c = do
mcan <- fromAny c >>= getCanvas
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
newtype Picture a = Picture {unP :: Ctx -> IO a}
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
getCanvasById :: MonadIO m => String -> m (Maybe Canvas)
getCanvasById eid = liftIO $ do
e <- J.elemById (toJSString eid)
maybe (return Nothing) getCanvas e
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
createCanvas :: Int -> Int -> IO Canvas
createCanvas w h = do
buf <- J.newElem "canvas"
J.setProp buf "width" (toJSString w)
J.setProp buf "height" (toJSString h)
fromJust <$> getCanvas buf
render :: MonadIO m => Canvas -> Picture a -> m a
render (Canvas ctx el) (Picture p) = liftIO $ do
jsResetCanvas el
p ctx
renderOnTop :: MonadIO m => Canvas -> Picture a -> m a
renderOnTop (Canvas ctx _) (Picture p) = liftIO $ p ctx
toDataURL :: MonadIO m => Canvas -> m URL
toDataURL (Canvas _ el) = liftIO $ do
fromJSStr <$> jsCanvasToDataURL el
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
withContext :: (Ctx -> IO a) -> Picture a
withContext f = Picture $ \ctx -> f ctx
setStrokeColor :: Color -> Picture ()
setStrokeColor c = Picture $ \(Ctx ctx) -> do
J.setProp (Elem ctx) "strokeStyle" (color2JSString c)
setFillColor :: Color -> Picture ()
setFillColor c = Picture $ \(Ctx ctx) -> do
J.setProp (Elem ctx) "fillStyle" (color2JSString c)
opacity :: Double -> Picture () -> Picture ()
opacity alpha (Picture pict) = Picture $ \(Ctx ctx) -> do
alpha' <- J.getProp (Elem ctx) "globalAlpha"
J.setProp (Elem ctx) "globalAlpha" (toJSString alpha)
pict (Ctx ctx)
J.setProp (Elem ctx) "globalAlpha" alpha'
color :: Color -> Picture () -> Picture ()
color c (Picture pict) = Picture $ \(Ctx ctx) -> do
fc <- J.getProp (Elem ctx) "fillStyle"
sc <- J.getProp (Elem ctx) "strokeStyle"
J.setProp (Elem ctx) "fillStyle" c'
J.setProp (Elem ctx) "strokeStyle" c'
pict (Ctx ctx)
J.setProp (Elem ctx) "fillStyle" fc
J.setProp (Elem ctx) "strokeStyle" sc
where
c' = color2JSString c
lineWidth :: Double -> Picture () -> Picture ()
lineWidth w (Picture pict) = Picture $ \(Ctx ctx) -> do
lw <- J.getProp (Elem ctx) "lineWidth"
J.setProp (Elem ctx) "lineWidth" (toJSString w)
pict (Ctx ctx)
J.setProp (Elem ctx) "lineWidth" lw
translate :: Vector -> Picture () -> Picture ()
translate (x, y) (Picture pict) = Picture $ \ctx -> do
jsPushState ctx
jsTranslate ctx x y
pict ctx
jsPopState ctx
rotate :: Double -> Picture () -> Picture ()
rotate rad (Picture pict) = Picture $ \ctx -> do
jsPushState ctx
jsRotate ctx rad
pict ctx
jsPopState ctx
scale :: Vector -> Picture () -> Picture ()
scale (x, y) (Picture pict) = Picture $ \ctx -> do
jsPushState ctx
jsScale ctx x y
pict ctx
jsPopState ctx
fill :: Shape () -> Picture ()
fill (Shape shape) = Picture $ \ctx -> do
jsBeginPath ctx
shape ctx
jsFill ctx
stroke :: Shape () -> Picture ()
stroke (Shape shape) = Picture $ \ctx -> do
jsBeginPath ctx
shape ctx
jsStroke ctx
clip :: Shape () -> Picture () -> Picture ()
clip (Shape shape) (Picture pict) = Picture $ \ctx -> do
jsPushState ctx
jsBeginPath ctx
shape ctx
jsClip ctx
pict ctx
jsPopState ctx
path :: [Point] -> Shape ()
path ((x1, y1):ps) = Shape $ \ctx -> do
jsMoveTo ctx x1 y1
mapM_ (uncurry $ jsLineTo ctx) ps
path _ =
return ()
line :: Point -> Point -> Shape ()
line p1 p2 = path [p1, p2]
rect :: Point -> Point -> Shape ()
rect (x1, y1) (x2, y2) = path [(x1, y1), (x2, y1), (x2, y2), (x1, y2), (x1, y1)]
circle :: Point -> Double -> Shape ()
circle (x, y) radius = Shape $ \ctx -> do
jsMoveTo ctx (x+radius) y
jsArc ctx x y radius (0 :: Double) twoPi
twoPi :: Double
twoPi = 2*pi
arc :: Point -> Double -> Angle -> Angle -> Shape ()
arc (x, y) radius from to = Shape $ \ctx -> jsArc ctx x y radius from to
font :: String -> Picture () -> Picture ()
font f (Picture pict) = Picture $ \(Ctx ctx) -> do
f' <- J.getProp (Elem ctx) "font"
J.setProp (Elem ctx) "font" (toJSString f)
pict (Ctx ctx)
J.setProp (Elem ctx) "font" f'
text :: Point -> String -> Picture ()
text (x, y) str = Picture $ \ctx -> jsDrawText ctx (toJSString str) x y