module Haste.Graphics.Canvas (
Bitmap, Canvas, Shape, Picture, Point, Vector, Angle, Rect (..), Color (..),
AnyImageBuffer (..),
ImageBuffer (..), BitmapSource (..),
getCanvasById, getCanvas, createCanvas,
bitmapElem,
render, buffer, toDataURL,
setStrokeColor, setFillColor, color, opacity,
translate, scale, rotate,
stroke, fill, clip,
line, path, rect, circle, arc,
font, text
) where
import Control.Applicative
import Control.Monad.IO.Class
import Haste
import Haste.Concurrent (CIO)
#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 = 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
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 <- 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
bitmapElem :: Bitmap -> Elem
bitmapElem (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
data Canvas = Canvas Ctx Elem
newtype Picture a = Picture {unP :: Ctx -> IO a}
newtype Shape a = Shape {unS :: Ctx -> IO a}
instance Monad Picture where
return x = Picture $ \_ -> return x
Picture m >>= f = Picture $ \ctx -> do
x <- m ctx
unP (f x) ctx
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 => ElemID -> m (Maybe Canvas)
getCanvasById eid = liftIO $ do
e <- elemById 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 (Maybe Canvas)
createCanvas w h = do
buf <- newElem "canvas"
setProp buf "width" (toString w)
setProp buf "height" (toString h)
getCanvas buf
render :: MonadIO m => Canvas -> Picture a -> m a
render (Canvas ctx el) (Picture p) = liftIO $ do
jsResetCanvas el
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
mbuf <- createCanvas w h
case mbuf of
Just buf@(Canvas _ el) -> do
render buf pict
return $ Bitmap el
_ -> do
Bitmap <$> newElem "img"
setStrokeColor :: Color -> Picture ()
setStrokeColor c = Picture $ \(Ctx ctx) -> do
setProp' (Elem ctx) "strokeStyle" (color2JSString c)
setFillColor :: Color -> Picture ()
setFillColor c = Picture $ \(Ctx ctx) -> do
setProp' (Elem ctx) "fillStyle" (color2JSString c)
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'
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
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' <- getProp' (Elem ctx) "font"
setProp' (Elem ctx) "font" (toJSString f)
pict (Ctx ctx)
setProp' (Elem ctx) "font" f'
text :: Point -> String -> Picture ()
text (x, y) str = Picture $ \ctx -> jsDrawText ctx (toJSString str) x y