{-|
Module      : Monomer.Graphics.NanoVGRenderer
Copyright   : (c) 2018 Francisco Vallarino
License     : BSD-3-Clause (see the LICENSE file)
Maintainer  : fjvallarino@gmail.com
Stability   : experimental
Portability : non-portable

Renderer based on the nanovg library.
-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TupleSections #-}

module Monomer.Graphics.NanoVGRenderer (makeRenderer) where

import Control.Lens ((&), (^.), (.~))
import Control.Monad (foldM, forM_, unless, when)
import Data.Default
import Data.Functor ((<&>))
import Data.IORef
import Data.List (foldl')
import Data.Maybe
import Data.Sequence (Seq(..), (<|), (|>))
import Data.Set (Set(..))
import Data.Text (Text)
import Data.Text.Foreign (withCStringLen)
import Foreign.C.Types (CFloat)
import Foreign.Ptr
import System.IO.Unsafe

import qualified Data.ByteString as BS
import qualified Data.Map as M
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Vector as V
import qualified NanoVG as VG
import qualified NanoVG.Internal.Image as VGI

import Monomer.Common
import Monomer.Graphics.Types

import qualified Monomer.Common.Lens as L
import qualified Monomer.Graphics.Lens as L

type ImagesMap = M.Map Text Image

data ImageAction
  = ImageAdd
  | ImageUpdate
  | ImageDelete
  deriving (ImageAction -> ImageAction -> Bool
(ImageAction -> ImageAction -> Bool)
-> (ImageAction -> ImageAction -> Bool) -> Eq ImageAction
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ImageAction -> ImageAction -> Bool
$c/= :: ImageAction -> ImageAction -> Bool
== :: ImageAction -> ImageAction -> Bool
$c== :: ImageAction -> ImageAction -> Bool
Eq, Int -> ImageAction -> ShowS
[ImageAction] -> ShowS
ImageAction -> String
(Int -> ImageAction -> ShowS)
-> (ImageAction -> String)
-> ([ImageAction] -> ShowS)
-> Show ImageAction
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ImageAction] -> ShowS
$cshowList :: [ImageAction] -> ShowS
show :: ImageAction -> String
$cshow :: ImageAction -> String
showsPrec :: Int -> ImageAction -> ShowS
$cshowsPrec :: Int -> ImageAction -> ShowS
Show)

data Image = Image {
  Image -> ImageDef
_imImageDef :: ImageDef,
  Image -> Image
_imNvImage :: VG.Image,
  Image -> Int
_imCount :: Int
}

data ImageReq = ImageReq {
  ImageReq -> Text
_irName :: Text,
  ImageReq -> Size
_irSize :: Size,
  ImageReq -> Maybe ByteString
_irImgData :: Maybe BS.ByteString,
  ImageReq -> ImageAction
_irAction :: ImageAction,
  ImageReq -> [ImageFlag]
_irFlags :: [ImageFlag]
}

data Env = Env {
  Env -> Seq (IO ())
overlays :: Seq (IO ()),
  Env -> Seq (IO ())
tasksRaw :: Seq (IO ()),
  Env -> Seq (IO ())
overlaysRaw :: Seq (IO ()),
  Env -> Set Text
validFonts :: Set Text,
  Env -> ImagesMap
imagesMap :: ImagesMap
}

data CSize
  = CSize CFloat CFloat
  deriving (CSize -> CSize -> Bool
(CSize -> CSize -> Bool) -> (CSize -> CSize -> Bool) -> Eq CSize
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CSize -> CSize -> Bool
$c/= :: CSize -> CSize -> Bool
== :: CSize -> CSize -> Bool
$c== :: CSize -> CSize -> Bool
Eq, Int -> CSize -> ShowS
[CSize] -> ShowS
CSize -> String
(Int -> CSize -> ShowS)
-> (CSize -> String) -> ([CSize] -> ShowS) -> Show CSize
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CSize] -> ShowS
$cshowList :: [CSize] -> ShowS
show :: CSize -> String
$cshow :: CSize -> String
showsPrec :: Int -> CSize -> ShowS
$cshowsPrec :: Int -> CSize -> ShowS
Show)

data CPoint
  = CPoint CFloat CFloat
  deriving (CPoint -> CPoint -> Bool
(CPoint -> CPoint -> Bool)
-> (CPoint -> CPoint -> Bool) -> Eq CPoint
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CPoint -> CPoint -> Bool
$c/= :: CPoint -> CPoint -> Bool
== :: CPoint -> CPoint -> Bool
$c== :: CPoint -> CPoint -> Bool
Eq, Int -> CPoint -> ShowS
[CPoint] -> ShowS
CPoint -> String
(Int -> CPoint -> ShowS)
-> (CPoint -> String) -> ([CPoint] -> ShowS) -> Show CPoint
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CPoint] -> ShowS
$cshowList :: [CPoint] -> ShowS
show :: CPoint -> String
$cshow :: CPoint -> String
showsPrec :: Int -> CPoint -> ShowS
$cshowsPrec :: Int -> CPoint -> ShowS
Show)

data CRect
  = CRect CFloat CFloat CFloat CFloat
  deriving (CRect -> CRect -> Bool
(CRect -> CRect -> Bool) -> (CRect -> CRect -> Bool) -> Eq CRect
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CRect -> CRect -> Bool
$c/= :: CRect -> CRect -> Bool
== :: CRect -> CRect -> Bool
$c== :: CRect -> CRect -> Bool
Eq, Int -> CRect -> ShowS
[CRect] -> ShowS
CRect -> String
(Int -> CRect -> ShowS)
-> (CRect -> String) -> ([CRect] -> ShowS) -> Show CRect
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CRect] -> ShowS
$cshowList :: [CRect] -> ShowS
show :: CRect -> String
$cshow :: CRect -> String
showsPrec :: Int -> CRect -> ShowS
$cshowsPrec :: Int -> CRect -> ShowS
Show)

-- | Creates a nanovg based renderer.
makeRenderer
  :: [FontDef]    -- ^ The font definitions.
  -> Double       -- ^ The device pixel rate.
  -> IO Renderer  -- ^ The created renderer.
makeRenderer :: [FontDef] -> Double -> IO Renderer
makeRenderer [FontDef]
fonts Double
dpr = do
  Context
c <- Set CreateFlags -> IO Context
VG.createGL3 ([CreateFlags] -> Set CreateFlags
forall a. Ord a => [a] -> Set a
Set.fromList [CreateFlags
VG.Antialias, CreateFlags
VG.StencilStrokes])

  Set Text
validFonts <- (Set Text -> FontDef -> IO (Set Text))
-> Set Text -> [FontDef] -> IO (Set Text)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Context -> Set Text -> FontDef -> IO (Set Text)
loadFont Context
c) Set Text
forall a. Set a
Set.empty [FontDef]
fonts

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Set Text -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set Text
validFonts) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    String -> IO ()
putStrLn String
"Could not find any valid fonts. Text will fail to be displayed."

  IORef Env
