{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
module Graphics.Blank.Canvas where
import Control.Monad (ap, liftM2)
import Data.Aeson (FromJSON(..),Value(..),encode)
import Data.Aeson.Types (Parser, (.:))
import Data.Text (Text)
import Data.Text.Lazy.Builder
import Data.Text.Lazy.Encoding (decodeUtf8)
import Graphics.Blank.Events
import Graphics.Blank.JavaScript
import Graphics.Blank.Types
import Graphics.Blank.Types.Cursor
import Graphics.Blank.Types.Font
import Prelude.Compat
import TextShow
import TextShow.TH (deriveTextShow)
data DeviceAttributes = DeviceAttributes Int Int Double deriving Int -> DeviceAttributes -> ShowS
[DeviceAttributes] -> ShowS
DeviceAttributes -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DeviceAttributes] -> ShowS
$cshowList :: [DeviceAttributes] -> ShowS
show :: DeviceAttributes -> String
$cshow :: DeviceAttributes -> String
showsPrec :: Int -> DeviceAttributes -> ShowS
$cshowsPrec :: Int -> DeviceAttributes -> ShowS
Show
$(deriveTextShow ''DeviceAttributes)
data TextMetrics = TextMetrics Double deriving Int -> TextMetrics -> ShowS
[TextMetrics] -> ShowS
TextMetrics -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TextMetrics] -> ShowS
$cshowList :: [TextMetrics] -> ShowS
show :: TextMetrics -> String
$cshow :: TextMetrics -> String
showsPrec :: Int -> TextMetrics -> ShowS
$cshowsPrec :: Int -> TextMetrics -> ShowS
Show
$(deriveTextShow ''TextMetrics)
data Canvas :: * -> * where
Method :: Method -> Canvas ()
Command :: Command -> Canvas ()
Function :: TextShow a => Function a -> Canvas a
Query :: TextShow a => Query a -> Canvas a
With :: CanvasContext -> Canvas a -> Canvas a
MyContext :: Canvas CanvasContext
Bind :: Canvas a -> (a -> Canvas b) -> Canvas b
Return :: a -> Canvas a
instance Monad Canvas where
#if !(MIN_VERSION_base(4,11,0))
return = Return
#endif
>>= :: forall a b. Canvas a -> (a -> Canvas b) -> Canvas b
(>>=) = forall a b. Canvas a -> (a -> Canvas b) -> Canvas b
Bind
instance Applicative Canvas where
pure :: forall a. a -> Canvas a
pure = forall a. a -> Canvas a
Return
<*> :: forall a b. Canvas (a -> b) -> Canvas a -> Canvas b
(<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
instance Functor Canvas where
fmap :: forall a b. (a -> b) -> Canvas a -> Canvas b
fmap a -> b
f Canvas a
c = Canvas a
c forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f
instance Semigroup a => Semigroup (Canvas a) where
<> :: Canvas a -> Canvas a -> Canvas a
(<>) = forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 forall a. Semigroup a => a -> a -> a
(<>)
instance Monoid a => Monoid (Canvas a) where
#if !(MIN_VERSION_base(4,11,0))
mappend = liftM2 mappend
#endif
mempty :: Canvas a
mempty = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
data Method
= Arc (Double, Double, Double, Radians, Radians, Bool)
| ArcTo (Double, Double, Double, Double, Double)
| BeginPath
| BezierCurveTo (Double, Double, Double, Double, Double, Double)
| ClearRect (Double, Double, Double, Double)
| Clip
| ClosePath
| forall image . Image image => DrawImage (image,[Double])
| Fill
| FillRect (Double, Double, Double, Double)
| forall style . Style style => FillStyle style
| FillText (Text, Double, Double)
| forall canvasFont . CanvasFont canvasFont => Font canvasFont
| GlobalAlpha Alpha
| GlobalCompositeOperation Text
| LineCap LineEndCap
| LineJoin LineJoinCorner
| LineTo (Double, Double)
| LineWidth Double
| MiterLimit Double
| MoveTo (Double, Double)
| PutImageData (ImageData, [Double])
| QuadraticCurveTo (Double, Double, Double, Double)
| Rect (Double, Double, Double, Double)
| Restore
| Rotate Radians
| Save
| Scale (Interval, Interval)
| SetTransform (Double, Double, Double, Double, Double, Double)
| ShadowBlur Double
| forall canvasColor . CanvasColor canvasColor => ShadowColor canvasColor
| ShadowOffsetX Double
| ShadowOffsetY Double
| Stroke
| StrokeRect (Double, Double, Double, Double)
| forall style . Style style => StrokeStyle style
| StrokeText (Text,Double, Double)
| TextAlign TextAnchorAlignment
| TextBaseline TextBaselineAlignment
| Transform (Double, Double, Double, Double, Double, Double)
| Translate (Double, Double)
data Command
= Trigger Event
| forall color . CanvasColor color => AddColorStop (Interval, color) CanvasGradient
| forall msg . JSArg msg => Log msg
| Eval Text
instance Show Command where
showsPrec :: Int -> Command -> ShowS
showsPrec Int
p = forall a. Show a => Int -> a -> ShowS
showsPrec Int
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> FromTextShow a
FromTextShow
instance TextShow Command where
showb :: Command -> Builder
showb (Trigger Event
e) = Builder
"Trigger(" forall a. Semigroup a => a -> a -> a
<> (Text -> Builder
fromLazyText forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8 forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> ByteString
encode Event
e) forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
')'
showb (AddColorStop (Double
off,color
rep) CanvasGradient
g) = CanvasGradient -> Builder
jsCanvasGradient CanvasGradient
g forall a. Semigroup a => a -> a -> a
<> Builder
".addColorStop("
forall a. Semigroup a => a -> a -> a
<> Double -> Builder
jsDouble Double
off forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
',' forall a. Semigroup a => a -> a -> a
<> forall color. CanvasColor color => color -> Builder
jsCanvasColor color
rep
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
')'
showb (Log msg
msg) = Builder
"console.log(" forall a. Semigroup a => a -> a -> a
<> forall a. JSArg a => a -> Builder
showbJS msg
msg forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
')'
showb (Eval Text
cmd) = Text -> Builder
fromText Text
cmd
with :: CanvasContext -> Canvas a -> Canvas a
with :: forall a. CanvasContext -> Canvas a -> Canvas a
with = forall a. CanvasContext -> Canvas a -> Canvas a
With
myCanvasContext :: Canvas CanvasContext
myCanvasContext :: Canvas CanvasContext
myCanvasContext = Canvas CanvasContext
MyContext
trigger :: Event -> Canvas ()
trigger :: Event -> Canvas ()
trigger = Command -> Canvas ()
Command forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Command
Trigger
addColorStop :: CanvasColor color => (Interval, color) -> CanvasGradient -> Canvas ()
addColorStop :: forall color.
CanvasColor color =>
(Double, color) -> CanvasGradient -> Canvas ()
addColorStop (Double
off,color
rep) = Command -> Canvas ()
Command forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall color.
CanvasColor color =>
(Double, color) -> CanvasGradient -> Command
AddColorStop (Double
off,color
rep)
console_log :: JSArg msg => msg -> Canvas ()
console_log :: forall msg. JSArg msg => msg -> Canvas ()
console_log = Command -> Canvas ()
Command forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall msg. JSArg msg => msg -> Command
Log
eval :: Text -> Canvas ()
eval :: Text -> Canvas ()
eval = Command -> Canvas ()
Command forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Command
Eval
data Function :: * -> * where
CreateLinearGradient :: (Double,Double,Double,Double) -> Function CanvasGradient
CreateRadialGradient :: (Double,Double,Double,Double,Double,Double) -> Function CanvasGradient
CreatePattern :: Image image => (image, RepeatDirection) -> Function CanvasPattern
instance Show (Function a) where
showsPrec :: Int -> Function a -> ShowS
showsPrec Int
p = forall a. Show a => Int -> a -> ShowS
showsPrec Int
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> FromTextShow a
FromTextShow
instance TextShow (Function a) where
showb :: Function a -> Builder
showb (CreateLinearGradient (Double
x0,Double
y0,Double
x1,Double
y1)) = Builder
"createLinearGradient("
forall a. Semigroup a => a -> a -> a
<> Double -> Builder
jsDouble Double
x0 forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
',' forall a. Semigroup a => a -> a -> a
<> Double -> Builder
jsDouble Double
y0 forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
','
forall a. Semigroup a => a -> a -> a
<> Double -> Builder
jsDouble Double
x1 forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
',' forall a. Semigroup a => a -> a -> a
<> Double -> Builder
jsDouble Double
y1 forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
')'
showb (CreateRadialGradient (Double
x0,Double
y0,Double
r0,Double
x1,Double
y1,Double
r1)) = Builder
"createRadialGradient("
forall a. Semigroup a => a -> a -> a
<> Double -> Builder
jsDouble Double
x0 forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
',' forall a. Semigroup a => a -> a -> a
<> Double -> Builder
jsDouble Double
y0 forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
',' forall a. Semigroup a => a -> a -> a
<> Double -> Builder
jsDouble Double
r0 forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
','
forall a. Semigroup a => a -> a -> a
<> Double -> Builder
jsDouble Double
x1 forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
',' forall a. Semigroup a => a -> a -> a
<> Double -> Builder
jsDouble Double
y1 forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
',' forall a. Semigroup a => a -> a -> a
<> Double -> Builder
jsDouble Double
r1 forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
')'
showb (CreatePattern (image
img,RepeatDirection
dir)) = Builder
"createPattern("
forall a. Semigroup a => a -> a -> a
<> forall a. Image a => a -> Builder
jsImage image
img forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
',' forall a. Semigroup a => a -> a -> a
<> RepeatDirection -> Builder
jsRepeatDirection RepeatDirection
dir forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
')'
data Query :: * -> * where
Device :: Query DeviceAttributes
ToDataURL :: Query Text
MeasureText :: Text -> Query TextMetrics
IsPointInPath :: (Double, Double) -> Query Bool
NewImage :: Text -> Query CanvasImage
NewAudio :: Text -> Query CanvasAudio
NewCanvas :: (Int, Int) -> Query CanvasContext
GetImageData :: (Double, Double, Double, Double) -> Query ImageData
Cursor :: CanvasCursor cursor => cursor -> Query ()
Sync :: Query ()
instance Show (Query a) where
showsPrec :: Int -> Query a -> ShowS
showsPrec Int
p = forall a. Show a => Int -> a -> ShowS
showsPrec Int
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> FromTextShow a
FromTextShow
instance TextShow (Query a) where
showb :: Query a -> Builder
showb Query a
Device = Builder
"Device"
showb Query a
ToDataURL = Builder
"ToDataURL"
showb (MeasureText Text
txt) = Builder
"MeasureText(" forall a. Semigroup a => a -> a -> a
<> Text -> Builder
jsText Text
txt forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
')'
showb (IsPointInPath (Double
x,Double
y)) = Builder
"IsPointInPath(" forall a. Semigroup a => a -> a -> a
<> Double -> Builder
jsDouble Double
x forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
','
forall a. Semigroup a => a -> a -> a
<> Double -> Builder
jsDouble Double
y forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
')'
showb (NewImage Text
url') = Builder
"NewImage(" forall a. Semigroup a => a -> a -> a
<> Text -> Builder
jsText Text
url' forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
')'
showb (NewAudio Text
txt) = Builder
"NewAudio(" forall a. Semigroup a => a -> a -> a
<> Text -> Builder
jsText Text
txt forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
')'
showb (NewCanvas (Int
x,Int
y)) = Builder
"NewCanvas(" forall a. Semigroup a => a -> a -> a
<> Int -> Builder
jsInt Int
x forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
','
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
jsInt Int
y forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
')'
showb (GetImageData (Double
sx,Double
sy,Double
sw,Double
sh)) = Builder
"GetImageData(" forall a. Semigroup a => a -> a -> a
<> Double -> Builder
jsDouble Double
sx forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
','
forall a. Semigroup a => a -> a -> a
<> Double -> Builder
jsDouble Double
sy forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
','
forall a. Semigroup a => a -> a -> a
<> Double -> Builder
jsDouble Double
sw forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
','
forall a. Semigroup a => a -> a -> a
<> Double -> Builder
jsDouble Double
sh forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
')'
showb (Cursor cursor
cur) = Builder
"Cursor(" forall a. Semigroup a => a -> a -> a
<> forall a. CanvasCursor a => a -> Builder
jsCanvasCursor cursor
cur forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
')'
showb Query a
Sync = Builder
"Sync"
parseQueryResult :: Query a -> Value -> Parser a
parseQueryResult :: forall a. Query a -> Value -> Parser a
parseQueryResult (Device {}) Value
o = forall a b c d. (a -> b -> c -> d) -> (a, b, c) -> d
uncurry3 Int -> Int -> Double -> DeviceAttributes
DeviceAttributes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => Value -> Parser a
parseJSON Value
o
parseQueryResult (ToDataURL {}) Value
o = forall a. FromJSON a => Value -> Parser a
parseJSON Value
o
parseQueryResult (MeasureText {}) (Object Object
v) = Double -> TextMetrics
TextMetrics forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"width"
parseQueryResult (IsPointInPath {}) Value
o = forall a. FromJSON a => Value -> Parser a
parseJSON Value
o
parseQueryResult (NewImage {}) Value
o = forall a b c d. (a -> b -> c -> d) -> (a, b, c) -> d
uncurry3 Int -> Int -> Int -> CanvasImage
CanvasImage forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => Value -> Parser a
parseJSON Value
o
parseQueryResult (NewAudio {}) Value
o = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> Double -> CanvasAudio
CanvasAudio forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => Value -> Parser a
parseJSON Value
o
parseQueryResult (NewCanvas {}) Value
o = forall a b c d. (a -> b -> c -> d) -> (a, b, c) -> d
uncurry3 Int -> Int -> Int -> CanvasContext
CanvasContext forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => Value -> Parser a
parseJSON Value
o
parseQueryResult (GetImageData {}) (Object Object
o) = Int -> Int -> Vector Word8 -> ImageData
ImageData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"width")
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"height")
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"data")
parseQueryResult (Cursor {}) Value
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
parseQueryResult (Sync {}) Value
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
parseQueryResult Query a
_ Value
_ = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"no parse in blank-canvas server (internal error)"
uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
uncurry3 :: forall a b c d. (a -> b -> c -> d) -> (a, b, c) -> d
uncurry3 a -> b -> c -> d
f (a
a,b
b,c
c) = a -> b -> c -> d
f a
a b
b c
c
device :: Canvas DeviceAttributes
device :: Canvas DeviceAttributes
device = forall a. TextShow a => Query a -> Canvas a
Query Query DeviceAttributes
Device
toDataURL :: () -> Canvas Text
toDataURL :: () -> Canvas Text
toDataURL () = forall a. TextShow a => Query a -> Canvas a
Query Query Text
ToDataURL
measureText :: Text -> Canvas TextMetrics
measureText :: Text -> Canvas TextMetrics
measureText = forall a. TextShow a => Query a -> Canvas a
Query forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Query TextMetrics
MeasureText
isPointInPath :: (Double, Double) -> Canvas Bool
isPointInPath :: (Double, Double) -> Canvas Bool
isPointInPath = forall a. TextShow a => Query a -> Canvas a
Query forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double, Double) -> Query Bool
IsPointInPath
newImage :: Text -> Canvas CanvasImage
newImage :: Text -> Canvas CanvasImage
newImage = forall a. TextShow a => Query a -> Canvas a
Query forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Query CanvasImage
NewImage
newAudio :: Text -> Canvas CanvasAudio
newAudio :: Text -> Canvas CanvasAudio
newAudio = forall a. TextShow a => Query a -> Canvas a
Query forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Query CanvasAudio
NewAudio
createLinearGradient :: (Double, Double, Double, Double) -> Canvas CanvasGradient
createLinearGradient :: (Double, Double, Double, Double) -> Canvas CanvasGradient
createLinearGradient = forall a. TextShow a => Function a -> Canvas a
Function forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double, Double, Double, Double) -> Function CanvasGradient
CreateLinearGradient
createRadialGradient :: (Double, Double, Double, Double, Double, Double) -> Canvas CanvasGradient
createRadialGradient :: (Double, Double, Double, Double, Double, Double)
-> Canvas CanvasGradient
createRadialGradient = forall a. TextShow a => Function a -> Canvas a
Function forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double, Double, Double, Double, Double, Double)
-> Function CanvasGradient
CreateRadialGradient
createPattern :: (CanvasImage, RepeatDirection) -> Canvas CanvasPattern
createPattern :: (CanvasImage, RepeatDirection) -> Canvas CanvasPattern
createPattern = forall a. TextShow a => Function a -> Canvas a
Function forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall cursor.
Image cursor =>
(cursor, RepeatDirection) -> Function CanvasPattern
CreatePattern
newCanvas :: (Int, Int) -> Canvas CanvasContext
newCanvas :: (Int, Int) -> Canvas CanvasContext
newCanvas = forall a. TextShow a => Query a -> Canvas a
Query forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Int) -> Query CanvasContext
NewCanvas
getImageData :: (Double, Double, Double, Double) -> Canvas ImageData
getImageData :: (Double, Double, Double, Double) -> Canvas ImageData
getImageData = forall a. TextShow a => Query a -> Canvas a
Query forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double, Double, Double, Double) -> Query ImageData
GetImageData
cursor :: CanvasCursor cursor => cursor -> Canvas ()
cursor :: forall cursor. CanvasCursor cursor => cursor -> Canvas ()
cursor = forall a. TextShow a => Query a -> Canvas a
Query forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall cursor. CanvasCursor cursor => cursor -> Query ()
Cursor
sync :: Canvas ()
sync :: Canvas ()
sync = forall a. TextShow a => Query a -> Canvas a
Query Query ()
Sync