{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
module Diagrams.Backend.Html5
( Html5(..)
, B
, Options(..)
, renderHtml5
, size
, canvasId
, standalone
) where
import Control.Monad (when)
import qualified Control.Monad.StateStack as SS
import Control.Monad.Trans (lift)
import Data.Default.Class
import qualified Data.Foldable as F
import Data.Maybe (catMaybes, isJust, fromJust, fromMaybe)
import Data.NumInstances ()
import qualified Data.Text as T
import Data.Text.Lazy.Builder (Builder, toLazyText)
import qualified Data.Text.Lazy.IO as L
import Data.Tree (Tree(Node))
import Data.Typeable (Typeable)
import Diagrams.Attributes
import Diagrams.Prelude hiding (fillTexture, moveTo, stroke, size)
import Diagrams.TwoD.Adjust (adjustDia2D)
import Diagrams.TwoD.Attributes (splitTextureFills)
import Diagrams.TwoD.Path (Clip (Clip))
import Diagrams.TwoD.Text
import Diagrams.Core.Compile
import Diagrams.Core.Transform (matrixHomRep)
import Diagrams.Core.Types (Annotation (..))
import qualified Graphics.Static as H
data Html5 = Html5
deriving (Html5 -> Html5 -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Html5 -> Html5 -> Bool
$c/= :: Html5 -> Html5 -> Bool
== :: Html5 -> Html5 -> Bool
$c== :: Html5 -> Html5 -> Bool
Eq, Eq Html5
Html5 -> Html5 -> Bool
Html5 -> Html5 -> Ordering
Html5 -> Html5 -> Html5
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Html5 -> Html5 -> Html5
$cmin :: Html5 -> Html5 -> Html5
max :: Html5 -> Html5 -> Html5
$cmax :: Html5 -> Html5 -> Html5
>= :: Html5 -> Html5 -> Bool
$c>= :: Html5 -> Html5 -> Bool
> :: Html5 -> Html5 -> Bool
$c> :: Html5 -> Html5 -> Bool
<= :: Html5 -> Html5 -> Bool
$c<= :: Html5 -> Html5 -> Bool
< :: Html5 -> Html5 -> Bool
$c< :: Html5 -> Html5 -> Bool
compare :: Html5 -> Html5 -> Ordering
$ccompare :: Html5 -> Html5 -> Ordering
Ord, ReadPrec [Html5]
ReadPrec Html5
Int -> ReadS Html5
ReadS [Html5]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Html5]
$creadListPrec :: ReadPrec [Html5]
readPrec :: ReadPrec Html5
$creadPrec :: ReadPrec Html5
readList :: ReadS [Html5]
$creadList :: ReadS [Html5]
readsPrec :: Int -> ReadS Html5
$creadsPrec :: Int -> ReadS Html5
Read, Int -> Html5 -> ShowS
[Html5] -> ShowS
Html5 -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Html5] -> ShowS
$cshowList :: [Html5] -> ShowS
show :: Html5 -> String
$cshow :: Html5 -> String
showsPrec :: Int -> Html5 -> ShowS
$cshowsPrec :: Int -> Html5 -> ShowS
Show, Typeable)
type B = Html5
type instance V Html5 = V2
type instance N Html5 = Double
data Html5State = Html5State { Html5State -> Style V2 Double
_accumStyle :: Style V2 Double
, Html5State -> (Double, Double)
_csPos :: (Double, Double) }
makeLenses ''Html5State
instance Default Html5State where
def :: Html5State
def = Html5State { _accumStyle :: Style V2 Double
_accumStyle = forall a. Monoid a => a
mempty
, _csPos :: (Double, Double)
_csPos = (Double
0,Double
0) }
type RenderM a = SS.StateStackT Html5State H.CanvasFree a
liftC :: H.CanvasFree a -> RenderM a
liftC :: forall a. CanvasFree a -> RenderM a
liftC = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
runRenderM :: RenderM a -> H.CanvasFree a
runRenderM :: forall a. RenderM a -> CanvasFree a
runRenderM = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) s a. Monad m => StateStackT s m a -> s -> m a
SS.evalStateStackT forall a. Default a => a
def
instance Semigroup (Render Html5 V2 Double) where
C RenderM ()
c1 <> :: Render Html5 V2 Double
-> Render Html5 V2 Double -> Render Html5 V2 Double
<> C RenderM ()
c2 = RenderM () -> Render Html5 V2 Double
C (RenderM ()
c1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RenderM ()
c2)
instance Monoid (Render Html5 V2 Double) where
mempty :: Render Html5 V2 Double
mempty = RenderM () -> Render Html5 V2 Double
C forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()
instance Backend Html5 V2 Double where
data Render Html5 V2 Double = C (RenderM ())
type Result Html5 V2 Double = Builder
data Options Html5 V2 Double = Html5Options
{ Options Html5 V2 Double -> SizeSpec V2 Double
_html5Size :: SizeSpec V2 Double
, Options Html5 V2 Double -> Bool
_standalone :: Bool
, Options Html5 V2 Double -> String
_canvasId :: String
}
renderRTree :: Html5 -> Options Html5 V2 Double -> RTree Html5 V2 Double Annotation
-> Result Html5 V2 Double
renderRTree :: Html5
-> Options Html5 V2 Double
-> RTree Html5 V2 Double Annotation
-> Result Html5 V2 Double
renderRTree Html5
_ Options Html5 V2 Double
opts RTree Html5 V2 Double Annotation
rt = Int -> Int -> CanvasFree () -> Builder
buildF (forall a b. (RealFrac a, Integral b) => a -> b
round Double
w) (forall a b. (RealFrac a, Integral b) => a -> b
round Double
h)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. RenderM a -> CanvasFree a
runRenderM
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Render Html5 V2 Double -> RenderM ()
runC
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RTree Html5 V2 Double Annotation -> Render Html5 V2 Double
toRender forall a b. (a -> b) -> a -> b
$ RTree Html5 V2 Double Annotation
rt
where
V2 Double
w Double
h = forall (v :: * -> *) n.
(Foldable v, Functor v, Num n, Ord n) =>
n -> SizeSpec v n -> v n
specToSize Double
100 (Options Html5 V2 Double
optsforall s a. s -> Getting a s a -> a
^.Lens' (Options Html5 V2 Double) (SizeSpec V2 Double)
size)
buildF :: Int -> Int -> CanvasFree () -> Builder
buildF | Options Html5 V2 Double
optsforall s a. s -> Getting a s a -> a
^.Lens' (Options Html5 V2 Double) Bool
standalone = Int -> Int -> CanvasFree () -> Builder
H.buildDoc
| Bool
otherwise = \Int
wd Int
ht -> Int -> Int -> Text -> CanvasFree () -> Builder
H.buildScript' Int
wd Int
ht (Options Html5 V2 Double
optsforall s a. s -> Getting a s a -> a
^.Lens' (Options Html5 V2 Double) String
canvasIdforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to String -> Text
T.pack)
adjustDia :: forall m.
(Additive V2, Monoid' m, Num Double) =>
Html5
-> Options Html5 V2 Double
-> QDiagram Html5 V2 Double m
-> (Options Html5 V2 Double, Transformation V2 Double,
QDiagram Html5 V2 Double m)
adjustDia Html5
c Options Html5 V2 Double
opts QDiagram Html5 V2 Double m
d = forall n m b.
(TypeableFloat n, Monoid' m) =>
Lens' (Options b V2 n) (SizeSpec V2 n)
-> b
-> Options b V2 n
-> QDiagram b V2 n m
-> (Options b V2 n, Transformation V2 n, QDiagram b V2 n m)
adjustDia2D Lens' (Options Html5 V2 Double) (SizeSpec V2 Double)
size Html5
c Options Html5 V2 Double
opts (QDiagram Html5 V2 Double m
d forall a b. a -> (a -> b) -> b
# forall (v :: * -> *) n t.
(InSpace v n t, R2 v, Transformable t) =>
t -> t
reflectY)
runC :: Render Html5 V2 Double -> RenderM ()
runC :: Render Html5 V2 Double -> RenderM ()
runC (C RenderM ()
r) = RenderM ()
r
toRender :: RTree Html5 V2 Double Annotation -> Render Html5 V2 Double
toRender :: RTree Html5 V2 Double Annotation -> Render Html5 V2 Double
toRender = forall {b} {a}.
Renderable (Prim b V2 Double) Html5 =>
Tree (RNode b V2 Double a) -> Render Html5 V2 Double
fromRTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> [Tree a] -> Tree a
Node (forall b (v :: * -> *) n a. Style v n -> RNode b v n a
RStyle (forall a. Monoid a => a
mempty forall a b. a -> (a -> b) -> b
# forall n a c.
(InSpace V2 n a, Color c, Typeable n, Floating n, HasStyle a) =>
c -> a -> a
recommendFillColor forall a. Num a => AlphaColour a
transparent))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b (v :: * -> *) n a.
Typeable n =>
RTree b v n a -> RTree b v n a
splitTextureFills
where
fromRTree :: Tree (RNode b V2 Double a) -> Render Html5 V2 Double
fromRTree (Node (RPrim Prim b V2 Double
p) [Tree (RNode b V2 Double a)]
_) = forall t b. Renderable t b => b -> t -> Render b (V t) (N t)
render Html5
Html5 Prim b V2 Double
p
fromRTree (Node (RStyle Style V2 Double
sty) [Tree (RNode b V2 Double a)]
rs) = RenderM () -> Render Html5 V2 Double
C forall a b. (a -> b) -> a -> b
$ do
RenderM ()
save
forall (v :: * -> *). Style v Double -> RenderM ()
html5Style Style V2 Double
sty
Lens' Html5State (Style V2 Double)
accumStyle forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (forall a. Semigroup a => a -> a -> a
<> Style V2 Double
sty)
Render Html5 V2 Double -> RenderM ()
runC forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.foldMap Tree (RNode b V2 Double a) -> Render Html5 V2 Double
fromRTree [Tree (RNode b V2 Double a)]
rs
RenderM ()
restore
fromRTree (Node RNode b V2 Double a
_ [Tree (RNode b V2 Double a)]
rs) = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.foldMap Tree (RNode b V2 Double a) -> Render Html5 V2 Double
fromRTree [Tree (RNode b V2 Double a)]
rs
size :: Lens' (Options Html5 V2 Double) (SizeSpec V2 Double)
size :: Lens' (Options Html5 V2 Double) (SizeSpec V2 Double)
size = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Options Html5 V2 Double -> SizeSpec V2 Double
_html5Size forall a b. (a -> b) -> a -> b
$ \Options Html5 V2 Double
o SizeSpec V2 Double
i -> Options Html5 V2 Double
o { _html5Size :: SizeSpec V2 Double
_html5Size = SizeSpec V2 Double
i }
canvasId :: Lens' (Options Html5 V2 Double) String
canvasId :: Lens' (Options Html5 V2 Double) String
canvasId = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Options Html5 V2 Double -> String
_canvasId forall a b. (a -> b) -> a -> b
$ \Options Html5 V2 Double
o String
i -> Options Html5 V2 Double
o { _canvasId :: String
_canvasId = String
i }
standalone :: Lens' (Options Html5 V2 Double) Bool
standalone :: Lens' (Options Html5 V2 Double) Bool
standalone = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Options Html5 V2 Double -> Bool
_standalone forall a b. (a -> b) -> a -> b
$ \Options Html5 V2 Double
o Bool
i -> Options Html5 V2 Double
o { _standalone :: Bool
_standalone = Bool
i }
move :: Double -> Double -> RenderM ()
move :: Double -> Double -> RenderM ()
move Double
x Double
y = do Lens' Html5State (Double, Double)
csPos forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= (Double
x, Double
y)
save :: RenderM ()
save :: RenderM ()
save = forall s (m :: * -> *). MonadStateStack s m => m ()
SS.save forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. CanvasFree a -> RenderM a
liftC CanvasFree ()
H.save
restore :: RenderM ()
restore :: RenderM ()
restore = forall a. CanvasFree a -> RenderM a
liftC CanvasFree ()
H.restore forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall s (m :: * -> *). MonadStateStack s m => m ()
SS.restore
newPath :: RenderM ()
newPath :: RenderM ()
newPath = forall a. CanvasFree a -> RenderM a
liftC forall a b. (a -> b) -> a -> b
$ CanvasFree ()
H.beginPath
closePath :: RenderM ()
closePath :: RenderM ()
closePath = forall a. CanvasFree a -> RenderM a
liftC forall a b. (a -> b) -> a -> b
$ CanvasFree ()
H.closePath
moveTo :: Double -> Double -> RenderM ()
moveTo :: Double -> Double -> RenderM ()
moveTo Double
x Double
y = do
forall a. CanvasFree a -> RenderM a
liftC forall a b. (a -> b) -> a -> b
$ Double -> Double -> CanvasFree ()
H.moveTo Double
x Double
y
Double -> Double -> RenderM ()
move Double
x Double
y
relLineTo :: Double -> Double -> RenderM ()
relLineTo :: Double -> Double -> RenderM ()
relLineTo Double
x Double
y = do
(Double
p, Double
q) <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' Html5State (Double, Double)
csPos
let x' :: Double
x' = Double
p forall a. Num a => a -> a -> a
+ Double
x
y' :: Double
y' = Double
q forall a. Num a => a -> a -> a
+ Double
y
forall a. CanvasFree a -> RenderM a
liftC forall a b. (a -> b) -> a -> b
$ Double -> Double -> CanvasFree ()
H.lineTo Double
x' Double
y'
Double -> Double -> RenderM ()
move Double
x' Double
y'
relCurveTo :: Double -> Double -> Double -> Double -> Double -> Double -> RenderM ()
relCurveTo :: Double
-> Double -> Double -> Double -> Double -> Double -> RenderM ()
relCurveTo Double
ax Double
ay Double
bx Double
by Double
cx Double
cy = do
(Double, Double)
p <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' Html5State (Double, Double)
csPos
let [(Double
ax',Double
ay'),(Double
bx',Double
by'),(Double
cx',Double
cy')] = forall a b. (a -> b) -> [a] -> [b]
map ((Double, Double)
p forall a. Num a => a -> a -> a
+) [(Double
ax,Double
ay),(Double
bx,Double
by),(Double
cx,Double
cy)]
forall a. CanvasFree a -> RenderM a
liftC forall a b. (a -> b) -> a -> b
$ Double
-> Double -> Double -> Double -> Double -> Double -> CanvasFree ()
H.bezierCurveTo Double
ax' Double
ay' Double
bx' Double
by' Double
cx' Double
cy'
Double -> Double -> RenderM ()
move Double
cx' Double
cy'
getStyleAttrib :: AttributeClass a => (a -> b) -> RenderM (Maybe b)
getStyleAttrib :: forall a b. AttributeClass a => (a -> b) -> RenderM (Maybe b)
getStyleAttrib a -> b
f = (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (v :: * -> *) n. AttributeClass a => Style v n -> Maybe a
getAttr) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' Html5State (Style V2 Double)
accumStyle
stroke :: RenderM ()
stroke :: RenderM ()
stroke = do
Double
w <- forall a. a -> Maybe a -> a
fromMaybe Double
0.5 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. AttributeClass a => (a -> b) -> RenderM (Maybe b)
getStyleAttrib forall n. LineWidth n -> n
getLineWidth
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Double
w forall a. Ord a => a -> a -> Bool
> (Double
0 :: Double)) (forall a. CanvasFree a -> RenderM a
liftC CanvasFree ()
H.stroke)
fill :: RenderM ()
fill :: RenderM ()
fill = forall a. CanvasFree a -> RenderM a
liftC forall a b. (a -> b) -> a -> b
$ CanvasFree ()
H.fill
clip :: RenderM ()
clip :: RenderM ()
clip = forall a. CanvasFree a -> RenderM a
liftC forall a b. (a -> b) -> a -> b
$ CanvasFree ()
H.clip
byteRange :: Double -> Int
byteRange :: Double -> Int
byteRange Double
d = forall a b. (RealFrac a, Integral b) => a -> b
floor (Double
d forall a. Num a => a -> a -> a
* Double
255)
texture :: (H.Style -> H.CanvasFree ()) -> Texture Double -> Double -> RenderM ()
texture :: (Style -> CanvasFree ()) -> Texture Double -> Double -> RenderM ()
texture Style -> CanvasFree ()
styleFn (SC (SomeColor c
c)) Double
o = forall a. CanvasFree a -> RenderM a
liftC forall b c a. (b -> c) -> (a -> b) -> a -> c
. Style -> CanvasFree ()
styleFn forall a b. (a -> b) -> a -> b
$ Style
s
where s :: Style
s = Color -> Style
H.ColorStyle forall a b. (a -> b) -> a -> b
$ forall c. Color c => c -> Double -> Color
colorJS c
c Double
o
texture Style -> CanvasFree ()
styleFn (LG LGradient Double
g) Double
_ = forall a. CanvasFree a -> RenderM a
liftC forall a b. (a -> b) -> a -> b
$ do
Style
grd <- Double -> Double -> Double -> Double -> CanvasFree Style
H.createLinearGradient Double
x0 Double
y0 Double
x1 Double
y1
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Style -> (Double, Color) -> CanvasFree ()
addStop Style
grd) [(Double, Color)]
stops
Style -> CanvasFree ()
styleFn Style
grd
where
(Double
x0, Double
y0) = forall n. P2 n -> (n, n)
unp2 forall a b. (a -> b) -> a -> b
$ forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform (LGradient Double
gforall s a. s -> Getting a s a -> a
^.forall n. Lens' (LGradient n) (Transformation V2 n)
lGradTrans) (LGradient Double
gforall s a. s -> Getting a s a -> a
^.forall n. Lens' (LGradient n) (Point V2 n)
lGradStart)
(Double
x1, Double
y1) = forall n. P2 n -> (n, n)
unp2 forall a b. (a -> b) -> a -> b
$ forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform (LGradient Double
gforall s a. s -> Getting a s a -> a
^.forall n. Lens' (LGradient n) (Transformation V2 n)
lGradTrans) (LGradient Double
gforall s a. s -> Getting a s a -> a
^.forall n. Lens' (LGradient n) (Point V2 n)
lGradEnd)
stops :: [(Double, Color)]
stops = forall a b. (a -> b) -> [a] -> [b]
map (\GradientStop Double
s -> ( GradientStop Double
sforall s a. s -> Getting a s a -> a
^.forall n. Lens' (GradientStop n) n
stopFraction , forall c. Color c => c -> Double -> Color
colorJS (GradientStop Double
sforall s a. s -> Getting a s a -> a
^.forall n. Lens' (GradientStop n) SomeColor
stopColor) Double
1)) (LGradient Double
gforall s a. s -> Getting a s a -> a
^.forall n. Lens' (LGradient n) [GradientStop n]
lGradStops)
texture Style -> CanvasFree ()
styleFn (RG RGradient Double
g) Double
_ = forall a. CanvasFree a -> RenderM a
liftC forall a b. (a -> b) -> a -> b
$ do
Style
grd <- Double
-> Double
-> Double
-> Double
-> Double
-> Double
-> CanvasFree Style
H.createRadialGradient Double
x0 Double
y0 Double
r0 Double
x1 Double
y1 Double
r1
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Style -> (Double, Color) -> CanvasFree ()
addStop Style
grd) [(Double, Color)]
stops
Style -> CanvasFree ()
styleFn Style
grd
where
(Double
r0, Double
r1) = (Double
s forall a. Num a => a -> a -> a
* RGradient Double
gforall s a. s -> Getting a s a -> a
^.forall n. Lens' (RGradient n) n
rGradRadius0, Double
s forall a. Num a => a -> a -> a
* RGradient Double
gforall s a. s -> Getting a s a -> a
^.forall n. Lens' (RGradient n) n
rGradRadius1)
(Double
x0, Double
y0) = forall n. P2 n -> (n, n)
unp2 forall a b. (a -> b) -> a -> b
$ forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform (RGradient Double
gforall s a. s -> Getting a s a -> a
^.forall n. Lens' (RGradient n) (Transformation V2 n)
rGradTrans) (RGradient Double
gforall s a. s -> Getting a s a -> a
^.forall n. Lens' (RGradient n) (Point V2 n)
rGradCenter0)
(Double
x1, Double
y1) = forall n. P2 n -> (n, n)
unp2 forall a b. (a -> b) -> a -> b
$ forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform (RGradient Double
gforall s a. s -> Getting a s a -> a
^.forall n. Lens' (RGradient n) (Transformation V2 n)
rGradTrans) (RGradient Double
gforall s a. s -> Getting a s a -> a
^.forall n. Lens' (RGradient n) (Point V2 n)
rGradCenter1)
stops :: [(Double, Color)]
stops = forall a b. (a -> b) -> [a] -> [b]
map (\GradientStop Double
st -> ( GradientStop Double
stforall s a. s -> Getting a s a -> a
^.forall n. Lens' (GradientStop n) n
stopFraction , forall c. Color c => c -> Double -> Color
colorJS (GradientStop Double
stforall s a. s -> Getting a s a -> a
^.forall n. Lens' (GradientStop n) SomeColor
stopColor) Double
1)) (RGradient Double
gforall s a. s -> Getting a s a -> a
^.forall n. Lens' (RGradient n) [GradientStop n]
rGradStops)
s :: Double
s = forall (v :: * -> *) n.
(Additive v, Traversable v, Floating n) =>
Transformation v n -> n
avgScale forall a b. (a -> b) -> a -> b
$ RGradient Double
gforall s a. s -> Getting a s a -> a
^.forall n. Lens' (RGradient n) (Transformation V2 n)
rGradTrans
addStop :: H.Style -> (Double, H.Color) -> H.CanvasFree ()
addStop :: Style -> (Double, Color) -> CanvasFree ()
addStop Style
g (Double
f, Color
c) = Double -> Color -> Style -> CanvasFree ()
H.addColorStop Double
f Color
c Style
g
colorJS :: (Color c) => c -> Double -> H.Color
colorJS :: forall c. Color c => c -> Double -> Color
colorJS c
c Double
o = Int -> Int -> Int -> Double -> Color
H.RGBA (Double -> Int
byteRange Double
r) (Double -> Int
byteRange Double
g) (Double -> Int
byteRange Double
b) (Double
o forall a. Num a => a -> a -> a
* forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
a)
where
(Double
r,Double
g,Double
b,Double
a) = forall c. Color c => c -> (Double, Double, Double, Double)
colorToSRGBA forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. Color c => c -> AlphaColour Double
toAlphaColour forall a b. (a -> b) -> a -> b
$ c
c
html5Transform :: T2 Double -> RenderM ()
html5Transform :: Transformation V2 Double -> RenderM ()
html5Transform Transformation V2 Double
tr = forall a. CanvasFree a -> RenderM a
liftC forall a b. (a -> b) -> a -> b
$ Double
-> Double -> Double -> Double -> Double -> Double -> CanvasFree ()
H.transform Double
ax Double
ay Double
bx Double
by Double
tx Double
ty
where
[[Double
ax, Double
ay], [Double
bx, Double
by], [Double
tx, Double
ty]] = (forall a b. (a -> b) -> [a] -> [b]
map forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map) forall a b. (Real a, Fractional b) => a -> b
realToFrac (forall (v :: * -> *) n.
(Additive v, Traversable v, Num n) =>
Transformation v n -> [[n]]
matrixHomRep Transformation V2 Double
tr)
strokeTexture :: Texture Double -> Double -> RenderM ()
strokeTexture :: Texture Double -> Double -> RenderM ()
strokeTexture = (Style -> CanvasFree ()) -> Texture Double -> Double -> RenderM ()
texture Style -> CanvasFree ()
H.strokeStyle
fillTexture :: Texture Double -> Double -> RenderM ()
fillTexture :: Texture Double -> Double -> RenderM ()
fillTexture = (Style -> CanvasFree ()) -> Texture Double -> Double -> RenderM ()
texture Style -> CanvasFree ()
H.fillStyle
fromLineCap :: LineCap -> H.LineCapStyle
fromLineCap :: LineCap -> LineCapStyle
fromLineCap LineCap
LineCapRound = LineCapStyle
H.LineCapRound
fromLineCap LineCap
LineCapSquare = LineCapStyle
H.LineCapSquare
fromLineCap LineCap
_ = LineCapStyle
H.LineCapButt
fromLineJoin :: LineJoin -> H.LineJoinStyle
fromLineJoin :: LineJoin -> LineJoinStyle
fromLineJoin LineJoin
LineJoinRound = LineJoinStyle
H.LineJoinRound
fromLineJoin LineJoin
LineJoinBevel = LineJoinStyle
H.LineJoinBevel
fromLineJoin LineJoin
_ = LineJoinStyle
H.LineJoinMiter
showFontJS :: FontWeight -> FontSlant -> Double -> String -> T.Text
showFontJS :: FontWeight -> FontSlant -> Double -> String -> Text
showFontJS FontWeight
wgt FontSlant
slant Double
sz String
fnt = [Text] -> Text
T.concat [Text
a, Text
" ", Text
b, Text
" ", Text
c, Text
" ", Text
d]
where
a :: Text
a = case FontWeight
wgt of
FontWeight
FontWeightBold -> Text
"bold"
FontWeight
_ -> Text
""
b :: Text
b = case FontSlant
slant of
FontSlant
FontSlantNormal -> Text
""
FontSlant
FontSlantItalic -> Text
"italic"
FontSlant
FontSlantOblique -> Text
"oblique"
c :: Text
c = [Text] -> Text
T.concat [String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Double
sz, Text
"pt"]
d :: Text
d = String -> Text
T.pack String
fnt
renderC :: (Renderable a Html5, V a ~ V2, N a ~ Double) => a -> RenderM ()
renderC :: forall a.
(Renderable a Html5, V a ~ V2, N a ~ Double) =>
a -> RenderM ()
renderC a
a = case (forall t b. Renderable t b => b -> t -> Render b (V t) (N t)
render Html5
Html5 a
a) of C RenderM ()
r -> RenderM ()
r
html5Style :: Style v Double -> RenderM ()
html5Style :: forall (v :: * -> *). Style v Double -> RenderM ()
html5Style Style v Double
s = forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ [ forall a.
AttributeClass a =>
(a -> RenderM ()) -> Maybe (RenderM ())
handle Clip Double -> RenderM ()
clip'
, forall a.
AttributeClass a =>
(a -> RenderM ()) -> Maybe (RenderM ())
handle LineWidth Double -> RenderM ()
lWidth
, forall a.
AttributeClass a =>
(a -> RenderM ()) -> Maybe (RenderM ())
handle LineCap -> RenderM ()
lCap
, forall a.
AttributeClass a =>
(a -> RenderM ()) -> Maybe (RenderM ())
handle LineJoin -> RenderM ()
lJoin
]
where handle :: (AttributeClass a) => (a -> RenderM ()) -> Maybe (RenderM ())
handle :: forall a.
AttributeClass a =>
(a -> RenderM ()) -> Maybe (RenderM ())
handle a -> RenderM ()
f = a -> RenderM ()
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall a (v :: * -> *) n. AttributeClass a => Style v n -> Maybe a
getAttr Style v Double
s
clip' :: Clip Double -> RenderM ()
clip' = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Path V2 Double
p -> Path V2 Double -> RenderM ()
html5Path Path V2 Double
p forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RenderM ()
clip) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. Wrapped s => (Unwrapped s -> s) -> s -> Unwrapped s
op forall n. [Path V2 n] -> Clip n
Clip
lWidth :: LineWidth Double -> RenderM ()
lWidth = forall a. CanvasFree a -> RenderM a
liftC forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> CanvasFree ()
H.lineWidth forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. LineWidth n -> n
getLineWidth
lCap :: LineCap -> RenderM ()
lCap = forall a. CanvasFree a -> RenderM a
liftC forall b c a. (b -> c) -> (a -> b) -> a -> c
. LineCapStyle -> CanvasFree ()
H.lineCap forall b c a. (b -> c) -> (a -> b) -> a -> c
. LineCap -> LineCapStyle
fromLineCap forall b c a. (b -> c) -> (a -> b) -> a -> c
. LineCap -> LineCap
getLineCap
lJoin :: LineJoin -> RenderM ()
lJoin = forall a. CanvasFree a -> RenderM a
liftC forall b c a. (b -> c) -> (a -> b) -> a -> c
. LineJoinStyle -> CanvasFree ()
H.lineJoin forall b c a. (b -> c) -> (a -> b) -> a -> c
. LineJoin -> LineJoinStyle
fromLineJoin forall b c a. (b -> c) -> (a -> b) -> a -> c
. LineJoin -> LineJoin
getLineJoin
instance Renderable (Segment Closed V2 Double) Html5 where
render :: Html5
-> Segment Closed V2 Double
-> Render
Html5 (V (Segment Closed V2 Double)) (N (Segment Closed V2 Double))
render Html5
_ (Linear (OffsetClosed (V2 Double
x Double
y))) = RenderM () -> Render Html5 V2 Double
C forall a b. (a -> b) -> a -> b
$ Double -> Double -> RenderM ()
relLineTo Double
x Double
y
render Html5
_ (Cubic (V2 Double
x1 Double
y1)
(V2 Double
x2 Double
y2)
(OffsetClosed (V2 Double
x3 Double
y3)))
= RenderM () -> Render Html5 V2 Double
C forall a b. (a -> b) -> a -> b
$ Double
-> Double -> Double -> Double -> Double -> Double -> RenderM ()
relCurveTo Double
x1 Double
y1 Double
x2 Double
y2 Double
x3 Double
y3
instance Renderable (Trail V2 Double) Html5 where
render :: Html5
-> Trail V2 Double
-> Render Html5 (V (Trail V2 Double)) (N (Trail V2 Double))
render Html5
_ = forall (v :: * -> *) n r.
(Trail' Line v n -> r) -> (Trail' Loop v n -> r) -> Trail v n -> r
withTrail Trail' Line V2 Double -> Render Html5 V2 Double
renderLine Trail' Loop V2 Double -> Render Html5 V2 Double
renderLoop
where
renderLine :: Trail' Line V2 Double -> Render Html5 V2 Double
renderLine Trail' Line V2 Double
ln = RenderM () -> Render Html5 V2 Double
C forall a b. (a -> b) -> a -> b
$ do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall a.
(Renderable a Html5, V a ~ V2, N a ~ Double) =>
a -> RenderM ()
renderC (forall (v :: * -> *) n. Trail' Line v n -> [Segment Closed v n]
lineSegments Trail' Line V2 Double
ln)
renderLoop :: Trail' Loop V2 Double -> Render Html5 V2 Double
renderLoop Trail' Loop V2 Double
lp = RenderM () -> Render Html5 V2 Double
C forall a b. (a -> b) -> a -> b
$ do
case forall (v :: * -> *) n.
Trail' Loop v n -> ([Segment Closed v n], Segment Open v n)
loopSegments Trail' Loop V2 Double
lp of
([Segment Closed V2 Double]
segs, Linear Offset Open V2 Double
_) -> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall a.
(Renderable a Html5, V a ~ V2, N a ~ Double) =>
a -> RenderM ()
renderC [Segment Closed V2 Double]
segs
([Segment Closed V2 Double], Segment Open V2 Double)
_ -> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall a.
(Renderable a Html5, V a ~ V2, N a ~ Double) =>
a -> RenderM ()
renderC (forall (v :: * -> *) n. Trail' Line v n -> [Segment Closed v n]
lineSegments forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> *) n.
(Metric v, OrderedField n) =>
Trail' Loop v n -> Trail' Line v n
cutLoop forall a b. (a -> b) -> a -> b
$ Trail' Loop V2 Double
lp)
RenderM ()
closePath
instance Renderable (Path V2 Double) Html5 where
render :: Html5
-> Path V2 Double
-> Render Html5 (V (Path V2 Double)) (N (Path V2 Double))
render Html5
_ Path V2 Double
p = RenderM () -> Render Html5 V2 Double
C forall a b. (a -> b) -> a -> b
$ do
Path V2 Double -> RenderM ()
html5Path Path V2 Double
p
Maybe (Texture Double)
f <- forall a b. AttributeClass a => (a -> b) -> RenderM (Maybe b)
getStyleAttrib forall n. FillTexture n -> Texture n
getFillTexture
Maybe (Texture Double)
s <- forall a b. AttributeClass a => (a -> b) -> RenderM (Maybe b)
getStyleAttrib forall n. LineTexture n -> Texture n
getLineTexture
Double
o <- forall a. a -> Maybe a -> a
fromMaybe Double
1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. AttributeClass a => (a -> b) -> RenderM (Maybe b)
getStyleAttrib Opacity -> Double
getOpacity
RenderM ()
save
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isJust Maybe (Texture Double)
f) (Texture Double -> Double -> RenderM ()
fillTexture (forall a. HasCallStack => Maybe a -> a
fromJust Maybe (Texture Double)
f) (forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
o) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RenderM ()
fill)
Texture Double -> Double -> RenderM ()
strokeTexture (forall a. a -> Maybe a -> a
fromMaybe (forall n. SomeColor -> Texture n
SC (forall c. Color c => c -> SomeColor
SomeColor (forall a. Num a => Colour a
black :: Colour Double))) Maybe (Texture Double)
s) (forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
o)
RenderM ()
stroke
RenderM ()
restore
html5Path :: Path V2 Double -> RenderM ()
html5Path :: Path V2 Double -> RenderM ()
html5Path (Path [Located (Trail V2 Double)]
trs) = do
RenderM ()
newPath
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
F.mapM_ forall {a}.
(V a ~ V2, N a ~ Double, Renderable a Html5) =>
Located a -> RenderM ()
renderTrail [Located (Trail V2 Double)]
trs
where
renderTrail :: Located a -> RenderM ()
renderTrail (forall a. Located a -> (Point (V a) (N a), a)
viewLoc -> (forall n. P2 n -> (n, n)
unp2 -> (Double, Double)
p, a
tr)) = do
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Double -> Double -> RenderM ()
moveTo (Double, Double)
p
forall a.
(Renderable a Html5, V a ~ V2, N a ~ Double) =>
a -> RenderM ()
renderC a
tr
instance Renderable (Text Double) Html5 where
render :: Html5
-> Text Double -> Render Html5 (V (Text Double)) (N (Text Double))
render Html5
_ (Text Transformation V2 Double
tr TextAlignment Double
al String
str) = RenderM () -> Render Html5 V2 Double
C forall a b. (a -> b) -> a -> b
$ do
String
tf <- forall a. a -> Maybe a -> a
fromMaybe String
"Calibri" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. AttributeClass a => (a -> b) -> RenderM (Maybe b)
getStyleAttrib Font -> String
getFont
Double
sz <- forall a. a -> Maybe a -> a
fromMaybe Double
12 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. AttributeClass a => (a -> b) -> RenderM (Maybe b)
getStyleAttrib forall n. FontSize n -> n
getFontSize
FontSlant
slant <- forall a. a -> Maybe a -> a
fromMaybe FontSlant
FontSlantNormal forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. AttributeClass a => (a -> b) -> RenderM (Maybe b)
getStyleAttrib FontSlant -> FontSlant
getFontSlant
FontWeight
fw <- forall a. a -> Maybe a -> a
fromMaybe FontWeight
FontWeightNormal forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. AttributeClass a => (a -> b) -> RenderM (Maybe b)
getStyleAttrib FontWeight -> FontWeight
getFontWeight
Texture Double
tx <- forall a. a -> Maybe a -> a
fromMaybe (forall n. SomeColor -> Texture n
SC (forall c. Color c => c -> SomeColor
SomeColor (forall a. Num a => Colour a
black :: Colour Double)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. AttributeClass a => (a -> b) -> RenderM (Maybe b)
getStyleAttrib forall n. FillTexture n -> Texture n
getFillTexture
Double
o <- forall a. a -> Maybe a -> a
fromMaybe Double
1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. AttributeClass a => (a -> b) -> RenderM (Maybe b)
getStyleAttrib Opacity -> Double
getOpacity
let fSize :: Double
fSize = forall (v :: * -> *) n.
(Additive v, Traversable v, Floating n) =>
Transformation v n -> n
avgScale Transformation V2 Double
tr forall a. Num a => a -> a -> a
* Double
sz
fnt :: Text
fnt = FontWeight -> FontSlant -> Double -> String -> Text
showFontJS FontWeight
fw FontSlant
slant Double
fSize String
tf
vAlign :: TextBaselineStyle
vAlign = case TextAlignment Double
al of
TextAlignment Double
BaselineText -> TextBaselineStyle
H.TextBaselineIdeographic
BoxAlignedText Double
_ Double
h -> case Double
h of
Double
h' | Double
h' forall a. Ord a => a -> a -> Bool
<= Double
0.25 -> TextBaselineStyle
H.TextBaselineBottom
Double
h' | Double
h' forall a. Ord a => a -> a -> Bool
>= Double
0.75 -> TextBaselineStyle
H.TextBaselineTop
Double
_ -> TextBaselineStyle
H.TextBaselineMiddle
hAlign :: TextAlignStyle
hAlign = case TextAlignment Double
al of
TextAlignment Double
BaselineText -> TextAlignStyle
H.TextAlignStart
BoxAlignedText Double
w Double
_ -> case Double
w of
Double
w' | Double
w' forall a. Ord a => a -> a -> Bool
<= Double
0.25 -> TextAlignStyle
H.TextAlignStart
Double
w' | Double
w' forall a. Ord a => a -> a -> Bool
>= Double
0.75 -> TextAlignStyle
H.TextAlignEnd
Double
_ -> TextAlignStyle
H.TextAlignCenter
RenderM ()
save
forall a. CanvasFree a -> RenderM a
liftC forall a b. (a -> b) -> a -> b
$ TextBaselineStyle -> CanvasFree ()
H.textBaseline TextBaselineStyle
vAlign
forall a. CanvasFree a -> RenderM a
liftC forall a b. (a -> b) -> a -> b
$ TextAlignStyle -> CanvasFree ()
H.textAlign TextAlignStyle
hAlign
forall a. CanvasFree a -> RenderM a
liftC forall a b. (a -> b) -> a -> b
$ Text -> CanvasFree ()
H.font Text
fnt
Texture Double -> Double -> RenderM ()
fillTexture Texture Double
tx (forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
o)
Transformation V2 Double -> RenderM ()
html5Transform (Transformation V2 Double
tr forall a. Semigroup a => a -> a -> a
<> forall (v :: * -> *) n.
(Additive v, R2 v, Num n) =>
Transformation v n
reflectionY)
forall a. CanvasFree a -> RenderM a
liftC forall a b. (a -> b) -> a -> b
$ Text -> Double -> Double -> CanvasFree ()
H.fillText (String -> Text
T.pack String
str) Double
0 Double
0
RenderM ()
restore
instance Renderable (DImage Double External) Html5 where
render :: Html5
-> DImage Double External
-> Render
Html5 (V (DImage Double External)) (N (DImage Double External))
render Html5
_ (DImage ImageData External
path Int
w Int
h Transformation V2 Double
tr) = RenderM () -> Render Html5 V2 Double
C forall a b. (a -> b) -> a -> b
$ do
let ImageRef String
file = ImageData External
path
RenderM ()
save
Transformation V2 Double -> RenderM ()
html5Transform (Transformation V2 Double
tr forall a. Semigroup a => a -> a -> a
<> forall (v :: * -> *) n.
(Additive v, R2 v, Num n) =>
Transformation v n
reflectionY)
Int
img <- forall a. CanvasFree a -> RenderM a
liftC forall a b. (a -> b) -> a -> b
$ Text -> CanvasFree Int
H.newImage (String -> Text
T.pack String
file)
forall a. CanvasFree a -> RenderM a
liftC forall a b. (a -> b) -> a -> b
$ Int -> Double -> Double -> Double -> Double -> CanvasFree ()
H.drawImageSize Int
img (forall a b. (Integral a, Num b) => a -> b
fromIntegral (-Int
w) forall a. Fractional a => a -> a -> a
/ Double
2) (forall a b. (Integral a, Num b) => a -> b
fromIntegral (-Int
h) forall a. Fractional a => a -> a -> a
/ Double
2)
(forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h)
RenderM ()
restore
renderHtml5 :: FilePath -> SizeSpec V2 Double -> QDiagram Html5 V2 Double Any -> IO ()
renderHtml5 :: String
-> SizeSpec V2 Double -> QDiagram Html5 V2 Double Any -> IO ()
renderHtml5 String
outFile SizeSpec V2 Double
spec
= String -> Text -> IO ()
L.writeFile String
outFile
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
toLazyText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b (v :: * -> *) n m.
(Backend b v n, HasLinearMap v, Metric v, Typeable n,
OrderedField n, Monoid' m) =>
b -> Options b v n -> QDiagram b v n m -> Result b v n
renderDia Html5
Html5 (SizeSpec V2 Double -> Bool -> String -> Options Html5 V2 Double
Html5Options SizeSpec V2 Double
spec Bool
True String
"")