envRef <- Env -> IO (IORef Env)
forall a. a -> IO (IORef a)
newIORef (Env -> IO (IORef Env)) -> Env -> IO (IORef Env)
forall a b. (a -> b) -> a -> b
$ Env :: Seq (IO ())
-> Seq (IO ()) -> Seq (IO ()) -> Set Text -> ImagesMap -> Env
Env {
    overlays :: Seq (IO ())
overlays = Seq (IO ())
forall a. Seq a
Seq.empty,
    tasksRaw :: Seq (IO ())
tasksRaw = Seq (IO ())
forall a. Seq a
Seq.empty,
    overlaysRaw :: Seq (IO ())
overlaysRaw = Seq (IO ())
forall a. Seq a
Seq.empty,
    validFonts :: Set Text
validFonts = Set Text
validFonts,
    imagesMap :: ImagesMap
imagesMap = ImagesMap
forall k a. Map k a
M.empty
  }

  Renderer -> IO Renderer
forall (m :: * -> *) a. Monad m => a -> m a
return (Renderer -> IO Renderer) -> Renderer -> IO Renderer
forall a b. (a -> b) -> a -> b
$ Context -> Double -> IORef Env -> Renderer
newRenderer Context
c Double
dpr IORef Env
envRef

newRenderer :: VG.Context -> Double -> IORef Env -> Renderer
newRenderer :: Context -> Double -> IORef Env -> Renderer
newRenderer Context
c Double
rdpr IORef Env
envRef = Renderer :: (Double -> Double -> IO ())
-> IO ()
-> IO ()
-> IO ()
-> IO ()
-> IO ()
-> (IO () -> IO ())
-> IO ()
-> (IO () -> IO ())
-> IO ()
-> (IO () -> IO ())
-> IO ()
-> (Rect -> IO ())
-> (Point -> IO ())
-> (Point -> IO ())
-> (Double -> IO ())
-> (Double -> IO ())
-> (Winding -> IO ())
-> IO ()
-> (Double -> IO ())
-> (Color -> IO ())
-> (Point -> Point -> Color -> Color -> IO ())
-> (Point -> Double -> Double -> Color -> Color -> IO ())
-> (Text -> Point -> Size -> Double -> Double -> IO ())
-> IO ()
-> (Color -> IO ())
-> (Point -> Point -> Color -> Color -> IO ())
-> (Point -> Double -> Double -> Color -> Color -> IO ())
-> (Text -> Point -> Size -> Double -> Double -> IO ())
-> (Point -> IO ())
-> (Point -> Point -> IO ())
-> (Point -> IO ())
-> (Rect -> IO ())
-> (Rect -> Double -> Double -> Double -> Double -> IO ())
-> (Point -> Double -> Double -> Double -> Winding -> IO ())
-> (Point -> Point -> IO ())
-> (Rect -> IO ())
-> (Point -> Font -> FontSize -> FontSpace -> Text -> IO ())
-> (Text -> IO (Maybe ImageDef))
-> (Text -> Size -> ByteString -> [ImageFlag] -> IO ())
-> (Text -> Size -> ByteString -> IO ())
-> (Text -> IO ())
-> Renderer
Renderer {IO ()
Double -> IO ()
Double -> Double -> IO ()
IO () -> IO ()
Text -> IO (Maybe ImageDef)
Text -> IO ()
Text -> Size -> ByteString -> IO ()
Text -> Size -> ByteString -> [ImageFlag] -> IO ()
Text -> Point -> Size -> Double -> Double -> IO ()
Rect -> IO ()
Rect -> Double -> Double -> Double -> Double -> IO ()
Point -> IO ()
Point -> Double -> Double -> Double -> Winding -> IO ()
Point -> Double -> Double -> Color -> Color -> IO ()
Point -> Point -> IO ()
Point -> Point -> Color -> Color -> IO ()
Point -> Font -> FontSize -> FontSpace -> Text -> IO ()
Color -> IO ()
Winding -> IO ()
forall a. Real a => a -> IO ()
forall a a.
(Real a, Real a) =>
Point -> Double -> a -> a -> Winding -> IO ()
forall a s a. (Real a, HasY s a, Real a, HasX s a) => s -> IO ()
forall a a a a.
(Real a, Real a, Real a, Real a) =>
Rect -> a -> a -> a -> a -> IO ()
deleteImage :: Text -> IO ()
updateImage :: Text -> Size -> ByteString -> IO ()
addImage :: Text -> Size -> ByteString -> [ImageFlag] -> IO ()
getImage :: Text -> IO (Maybe ImageDef)
renderText :: Point -> Font -> FontSize -> FontSpace -> Text -> IO ()
renderEllipse :: Rect -> IO ()
renderQuadTo :: Point -> Point -> IO ()
renderArc :: Point -> Double -> Double -> Double -> Winding -> IO ()
renderRoundedRect :: Rect -> Double -> Double -> Double -> Double -> IO ()
renderRect :: Rect -> IO ()
renderLineTo :: Point -> IO ()
renderLine :: Point -> Point -> IO ()
moveTo :: Point -> IO ()
setFillImagePattern :: Text -> Point -> Size -> Double -> Double -> IO ()
setFillRadialGradient :: Point -> Double -> Double -> Color -> Color -> IO ()
setFillLinearGradient :: Point -> Point -> Color -> Color -> IO ()
setFillColor :: Color -> IO ()
fill :: IO ()
setStrokeImagePattern :: Text -> Point -> Size -> Double -> Double -> IO ()
setStrokeRadialGradient :: Point -> Double -> Double -> Color -> Color -> IO ()
setStrokeLinearGradient :: Point -> Point -> Color -> Color -> IO ()
setStrokeColor :: Color -> IO ()
setStrokeWidth :: Double -> IO ()
stroke :: IO ()
setPathWinding :: Winding -> IO ()
setGlobalAlpha :: Double -> IO ()
setRotation :: Double -> IO ()
setScale :: Point -> IO ()
setTranslation :: Point -> IO ()
intersectScissor :: Rect -> IO ()
renderRawOverlays :: IO ()
createRawOverlay :: IO () -> IO ()
renderRawTasks :: IO ()
createRawTask :: IO () -> IO ()
renderOverlays :: IO ()
createOverlay :: IO () -> IO ()
restoreContext :: IO ()
saveContext :: IO ()
closePath :: IO ()
beginPath :: IO ()
endFrame :: IO ()
beginFrame :: Double -> Double -> IO ()
deleteImage :: Text -> IO ()
updateImage :: Text -> Size -> ByteString -> IO ()
addImage :: Text -> Size -> ByteString -> [ImageFlag] -> IO ()
getImage :: Text -> IO (Maybe ImageDef)
renderText :: Point -> Font -> FontSize -> FontSpace -> Text -> IO ()
renderEllipse :: Rect -> IO ()
renderQuadTo :: Point -> Point -> IO ()
renderArc :: forall a a.
(Real a, Real a) =>
Point -> Double -> a -> a -> Winding -> IO ()
renderRoundedRect :: forall a a a a.
(Real a, Real a, Real a, Real a) =>
Rect -> a -> a -> a -> a -> IO ()
renderRect :: Rect -> IO ()
renderLineTo :: Point -> IO ()
renderLine :: Point -> Point -> IO ()
moveTo :: Point -> IO ()
setFillImagePattern :: Text -> Point -> Size -> Double -> Double -> IO ()
setFillRadialGradient :: Point -> Double -> Double -> Color -> Color -> IO ()
setFillLinearGradient :: Point -> Point -> Color -> Color -> IO ()
setFillColor :: Color -> IO ()
fill :: IO ()
setStrokeImagePattern :: Text -> Point -> Size -> Double -> Double -> IO ()
setStrokeRadialGradient :: Point -> Double -> Double -> Color -> Color -> IO ()
setStrokeLinearGradient :: Point -> Point -> Color -> Color -> IO ()
setStrokeColor :: Color -> IO ()
setStrokeWidth :: Double -> IO ()
stroke :: IO ()
setPathWinding :: Winding -> IO ()
setGlobalAlpha :: forall a. Real a => a -> IO ()
setRotation :: forall a. Real a => a -> IO ()
setScale :: forall a s a. (Real a, HasY s a, Real a, HasX s a) => s -> IO ()
setTranslation :: Point -> IO ()
intersectScissor :: Rect -> IO ()
renderRawOverlays :: IO ()
createRawOverlay :: IO () -> IO ()
renderRawTasks :: IO ()
createRawTask :: IO () -> IO ()
renderOverlays :: IO ()
createOverlay :: IO () -> IO ()
restoreContext :: IO ()
saveContext :: IO ()
closePath :: IO ()
beginPath :: IO ()
endFrame :: IO ()
beginFrame :: Double -> Double -> IO ()
..} where
  {-
  rdpr is used to let nanovg know the real device pixel rate.
  dpr is set to 1 to disable all NanoVGRenderer internal calculations.
  -}
  dpr :: Double
dpr = Double
1

  beginFrame :: Double -> Double -> IO ()
beginFrame Double
w Double
h = do
    Context -> Float -> Float -> Float -> IO ()
VG.beginFrame Context
c Float
cw Float
ch Float
cdpr
    where
      cw :: Float
cw = Double -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Double
w Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
dpr)
      ch :: Float
ch = Double -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Double
h Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
dpr)
      cdpr :: Float
cdpr = Double -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
rdpr

  endFrame :: IO ()
endFrame =
    Context -> IO ()
VG.endFrame Context
c

  beginPath :: IO ()
beginPath =
    Context -> IO ()
VG.beginPath Context
c

  closePath :: IO ()
closePath =
    Context -> IO ()
VG.closePath Context
c

  -- Context management
  saveContext :: IO ()
saveContext =
    Context -> IO ()
VG.save Context
c

  restoreContext :: IO ()
restoreContext =
    Context -> IO ()
VG.restore Context
c

  -- Overlays
  createOverlay :: IO () -> IO ()
createOverlay IO ()
overlay =
    IORef Env -> (Env -> Env) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef Env
envRef ((Env -> Env) -> IO ()) -> (Env -> Env) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Env
env -> Env
env {
      overlays :: Seq (IO ())
overlays = Env -> Seq (IO ())
overlays Env
env Seq (IO ()) -> IO () -> Seq (IO ())
forall a. Seq a -> a -> Seq a
|> IO ()
overlay
    }

  renderOverlays :: IO ()
renderOverlays = do
    Env
env <- IORef Env -> IO Env
forall a. IORef a -> IO a
readIORef IORef Env
envRef
    Seq (IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ (Seq (IO ()) -> IO ()) -> Seq (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Env -> Seq (IO ())
overlays Env
env
    IORef Env -> Env -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Env
envRef Env
env {
      overlays :: Seq (IO ())
overlays = Seq (IO ())
forall a. Seq a
Seq.empty
    }

  -- Raw tasks
  createRawTask :: IO () -> IO ()
createRawTask IO ()
task =
    IORef Env -> (Env -> Env) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef Env
envRef ((Env -> Env) -> IO ()) -> (Env -> Env) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Env
env -> Env
env {
      tasksRaw :: Seq (IO ())
tasksRaw = Env -> Seq (IO ())
tasksRaw Env
env Seq (IO ()) -> IO () -> Seq (IO ())
forall a. Seq a -> a -> Seq a
|> IO ()
task
    }

  renderRawTasks :: IO ()
renderRawTasks = do
    Env
env <- IORef Env -> IO Env
forall a. IORef a -> IO a
readIORef IORef Env
envRef
    Seq (IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ (Seq (IO ()) -> IO ()) -> Seq (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Env -> Seq (IO ())
tasksRaw Env
env
    IORef Env -> Env -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Env
envRef Env
env {
      tasksRaw :: Seq (IO ())
tasksRaw = Seq (IO ())
forall a. Seq a
Seq.empty
    }

  -- Raw overlays
  createRawOverlay :: IO () -> IO ()
createRawOverlay IO ()
overlay =
    IORef Env -> (Env -> Env) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef Env
envRef ((Env -> Env) -> IO ()) -> (Env -> Env) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Env
env -> Env
env {
      overlaysRaw :: Seq (IO ())
overlaysRaw = Env -> Seq (IO ())
overlaysRaw Env
env Seq (IO ()) -> IO () -> Seq (IO ())
forall a. Seq a -> a -> Seq a
|> IO ()
overlay
    }

  renderRawOverlays :: IO ()
renderRawOverlays = do
    Env
env <- IORef Env -> IO Env
forall a. IORef a -> IO a
readIORef IORef Env
envRef
    Seq (IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ (Seq (IO ()) -> IO ()) -> Seq (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Env -> Seq (IO ())
overlaysRaw Env
env
    IORef Env -> Env -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Env
envRef Env
env {
      overlaysRaw :: Seq (IO ())
overlaysRaw = Seq (IO ())
forall a. Seq a
Seq.empty
    }

  -- Scissor
  intersectScissor :: Rect -> IO ()
intersectScissor Rect
rect = do
    Context -> CFloat -> CFloat -> CFloat -> CFloat -> IO ()
VG.intersectScissor Context
c CFloat
cx CFloat
cy CFloat
cw CFloat
ch
    where
      CRect CFloat
cx CFloat
cy CFloat
cw CFloat
ch = Rect -> Double -> CRect
rectToCRect Rect
rect Double
dpr

  -- Translation
  setTranslation :: Point -> IO ()
setTranslation Point
offset = do
    Context -> CFloat -> CFloat -> IO ()
VG.translate Context
c CFloat
tx CFloat
ty
    where
      CPoint CFloat
tx CFloat
ty = Point -> Double -> CPoint
pointToCPoint Point
offset Double
dpr

  -- Scale
  setScale :: s -> IO ()
setScale s
point = do
    Context -> CFloat -> CFloat -> IO ()
VG.scale Context
c CFloat
sx CFloat
sy
    where
      sx :: CFloat
sx = a -> CFloat
forall a b. (Real a, Fractional b) => a -> b
realToFrac (s
point s -> Getting a s a -> a
forall s a. s -> Getting a s a -> a
^. Getting a s a
forall s a. HasX s a => Lens' s a
L.x)
      sy :: CFloat
sy = a -> CFloat
forall a b. (Real a, Fractional b) => a -> b
realToFrac (s
point s -> Getting a s a -> a
forall s a. s -> Getting a s a -> a
^. Getting a s a
forall s a. HasY s a => Lens' s a
L.y)

  -- Rotation
  setRotation :: a -> IO ()
setRotation a
angle = do
    Context -> CFloat -> IO ()
VG.rotate Context
c CFloat
cangle
    where
      cangle :: CFloat
cangle = CFloat -> CFloat
VG.degToRad (CFloat -> CFloat) -> CFloat -> CFloat
forall a b. (a -> b) -> a -> b
$ a -> CFloat
forall a b. (Real a, Fractional b) => a -> b
realToFrac a
angle

  -- Alpha
  setGlobalAlpha :: a -> IO ()
setGlobalAlpha a
alpha = do
    Context -> CFloat -> IO ()
VG.globalAlpha Context
c CFloat
calpha
    where
      calpha :: CFloat
calpha = CFloat -> CFloat -> CFloat
forall a. Ord a => a -> a -> a
max CFloat
0 (CFloat -> CFloat) -> (CFloat -> CFloat) -> CFloat -> CFloat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CFloat -> CFloat -> CFloat
forall a. Ord a => a -> a -> a
min CFloat
1 (CFloat -> CFloat) -> CFloat -> CFloat
forall a b. (a -> b) -> a -> b
$ a -> CFloat
forall a b. (Real a, Fractional b) => a -> b
realToFrac a
alpha

  -- Winding
  setPathWinding :: Winding -> IO ()
setPathWinding Winding
winding = do
    Context -> CInt -> IO ()
VG.pathWinding Context
c CInt
cwinding
    where
      cwinding :: CInt
cwinding = if Winding
winding Winding -> Winding -> Bool
forall a. Eq a => a -> a -> Bool
== Winding
CW then CInt
0 else CInt
1

  -- Strokes
  stroke :: IO ()
stroke =
    Context -> IO ()
VG.stroke Context
c

  setStrokeWidth :: Double -> IO ()
setStrokeWidth Double
width =
    Context -> CFloat -> IO ()
VG.strokeWidth Context
c (Double -> CFloat
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Double -> CFloat) -> Double -> CFloat
forall a b. (a -> b) -> a -> b
$ Double
width Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
dpr)

  setStrokeColor :: Color -> IO ()
setStrokeColor Color
color =
    Context -> Color -> IO ()
VG.strokeColor Context
c (Color -> Color
colorToPaint Color
color)

  setStrokeLinearGradient :: Point -> Point -> Color -> Color -> IO ()
setStrokeLinearGradient Point
p1 Point
p2 Color
color1 Color
color2 = do
    Paint
gradient <- Context -> Double -> Point -> Point -> Color -> Color -> IO Paint
makeLinearGradient Context
c Double
dpr Point
p1 Point
p2 Color
color1 Color
color2
    Context -> Paint -> IO ()
VG.strokePaint Context
c Paint
gradient

  setStrokeRadialGradient :: Point -> Double -> Double -> Color -> Color -> IO ()
setStrokeRadialGradient Point
p1 Double
rad1 Double
rad2 Color
color1 Color
color2 = do
    Paint
gradient <- Context
-> Double
-> Point
-> Double
-> Double
-> Color
-> Color
-> IO Paint
makeRadialGradient Context
c Double
dpr Point
p1 Double
rad1 Double
rad2 Color
color1 Color
color2
    Context -> Paint -> IO ()
VG.strokePaint Context
c Paint
gradient

  setStrokeImagePattern :: Text -> Point -> Size -> Double -> Double -> IO ()
setStrokeImagePattern Text
name Point
topLeft Size
size Double
angle Double
alpha = do
    Env
env <- IORef Env -> IO Env
forall a. IORef a -> IO a
readIORef IORef Env
envRef

    Maybe Image -> (Image -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Text -> ImagesMap -> Maybe Image
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
name (Env -> ImagesMap
imagesMap Env
env)) ((Image -> IO ()) -> IO ()) -> (Image -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Image
image -> do
      Paint
imgPattern <- Context
-> Double -> Image -> Point -> Size -> Double -> Double -> IO Paint
makeImagePattern Context
c Double
dpr Image
image Point
topLeft Size
size Double
angle Double
alpha
      Context -> Paint -> IO ()
VG.strokePaint Context
c Paint
imgPattern

  -- Fill
  fill :: IO ()
fill =
    Context -> IO ()
VG.fill Context
c

  setFillColor :: Color -> IO ()
setFillColor Color
color =
    Context -> Color -> IO ()
VG.fillColor Context
c (Color -> Color
colorToPaint Color
color)

  setFillLinearGradient :: Point -> Point -> Color -> Color -> IO ()
setFillLinearGradient Point
p1 Point
p2 Color
color1 Color
color2 = do
    Paint
gradient <- Context -> Double -> Point -> Point -> Color -> Color -> IO Paint
makeLinearGradient Context
c Double
dpr Point
p1 Point
p2 Color
color1 Color
color2
    Context -> Paint -> IO ()
VG.fillPaint Context
c Paint
gradient

  setFillRadialGradient :: Point -> Double -> Double -> Color -> Color -> IO ()
setFillRadialGradient Point
p1 Double
rad1 Double
rad2 Color
color1 Color
color2 = do
    Paint
gradient <- Context
-> Double
-> Point
-> Double
-> Double
-> Color
-> Color
-> IO Paint
makeRadialGradient Context
c Double
dpr Point
p1 Double
rad1 Double
rad2 Color
color1 Color
color2
    Context -> Paint -> IO ()
VG.fillPaint Context
c Paint
gradient

  setFillImagePattern :: Text -> Point -> Size -> Double -> Double -> IO ()
setFillImagePattern Text
name Point
topLeft Size
size Double
angle Double
alpha = do
    Env
env <- IORef Env -> IO Env
forall a. IORef a -> IO a
readIORef IORef Env
envRef

    Maybe Image -> (Image -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Text -> ImagesMap -> Maybe Image
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
name (Env -> ImagesMap
imagesMap Env
env)) ((Image -> IO ()) -> IO ()) -> (Image -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Image
image -> do
      Paint
imgPattern <- Context
-> Double -> Image -> Point -> Size -> Double -> Double -> IO Paint
makeImagePattern Context
c Double
dpr Image
image Point
topLeft Size
size Double
angle Double
alpha
      Context -> Paint -> IO ()
VG.fillPaint Context
c Paint
imgPattern

  -- Drawing
  moveTo :: Point -> IO ()
moveTo !Point
point =
    Context -> CFloat -> CFloat -> IO ()
VG.moveTo Context
c CFloat
x CFloat
y
    where
      CPoint CFloat
x CFloat
y = Point -> Double -> CPoint
pointToCPoint Point
point Double
dpr

  renderLine :: Point -> Point -> IO ()
renderLine Point
p1 Point
p2 = do
    Context -> CFloat -> CFloat -> IO ()
VG.moveTo Context
c CFloat
x1 CFloat
y1
    Context -> CFloat -> CFloat -> IO ()
VG.lineTo Context
c CFloat
x2 CFloat
y2
    where
      CPoint CFloat
x1 CFloat
y1 = Point -> Double -> CPoint
pointToCPoint Point
p1 Double
dpr
      CPoint CFloat
x2 CFloat
y2 = Point -> Double -> CPoint
pointToCPoint Point
p2 Double
dpr

  renderLineTo :: Point -> IO ()
renderLineTo !Point
point = do
    Context -> LineCap -> IO ()
VG.lineJoin Context
c LineCap
VG.Bevel
    Context -> CFloat -> CFloat -> IO ()
VG.lineTo Context
c CFloat
x CFloat
y
    where
      CPoint CFloat
x CFloat
y = Point -> Double -> CPoint
pointToCPoint Point
point Double
dpr

  renderRect :: Rect -> IO ()
renderRect !Rect
rect =
    Context -> CFloat -> CFloat -> CFloat -> CFloat -> IO ()
VG.rect Context
c CFloat
x CFloat
y CFloat
w CFloat
h
    where
      CRect CFloat
x CFloat
y CFloat
w CFloat
h = Rect -> Double -> CRect
rectToCRect Rect
rect Double
dpr

  renderRoundedRect :: Rect -> a -> a -> a -> a -> IO ()
renderRoundedRect !Rect
rect a
tl a
tr a
br a
bl =
    Context
-> CFloat
-> CFloat
-> CFloat
-> CFloat
-> CFloat
-> CFloat
-> CFloat
-> CFloat
-> IO ()
VG.roundedRectVarying Context
c CFloat
x CFloat
y CFloat
w CFloat
h CFloat
ctl CFloat
ctr CFloat
cbr CFloat
cbl
    where
      CRect CFloat
x CFloat
y CFloat
w CFloat
h = Rect -> Double -> CRect
rectToCRect Rect
rect Double
dpr
      ctl :: CFloat
ctl = a -> CFloat
forall a b. (Real a, Fractional b) => a -> b
realToFrac a
tl
      ctr :: CFloat
ctr = a -> CFloat
forall a b. (Real a, Fractional b) => a -> b
realToFrac a
tr
      cbr :: CFloat
cbr = a -> CFloat
forall a b. (Real a, Fractional b) => a -> b
realToFrac a
br
      cbl :: CFloat
cbl = a -> CFloat
forall a b. (Real a, Fractional b) => a -> b
realToFrac a
bl

  renderArc :: Point -> Double -> a -> a -> Winding -> IO ()
renderArc !Point
point Double
rad a
angleStart a
angleEnd Winding
winding =
    Context
-> CFloat
-> CFloat
-> CFloat
-> CFloat
-> CFloat
-> Winding
-> IO ()
VG.arc Context
c CFloat
x CFloat
y CFloat
radius CFloat
start CFloat
end Winding
wind
    where
      CPoint CFloat
x CFloat
y = Point -> Double -> CPoint
pointToCPoint Point
point Double
dpr
      radius :: CFloat
radius = Double -> CFloat
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Double -> CFloat) -> Double -> CFloat
forall a b. (a -> b) -> a -> b
$ Double
rad Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
dpr
      start :: CFloat
start = CFloat -> CFloat
VG.degToRad (CFloat -> CFloat) -> CFloat -> CFloat
forall a b. (a -> b) -> a -> b
$ a -> CFloat
forall a b. (Real a, Fractional b) => a -> b
realToFrac a
angleStart
      end :: CFloat
end = CFloat -> CFloat
VG.degToRad (CFloat -> CFloat) -> CFloat -> CFloat
forall a b. (a -> b) -> a -> b
$ a -> CFloat
forall a b. (Real a, Fractional b) => a -> b
realToFrac a
angleEnd
      wind :: Winding
wind = Winding -> Winding
convertWinding Winding
winding

  renderQuadTo :: Point -> Point -> IO ()
renderQuadTo Point
p1 Point
p2 =
    Context -> CFloat -> CFloat -> CFloat -> CFloat -> IO ()
VG.quadTo Context
c CFloat
x1 CFloat
y1 CFloat
x2 CFloat
y2
    where
      CPoint CFloat
x1 CFloat
y1 = Point -> Double -> CPoint
pointToCPoint Point
p1 Double
dpr
      CPoint CFloat
x2 CFloat
y2 = Point -> Double -> CPoint
pointToCPoint Point
p2 Double
dpr

  renderEllipse :: Rect -> IO ()
renderEllipse !Rect
rect =
    Context -> CFloat -> CFloat -> CFloat -> CFloat -> IO ()
VG.ellipse Context
c CFloat
cx CFloat
cy CFloat
rx CFloat
ry
    where
      CRect CFloat
x CFloat
y CFloat
w CFloat
h = Rect -> Double -> CRect
rectToCRect Rect
rect Double
dpr
      cx :: CFloat
cx = CFloat
x CFloat -> CFloat -> CFloat
forall a. Num a => a -> a -> a
+ CFloat
rx
      cy :: CFloat
cy = CFloat
y CFloat -> CFloat -> CFloat
forall a. Num a => a -> a -> a
+ CFloat
ry
      rx :: CFloat
rx = CFloat
w CFloat -> CFloat -> CFloat
forall a. Fractional a => a -> a -> a
/ CFloat
2
      ry :: CFloat
ry = CFloat
h CFloat -> CFloat -> CFloat
forall a. Fractional a => a -> a -> a
/ CFloat
2

  -- Text
  renderText :: Point -> Font -> FontSize -> FontSpace -> Text -> IO ()
renderText !Point
point Font
font FontSize
fontSize FontSpace
fontSpaceH Text
message = do
    Context
-> IORef Env -> Double -> Font -> FontSize -> FontSpace -> IO ()
setFont Context
c IORef Env
envRef Double
dpr Font
font FontSize
fontSize FontSpace
fontSpaceH

    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
message Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"") (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      Context -> CFloat -> CFloat -> Text -> IO ()
VG.text Context
c CFloat
tx CFloat
ty Text
message
    where
      CPoint CFloat
tx CFloat
ty = Point -> Double -> CPoint
pointToCPoint Point
point Double
dpr

  getImage :: Text -> IO (Maybe ImageDef)
getImage Text
name = do
    Env
env <- IORef Env -> IO Env
forall a. IORef a -> IO a
readIORef IORef Env
envRef
    let image :: Maybe Image
image = Text -> ImagesMap -> Maybe Image
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
name (Env -> ImagesMap
imagesMap Env
env)
    Maybe ImageDef -> IO (Maybe ImageDef)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ImageDef -> IO (Maybe ImageDef))
-> Maybe ImageDef -> IO (Maybe ImageDef)
forall a b. (a -> b) -> a -> b
$ (Image -> ImageDef) -> Maybe Image -> Maybe ImageDef
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Image -> ImageDef
_imImageDef Maybe Image
image

  addImage :: Text -> Size -> ByteString -> [ImageFlag] -> IO ()
addImage Text
name Size
size ByteString
imgData [ImageFlag]
flags = do
    Context -> IORef Env -> ImageReq -> IO ()
processImgReq Context
c IORef Env
envRef ImageReq
req
    where
      req :: ImageReq
req = Text
-> Size
-> Maybe ByteString
-> ImageAction
-> [ImageFlag]
-> ImageReq
ImageReq Text
name Size
size (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
imgData) ImageAction
ImageAdd [ImageFlag]
flags

  updateImage :: Text -> Size -> ByteString -> IO ()
updateImage Text
name Size
size ByteString
imgData = do
    Context -> IORef Env -> ImageReq -> IO ()
processImgReq Context
c IORef Env
envRef ImageReq
req
    where
      req :: ImageReq
req = Text
-> Size
-> Maybe ByteString
-> ImageAction
-> [ImageFlag]
-> ImageReq
ImageReq Text
name Size
size (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
imgData) ImageAction
ImageUpdate []

  deleteImage :: Text -> IO ()
deleteImage Text
name = do
    Context -> IORef Env -> ImageReq -> IO ()
processImgReq Context
c IORef Env
envRef ImageReq
req
    where
    req :: ImageReq
req = Text
-> Size
-> Maybe ByteString
-> ImageAction
-> [ImageFlag]
-> ImageReq
ImageReq Text
name Size
forall a. Default a => a
def Maybe ByteString
forall a. Maybe a
Nothing ImageAction
ImageDelete []

loadFont :: VG.Context -> Set Text -> FontDef -> IO (Set Text)
loadFont :: Context -> Set Text -> FontDef -> IO (Set Text)
loadFont Context
c Set Text
fonts (FontDef Text
name Text
path) = do
  Maybe Font
res <- Context -> Text -> FileName -> IO (Maybe Font)
VG.createFont Context
c Text
name (Text -> FileName
VG.FileName Text
path)
  case Maybe Font
res of
    Just{} -> Set Text -> IO (Set Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Set Text -> IO (Set Text)) -> Set Text -> IO (Set Text)
forall a b. (a -> b) -> a -> b
$ Text -> Set Text -> Set Text
forall a. Ord a => a -> Set a -> Set a
Set.insert Text
name Set Text
fonts
    Maybe Font
_ -> String -> IO ()
putStrLn (String
"Failed to load font: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
name) IO () -> IO (Set Text) -> IO (Set Text)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Set Text -> IO (Set Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Set Text
fonts

setFont
  :: VG.Context
  -> IORef Env
  -> Double
  -> Font
  -> FontSize
  -> FontSpace
  -> IO ()
setFont :: Context
-> IORef Env -> Double -> Font -> FontSize -> FontSpace -> IO ()
setFont Context
c IORef Env
envRef Double
dpr (Font Text
name) (FontSize Double
size) (FontSpace Double
spaceH) = do
  Env
env <- IORef Env -> IO Env
forall a. IORef a -> IO a
readIORef IORef Env
envRef
  Set Text -> IO ()
handleSetFont (Env -> Set Text
validFonts Env
env)
  where
    handleSetFont :: Set Text -> IO ()
handleSetFont Set Text
validFonts
      | Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Text
name Set Text
validFonts = do
          Context -> Text -> IO ()
VG.fontFace Context
c Text
name
          Context -> CFloat -> IO ()
VG.fontSize Context
c (CFloat -> IO ()) -> CFloat -> IO ()
forall a b. (a -> b) -> a -> b
$ Double -> CFloat
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Double -> CFloat) -> Double -> CFloat
forall a b. (a -> b) -> a -> b
$ Double
size Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
dpr
          Context -> CFloat -> IO ()
VG.textLetterSpacing Context
c (CFloat -> IO ()) -> CFloat -> IO ()
forall a b. (a -> b) -> a -> b
$ Double -> CFloat
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Double -> CFloat) -> Double -> CFloat
forall a b. (a -> b) -> a -> b
$ Double
spaceH Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
dpr
      | Bool
otherwise = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

makeLinearGradient
  :: VG.Context -> Double -> Point -> Point -> Color -> Color -> IO VG.Paint
makeLinearGradient :: Context -> Double -> Point -> Point -> Color -> Color -> IO Paint
makeLinearGradient Context
c Double
dpr Point
p1 Point
p2 Color
color1 Color
color2 = do
  Context
-> CFloat
-> CFloat
-> CFloat
-> CFloat
-> Color
-> Color
-> IO Paint
VG.linearGradient Context
c CFloat
x1 CFloat
y1 CFloat
x2 CFloat
y2 Color
col1 Color
col2
  where
    CPoint CFloat
x1 CFloat
y1 = Point -> Double -> CPoint
pointToCPoint Point
p1 Double
dpr
    CPoint CFloat
x2 CFloat
y2 = Point -> Double -> CPoint
pointToCPoint Point
p2 Double
dpr
    col1 :: Color
col1 = Color -> Color
colorToPaint Color
color1
    col2 :: Color
col2 = Color -> Color
colorToPaint Color
color2

makeRadialGradient
  :: VG.Context -> Double -> Point -> Double -> Double -> Color -> Color -> IO VG.Paint
makeRadialGradient :: Context
-> Double
-> Point
-> Double
-> Double
-> Color
-> Color
-> IO Paint
makeRadialGradient Context
c Double
dpr Point
center Double
rad1 Double
rad2 Color
color1 Color
color2 = do
  Context
-> CFloat
-> CFloat
-> CFloat
-> CFloat
-> Color
-> Color
-> IO Paint
VG.radialGradient Context
c CFloat
cx CFloat
cy CFloat
crad1 CFloat
crad2 Color
col1 Color
col2
  where
    CPoint CFloat
cx CFloat
cy = Point -> Double -> CPoint
pointToCPoint Point
center Double
dpr
    crad1 :: CFloat
crad1 = Double -> CFloat
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
rad1
    crad2 :: CFloat
crad2 = Double -> CFloat
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
rad2
    col1 :: Color
col1 = Color -> Color
colorToPaint Color
color1
    col2 :: Color
col2 = Color -> Color
colorToPaint Color
color2

makeImagePattern
  :: VG.Context -> Double -> Image -> Point -> Size -> Double -> Double -> IO VG.Paint
makeImagePattern :: Context
-> Double -> Image -> Point -> Size -> Double -> Double -> IO Paint
makeImagePattern Context
c Double
dpr Image
image Point
topLeft Size
size Double
angle Double
alpha = do
  Context
-> CFloat
-> CFloat
-> CFloat
-> CFloat
-> CFloat
-> Image
-> CFloat
-> IO Paint
VG.imagePattern Context
c CFloat
x CFloat
y CFloat
w CFloat
h CFloat
cangle Image
nvImg CFloat
calpha
  where
    CPoint CFloat
x CFloat
y = Point -> Double -> CPoint
pointToCPoint Point
topLeft Double
dpr
    CSize CFloat
w CFloat
h = Size -> Double -> CSize
sizeToCSize Size
size Double
dpr
    cangle :: CFloat
cangle = Double -> CFloat
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
angle
    calpha :: CFloat
calpha = Double -> CFloat
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
alpha
    nvImg :: Image
nvImg = Image -> Image
_imNvImage Image
image

processImgReq :: VG.Context -> IORef Env -> ImageReq -> IO ()
processImgReq :: Context -> IORef Env -> ImageReq -> IO ()
processImgReq Context
c IORef Env
envRef ImageReq
imageReq = do
  Env
env <- IORef Env -> IO Env
forall a. IORef a -> IO a
readIORef IORef Env
envRef
  ImagesMap
newImgMap <- Context -> ImagesMap -> ImageReq -> IO ImagesMap
handlePendingImage Context
c (Env -> ImagesMap
imagesMap Env
env) ImageReq
imageReq

  IORef Env -> Env -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Env
envRef (Env -> IO ()) -> Env -> IO ()
forall a b. (a -> b) -> a -> b
$ Env
env {
    imagesMap :: ImagesMap
imagesMap = ImagesMap
newImgMap
  }

handlePendingImage :: VG.Context -> ImagesMap -> ImageReq -> IO ImagesMap
handlePendingImage :: Context -> ImagesMap -> ImageReq -> IO ImagesMap
handlePendingImage Context
c ImagesMap
imagesMap ImageReq
imageReq
  | ImageAction
action ImageAction -> ImageAction -> Bool
forall a. Eq a => a -> a -> Bool
== ImageAction
ImageAdd Bool -> Bool -> Bool
&& Bool
imageExists =
      ImagesMap -> IO ImagesMap
forall (m :: * -> *) a. Monad m => a -> m a
return (ImagesMap -> IO ImagesMap) -> ImagesMap -> IO ImagesMap
forall a b. (a -> b) -> a -> b
$ Text -> ImagesMap -> ImagesMap
imgIncreaseCount Text
name ImagesMap
imagesMap
  | ImageAction
action ImageAction -> [ImageAction] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ImageAction
ImageAdd, ImageAction
ImageUpdate] Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
imageExists = do
      -- Attempt to create image. If it fails, remove existing images and retry.
      -- Ideally only LRU should be removed.
      Maybe Image
tmpImg <- IO (Maybe Image)
createImage
      (ImagesMap
newImgMap, Maybe Image
nvImg) <- if Maybe Image -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Image
tmpImg
        then Context -> ImagesMap -> IO ()
clearImagesMap Context
c ImagesMap
imagesMap IO () -> IO (Maybe Image) -> IO (Maybe Image)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO (Maybe Image)
createImage IO (Maybe Image)
-> (Maybe Image -> (ImagesMap, Maybe Image))
-> IO (ImagesMap, Maybe Image)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (ImagesMap
forall k a. Map k a
M.empty, )
        else (ImagesMap, Maybe Image) -> IO (ImagesMap, Maybe Image)
forall (m :: * -> *) a. Monad m => a -> m a
return (ImagesMap
imagesMap, Maybe Image
tmpImg)
      ImagesMap -> IO ImagesMap
forall (m :: * -> *) a. Monad m => a -> m a
return (ImagesMap -> IO ImagesMap) -> ImagesMap -> IO ImagesMap
forall a b. (a -> b) -> a -> b
$ ImagesMap -> (Image -> ImagesMap) -> Maybe Image -> ImagesMap
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ImagesMap
newImgMap (Text -> ImageDef -> ImagesMap -> Image -> ImagesMap
imgInsertNew Text
name ImageDef
imgDef ImagesMap
newImgMap) Maybe Image
nvImg
  | ImageAction
action ImageAction -> ImageAction -> Bool
forall a. Eq a => a -> a -> Bool
== ImageAction
ImageUpdate Bool -> Bool -> Bool
&& Bool
imageExists Bool -> Bool -> Bool
&& Bool
sizeMatches = do
      Context -> Image -> ByteString -> IO ()
VG.updateImage Context
c (Image -> Image
_imNvImage Image
image) ByteString
imgData
      ImagesMap -> IO ImagesMap
forall (m :: * -> *) a. Monad m => a -> m a
return ImagesMap
imagesMap
  | ImageAction
action ImageAction -> ImageAction -> Bool
forall a. Eq a => a -> a -> Bool
== ImageAction
ImageDelete Bool -> Bool -> Bool
&& Bool
imageExists = do
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Image -> Int
_imCount Image
image Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Context -> Image -> IO ()
VG.deleteImage Context
c (Image -> Image
_imNvImage Image
image)
      ImagesMap -> IO ImagesMap
forall (m :: * -> *) a. Monad m => a -> m a
return (ImagesMap -> IO ImagesMap) -> ImagesMap -> IO ImagesMap
forall a b. (a -> b) -> a -> b
$ Text -> ImagesMap -> ImagesMap
imgDelete Text
name ImagesMap
imagesMap
  | Bool
otherwise =
      ImagesMap -> IO ImagesMap
forall (m :: * -> *) a. Monad m => a -> m a
return ImagesMap
imagesMap
  where
    name :: Text
name = ImageReq -> Text
_irName ImageReq
imageReq
    action :: ImageAction
action = ImageReq -> ImageAction
_irAction ImageReq
imageReq
    size :: Size
size = ImageReq -> Size
_irSize ImageReq
imageReq

    cw :: CInt
cw = Double -> CInt
forall a b. (RealFrac a, Integral b) => a -> b
round (Size
size Size -> Getting Double Size Double -> Double
forall s a. s -> Getting a s a -> a
^. Getting Double Size Double
forall s a. HasW s a => Lens' s a
L.w)
    ch :: CInt
ch = Double -> CInt
forall a b. (RealFrac a, Integral b) => a -> b
round (Size
size Size -> Getting Double Size Double -> Double
forall s a. s -> Getting a s a -> a
^. Getting Double Size Double
forall s a. HasH s a => Lens' s a
L.h)

    imgData :: ByteString
imgData = Maybe ByteString -> ByteString
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ImageReq -> Maybe ByteString
_irImgData ImageReq
imageReq
    imgFlags :: [ImageFlag]
imgFlags = ImageReq -> [ImageFlag]
_irFlags ImageReq
imageReq
    flags :: Set ImageFlags
flags = [ImageFlags] -> Set ImageFlags
forall a. Ord a => [a] -> Set a
Set.fromList (ImageFlag -> ImageFlags
toVGImgFlag (ImageFlag -> ImageFlags) -> [ImageFlag] -> [ImageFlags]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ImageFlag]
imgFlags)

    imgDef :: ImageDef
imgDef = Text -> Size -> ByteString -> [ImageFlag] -> ImageDef
ImageDef Text
name Size
size ByteString
imgData [ImageFlag]
imgFlags
    createImage :: IO (Maybe Image)
createImage = Context
-> CInt -> CInt -> Set ImageFlags -> ByteString -> IO (Maybe Image)
VG.createImageRGBA Context
c CInt
cw CInt
ch Set ImageFlags
flags ByteString
imgData

    mimage :: Maybe Image
mimage = Text -> ImagesMap -> Maybe Image
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
name ImagesMap
imagesMap
    imageExists :: Bool
imageExists = Maybe Image -> Bool
forall a. Maybe a -> Bool
isJust Maybe Image
mimage
    image :: Image
image = Maybe Image -> Image
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Image
mimage
    sizeMatches :: Bool
sizeMatches = Size
size Size -> Size -> Bool
forall a. Eq a => a -> a -> Bool
== Image -> ImageDef
_imImageDef Image
image ImageDef -> Getting Size ImageDef Size -> Size
forall s a. s -> Getting a s a -> a
^. Getting Size ImageDef Size
forall s a. HasSize s a => Lens' s a
L.size

toVGImgFlag :: ImageFlag -> VGI.ImageFlags
toVGImgFlag :: ImageFlag -> ImageFlags
toVGImgFlag ImageFlag
ImageNearest = ImageFlags
VGI.ImageNearest
toVGImgFlag ImageFlag
ImageRepeatX = ImageFlags
VGI.ImageRepeatx
toVGImgFlag ImageFlag
ImageRepeatY = ImageFlags
VGI.ImageRepeaty

imgIncreaseCount :: Text -> ImagesMap -> ImagesMap
imgIncreaseCount :: Text -> ImagesMap -> ImagesMap
imgIncreaseCount Text
name ImagesMap
imagesMap = ImagesMap
newImageMap where
  incCount :: Image -> Image
incCount Image
img = Image
img { _imCount :: Int
_imCount = Image -> Int
_imCount Image
img Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 }
  newImageMap :: ImagesMap
newImageMap = (Image -> Image) -> Text -> ImagesMap -> ImagesMap
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
M.adjust Image -> Image
incCount Text
name ImagesMap
imagesMap

imgInsertNew :: Text -> ImageDef -> ImagesMap -> VG.Image -> ImagesMap
imgInsertNew :: Text -> ImageDef -> ImagesMap -> Image -> ImagesMap
imgInsertNew Text
name ImageDef
imageDef ImagesMap
imagesMap Image
nvImg = ImagesMap
newImagesMap where
  image :: Image
image = ImageDef -> Image -> Int -> Image
Image ImageDef
imageDef Image
nvImg Int
0
  newImagesMap :: ImagesMap
newImagesMap = Text -> Image -> ImagesMap -> ImagesMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Text
name Image
image ImagesMap
imagesMap

imgDelete :: Text -> ImagesMap -> ImagesMap
imgDelete :: Text -> ImagesMap -> ImagesMap
imgDelete Text
name ImagesMap
imagesMap = ImagesMap
newImageMap where
  deleteInstance :: Image -> Maybe Image
deleteInstance Image
img
    | Image -> Int
_imCount Image
img Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 = Image -> Maybe Image
forall a. a -> Maybe a
Just (Image -> Maybe Image) -> Image -> Maybe Image
forall a b. (a -> b) -> a -> b
$ Image
img { _imCount :: Int
_imCount = Image -> Int
_imCount Image
img Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 }
    | Bool
otherwise = Maybe Image
forall a. Maybe a
Nothing
  newImageMap :: ImagesMap
newImageMap = (Image -> Maybe Image) -> Text -> ImagesMap -> ImagesMap
forall k a. Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a
M.update Image -> Maybe Image
deleteInstance Text
name ImagesMap
imagesMap

clearImagesMap :: VG.Context -> ImagesMap -> IO ()
clearImagesMap :: Context -> ImagesMap -> IO ()
clearImagesMap Context
c ImagesMap
imagesMap = do
  String -> IO ()
putStrLn String
"Clearing images map"
  [Image] -> (Image -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (ImagesMap -> [Image]
forall k a. Map k a -> [a]
M.elems ImagesMap
imagesMap) ((Image -> IO ()) -> IO ()) -> (Image -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Image
image ->
    Context -> Image -> IO ()
VG.deleteImage Context
c (Image -> Image
_imNvImage Image
image)

colorToPaint :: Color -> VG.Color
colorToPaint :: Color -> Color
colorToPaint (Color Int
r Int
g Int
b Double
a)
  | Double
a Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
1.0  = CUChar -> CUChar -> CUChar -> Color
VG.rgb CUChar
red CUChar
green CUChar
blue
  | Bool
otherwise = CUChar -> CUChar -> CUChar -> CUChar -> Color
VG.rgba CUChar
red CUChar
green CUChar
blue CUChar
alpha
  where
    red :: CUChar
red = Int -> CUChar
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
r
    green :: CUChar
green = Int -> CUChar
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
g
    blue :: CUChar
blue = Int -> CUChar
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
b
    alpha :: CUChar
alpha = Double -> CUChar
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> CUChar) -> Double -> CUChar
forall a b. (a -> b) -> a -> b
$ Double
a Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
255

convertWinding :: Winding -> VG.Winding
convertWinding :: Winding -> Winding
convertWinding Winding
CW = Winding
VG.CW
convertWinding Winding
CCW = Winding
VG.CCW

sizeToCSize :: Size -> Double -> CSize
sizeToCSize :: Size -> Double -> CSize
sizeToCSize (Size Double
w Double
h) Double
dpr = CFloat -> CFloat -> CSize
CSize CFloat
cw CFloat
ch where
  cw :: CFloat
cw = Double -> CFloat
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Double -> CFloat) -> Double -> CFloat
forall a b. (a -> b) -> a -> b
$ Double
w Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
dpr
  ch :: CFloat
ch = Double -> CFloat
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Double -> CFloat) -> Double -> CFloat
forall a b. (a -> b) -> a -> b
$ Double
h Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
dpr

pointToCPoint :: Point -> Double -> CPoint
pointToCPoint :: Point -> Double -> CPoint
pointToCPoint (Point Double
x Double
y) Double
dpr = CFloat -> CFloat -> CPoint
CPoint CFloat
cx CFloat
cy where
  cx :: CFloat
cx = Double -> CFloat
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Double -> CFloat) -> Double -> CFloat
forall a b. (a -> b) -> a -> b
$ Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
dpr
  cy :: CFloat
cy = Double -> CFloat
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Double -> CFloat) -> Double -> CFloat
forall a b. (a -> b) -> a -> b
$ Double
y Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
dpr

rectToCRect :: Rect -> Double -> CRect
rectToCRect :: Rect -> Double -> CRect
rectToCRect (Rect Double
x Double
y Double
w Double
h) Double
dpr = CFloat -> CFloat -> CFloat -> CFloat -> CRect
CRect CFloat
cx CFloat
cy CFloat
cw CFloat
ch where
  cx :: CFloat
cx = Double -> CFloat
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Double -> CFloat) -> Double -> CFloat
forall a b. (a -> b) -> a -> b
$ Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
dpr
  cy :: CFloat
cy = Double -> CFloat
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Double -> CFloat) -> Double -> CFloat
forall a b. (a -> b) -> a -> b
$ Double
y Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
dpr
  ch :: CFloat
ch = Double -> CFloat
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Double -> CFloat) -> Double -> CFloat
forall a b. (a -> b) -> a -> b
$ Double
h Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
dpr
  cw :: CFloat
cw = Double -> CFloat
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Double -> CFloat) -> Double -> CFloat
forall a b. (a -> b) -> a -> b
$ Double
w Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
dpr