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

Displays an image from local storage or a url.

@
image "https://picsum.photos/id/1059/800/600"
@

It is also possible to create images from a block of memory using 'imageMem'.

Notes:

- Depending on the type of image fit chosen and the assigned viewport, some
  space may remain unused. The alignment options exist to handle this situation.
- If you choose 'fitNone', adding 'imageRepeatX' and 'imageRepeatY' won't have
  any kind of effect.
-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StrictData #-}

module Monomer.Widgets.Singles.Image (
  -- * Configuration
  ImageCfg,
  ImageLoadError(..),
  -- * Constructors
  image,
  image_,
  imageMem,
  imageMem_
) where

import Codec.Picture (DynamicImage, Image(..))
import Control.Applicative ((<|>))
import Control.Concurrent
import Control.Exception (try)
import Control.Lens ((&), (^.), (.~), (%~), (?~), at)
import Control.Monad (when)
import Data.ByteString (ByteString)
import Data.Char (toLower)
import Data.Default
import Data.Map.Strict (Map)
import Data.Maybe
import Data.List (isPrefixOf)
import Data.Text (Text)
import Data.Typeable (cast)
import Data.Vector.Storable.ByteString (vectorToByteString)
import GHC.Generics
import Network.HTTP.Client (HttpException(..), HttpExceptionContent(..))
import Network.Wreq
import Network.Wreq.Session (Session)

import qualified Codec.Picture as Pic
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Map.Strict as Map
import qualified Data.Text as T
import qualified Network.Wreq.Session as Sess

import Monomer.Widgets.Single

import qualified Monomer.Lens as L

data ImageFit
  = FitNone
  | FitFill
  | FitWidth
  | FitHeight
  | FitEither
  deriving (ImageFit -> ImageFit -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ImageFit -> ImageFit -> Bool
$c/= :: ImageFit -> ImageFit -> Bool
== :: ImageFit -> ImageFit -> Bool
$c== :: ImageFit -> ImageFit -> Bool
Eq, Int -> ImageFit -> ShowS
[ImageFit] -> ShowS
ImageFit -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ImageFit] -> ShowS
$cshowList :: [ImageFit] -> ShowS
show :: ImageFit -> [Char]
$cshow :: ImageFit -> [Char]
showsPrec :: Int -> ImageFit -> ShowS
$cshowsPrec :: Int -> ImageFit -> ShowS
Show)

-- | Possible errors when loading an image.
data ImageLoadError
  = ImageLoadFailed String
  | ImageInvalid String
  deriving (ImageLoadError -> ImageLoadError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ImageLoadError -> ImageLoadError -> Bool
$c/= :: ImageLoadError -> ImageLoadError -> Bool
== :: ImageLoadError -> ImageLoadError -> Bool
$c== :: ImageLoadError -> ImageLoadError -> Bool
Eq, Int -> ImageLoadError -> ShowS
[ImageLoadError] -> ShowS
ImageLoadError -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ImageLoadError] -> ShowS
$cshowList :: [ImageLoadError] -> ShowS
show :: ImageLoadError -> [Char]
$cshow :: ImageLoadError -> [Char]
showsPrec :: Int -> ImageLoadError -> ShowS
$cshowsPrec :: Int -> ImageLoadError -> ShowS
Show)

{-|
Configuration options for image:

- 'transparency': the alpha to apply when rendering the image.
- 'onLoadError': an event to report a load error.
- 'imageNearest': apply nearest filtering when stretching an image.
- 'imageRepeatX': repeat the image across the x coordinate.
- 'imageRepeatY': repeat the image across the y coordinate.
- 'fitNone': does not perform any stretching if the size does not match viewport.
- 'fitFill': stretches the image to match the viewport.
- 'fitWidth': stretches the image to match the viewport width. Maintains ratio.
- 'fitHeight': stretches the image to match the viewport height. Maintains ratio.
- 'fitEither': stretches the image to match either the viewport width or height
  such that image does not overflow viewport. Maintains ratio.
- 'alignLeft': aligns to the left if extra space is available.
- 'alignRight': aligns to the right if extra space is available.
- 'alignCenter': aligns to the horizontal center if extra space is available.
- 'alignTop': aligns to the top if extra space is available.
- 'alignMiddle': aligns to the vertical middle if extra space is available.
- 'alignBottom': aligns to the bottom if extra space is available.
-}
data ImageCfg e = ImageCfg {
  forall e. ImageCfg e -> [ImageLoadError -> e]
_imcLoadError :: [ImageLoadError -> e],
  forall e. ImageCfg e -> [ImageFlag]
_imcFlags :: [ImageFlag],
  forall e. ImageCfg e -> Maybe ImageFit
_imcFit :: Maybe ImageFit,
  forall e. ImageCfg e -> Maybe Double
_imcTransparency :: Maybe Double,
  forall e. ImageCfg e -> Maybe AlignH
_imcAlignH :: Maybe AlignH,
  forall e. ImageCfg e -> Maybe AlignV
_imcAlignV :: Maybe AlignV,
  forall e. ImageCfg e -> Maybe Double
_imcFactorW :: Maybe Double,
  forall e. ImageCfg e -> Maybe Double
_imcFactorH :: Maybe Double
}

instance Default (ImageCfg e) where
  def :: ImageCfg e
def = ImageCfg {
    _imcLoadError :: [ImageLoadError -> e]
_imcLoadError = [],
    _imcFlags :: [ImageFlag]
_imcFlags = [],
    _imcFit :: Maybe ImageFit
_imcFit = forall a. Maybe a
Nothing,
    _imcTransparency :: Maybe Double
_imcTransparency = forall a. Maybe a
Nothing,
    _imcAlignH :: Maybe AlignH
_imcAlignH = forall a. Maybe a
Nothing,
    _imcAlignV :: Maybe AlignV
_imcAlignV = forall a. Maybe a
Nothing,
    _imcFactorW :: Maybe Double
_imcFactorW = forall a. Maybe a
Nothing,
    _imcFactorH :: Maybe Double
_imcFactorH = forall a. Maybe a
Nothing
  }

instance Semigroup (ImageCfg e) where
  <> :: ImageCfg e -> ImageCfg e -> ImageCfg e
(<>) ImageCfg e
i1 ImageCfg e
i2 = ImageCfg {
    _imcLoadError :: [ImageLoadError -> e]
_imcLoadError = forall e. ImageCfg e -> [ImageLoadError -> e]
_imcLoadError ImageCfg e
i1 forall a. [a] -> [a] -> [a]
++ forall e. ImageCfg e -> [ImageLoadError -> e]
_imcLoadError ImageCfg e
i2,
    _imcFlags :: [ImageFlag]
_imcFlags = forall e. ImageCfg e -> [ImageFlag]
_imcFlags ImageCfg e
i1 forall a. [a] -> [a] -> [a]
++ forall e. ImageCfg e -> [ImageFlag]
_imcFlags ImageCfg e
i2,
    _imcFit :: Maybe ImageFit
_imcFit = forall e. ImageCfg e -> Maybe ImageFit
_imcFit ImageCfg e
i2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e. ImageCfg e -> Maybe ImageFit
_imcFit ImageCfg e
i1,
    _imcTransparency :: Maybe Double
_imcTransparency = forall e. ImageCfg e -> Maybe Double
_imcTransparency ImageCfg e
i2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e. ImageCfg e -> Maybe Double
_imcTransparency ImageCfg e
i1,
    _imcAlignH :: Maybe AlignH
_imcAlignH = forall e. ImageCfg e -> Maybe AlignH
_imcAlignH ImageCfg e
i2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e. ImageCfg e -> Maybe AlignH
_imcAlignH ImageCfg e
i1,
    _imcAlignV :: Maybe AlignV
_imcAlignV = forall e. ImageCfg e -> Maybe AlignV
_imcAlignV ImageCfg e
i2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e. ImageCfg e -> Maybe AlignV
_imcAlignV ImageCfg e
i1,
    _imcFactorW :: Maybe Double
_imcFactorW = forall e. ImageCfg e -> Maybe Double
_imcFactorW ImageCfg e
i2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e. ImageCfg e -> Maybe Double
_imcFactorW ImageCfg e
i1,
    _imcFactorH :: Maybe Double
_imcFactorH = forall e. ImageCfg e -> Maybe Double
_imcFactorH ImageCfg e
i2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e. ImageCfg e -> Maybe Double
_imcFactorH ImageCfg e
i1
  }

instance Monoid (ImageCfg e) where
  mempty :: ImageCfg e
mempty = forall a. Default a => a
def

instance CmbOnLoadError (ImageCfg e) e ImageLoadError where
  onLoadError :: (ImageLoadError -> e) -> ImageCfg e
onLoadError ImageLoadError -> e
err = forall a. Default a => a
def {
    _imcLoadError :: [ImageLoadError -> e]
_imcLoadError = [ImageLoadError -> e
err]
  }

instance CmbImageNearest (ImageCfg e) where
  imageNearest :: ImageCfg e
imageNearest = forall a. Default a => a
def {
    _imcFlags :: [ImageFlag]
_imcFlags = [ImageFlag
ImageNearest]
  }

instance CmbImageRepeatX (ImageCfg e) where
  imageRepeatX :: ImageCfg e
imageRepeatX = forall a. Default a => a
def {
    _imcFlags :: [ImageFlag]
_imcFlags = [ImageFlag
ImageRepeatX]
  }

instance CmbImageRepeatY (ImageCfg e) where
  imageRepeatY :: ImageCfg e
imageRepeatY = forall a. Default a => a
def {
    _imcFlags :: [ImageFlag]
_imcFlags = [ImageFlag
ImageRepeatY]
  }

instance CmbFitNone (ImageCfg e) where
  fitNone :: ImageCfg e
fitNone = forall a. Default a => a
def {
    _imcFit :: Maybe ImageFit
_imcFit = forall a. a -> Maybe a
Just ImageFit
FitNone
  }

instance CmbFitFill (ImageCfg e) where
  fitFill :: ImageCfg e
fitFill = forall a. Default a => a
def {
    _imcFit :: Maybe ImageFit
_imcFit = forall a. a -> Maybe a
Just ImageFit
FitFill
  }

instance CmbFitWidth (ImageCfg e) where
  fitWidth :: ImageCfg e
fitWidth = forall a. Default a => a
def {
    _imcFit :: Maybe ImageFit
_imcFit = forall a. a -> Maybe a
Just ImageFit
FitWidth
  }

instance CmbFitHeight (ImageCfg e) where
  fitHeight :: ImageCfg e
fitHeight = forall a. Default a => a
def {
    _imcFit :: Maybe ImageFit
_imcFit = forall a. a -> Maybe a
Just ImageFit
FitHeight
  }

instance CmbFitEither (ImageCfg e) where
  fitEither :: ImageCfg e
fitEither  = forall a. Default a => a
def {
    _imcFit :: Maybe ImageFit
_imcFit = forall a. a -> Maybe a
Just ImageFit
FitEither
  }

instance CmbTransparency (ImageCfg e) where
  transparency :: Double -> ImageCfg e
transparency Double
alpha = forall a. Default a => a
def {
    _imcTransparency :: Maybe Double
_imcTransparency = forall a. a -> Maybe a
Just Double
alpha
  }

instance CmbAlignLeft (ImageCfg e) where
  alignLeft_ :: Bool -> ImageCfg e
alignLeft_ Bool
False = forall a. Default a => a
def
  alignLeft_ Bool
True = forall a. Default a => a
def {
    _imcAlignH :: Maybe AlignH
_imcAlignH = forall a. a -> Maybe a
Just AlignH
ALeft
  }

instance CmbAlignCenter (ImageCfg e) where
  alignCenter_ :: Bool -> ImageCfg e
alignCenter_ Bool
False = forall a. Default a => a
def
  alignCenter_ Bool
True = forall a. Default a => a
def {
    _imcAlignH :: Maybe AlignH
_imcAlignH = forall a. a -> Maybe a
Just AlignH
ACenter
  }

instance CmbAlignRight (ImageCfg e) where
  alignRight_ :: Bool -> ImageCfg e
alignRight_ Bool
False = forall a. Default a => a
def
  alignRight_ Bool
True = forall a. Default a => a
def {
    _imcAlignH :: Maybe AlignH
_imcAlignH = forall a. a -> Maybe a
Just AlignH
ARight
  }

instance CmbAlignTop (ImageCfg e) where
  alignTop_ :: Bool -> ImageCfg e
alignTop_ Bool
False = forall a. Default a => a
def
  alignTop_ Bool
True = forall a. Default a => a
def {
    _imcAlignV :: Maybe AlignV
_imcAlignV = forall a. a -> Maybe a
Just AlignV
ATop
  }

instance CmbAlignMiddle (ImageCfg e) where
  alignMiddle_ :: Bool -> ImageCfg e
alignMiddle_ Bool
False = forall a. Default a => a
def
  alignMiddle_ Bool
True = forall a. Default a => a
def {
    _imcAlignV :: Maybe AlignV
_imcAlignV = forall a. a -> Maybe a
Just AlignV
AMiddle
  }

instance CmbAlignBottom (ImageCfg e) where
  alignBottom_ :: Bool -> ImageCfg e
alignBottom_ Bool
False = forall a. Default a => a
def
  alignBottom_ Bool
True = forall a. Default a => a
def {
    _imcAlignV :: Maybe AlignV
_imcAlignV = forall a. a -> Maybe a
Just AlignV
ABottom
  }

instance CmbResizeFactor (ImageCfg e) where
  resizeFactor :: Double -> ImageCfg e
resizeFactor Double
s = forall a. Default a => a
def {
    _imcFactorW :: Maybe Double
_imcFactorW = forall a. a -> Maybe a
Just Double
s,
    _imcFactorH :: Maybe Double
_imcFactorH = forall a. a -> Maybe a
Just Double
s
  }

instance CmbResizeFactorDim (ImageCfg e) where
  resizeFactorW :: Double -> ImageCfg e
resizeFactorW Double
w = forall a. Default a => a
def {
    _imcFactorW :: Maybe Double
_imcFactorW = forall a. a -> Maybe a
Just Double
w
  }
  resizeFactorH :: Double -> ImageCfg e
resizeFactorH Double
h = forall a. Default a => a
def {
    _imcFactorH :: Maybe Double
_imcFactorH = forall a. a -> Maybe a
Just Double
h
  }

data ImageSource
  = ImageMem Text
  | ImagePath Text
  deriving (ImageSource -> ImageSource -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ImageSource -> ImageSource -> Bool
$c/= :: ImageSource -> ImageSource -> Bool
== :: ImageSource -> ImageSource -> Bool
$c== :: ImageSource -> ImageSource -> Bool
Eq, Int -> ImageSource -> ShowS
[ImageSource] -> ShowS
ImageSource -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ImageSource] -> ShowS
$cshowList :: [ImageSource] -> ShowS
show :: ImageSource -> [Char]
$cshow :: ImageSource -> [Char]
showsPrec :: Int -> ImageSource -> ShowS
$cshowsPrec :: Int -> ImageSource -> ShowS
Show)

data ImageState = ImageState {
  ImageState -> ImageSource
isImageSource :: ImageSource,
  ImageState -> Maybe (ByteString, Size)
isImageData :: Maybe (ByteString, Size)
} deriving (ImageState -> ImageState -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ImageState -> ImageState -> Bool
$c/= :: ImageState -> ImageState -> Bool
== :: ImageState -> ImageState -> Bool
$c== :: ImageState -> ImageState -> Bool
Eq, Int -> ImageState -> ShowS
[ImageState] -> ShowS
ImageState -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ImageState] -> ShowS
$cshowList :: [ImageState] -> ShowS
show :: ImageState -> [Char]
$cshow :: ImageState -> [Char]
showsPrec :: Int -> ImageState -> ShowS
$cshowsPrec :: Int -> ImageState -> ShowS
Show, forall x. Rep ImageState x -> ImageState
forall x. ImageState -> Rep ImageState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ImageState x -> ImageState
$cfrom :: forall x. ImageState -> Rep ImageState x
Generic)

data ImageMessage
  = ImageLoaded ImageState
  | ImageFailed ImageLoadError

-- | Creates an image with the given local path or url.
image
  :: WidgetEvent e
  => Text            -- ^ The local path or url.
  -> WidgetNode s e  -- ^ The created image widget.
image :: forall e s. WidgetEvent e => Text -> WidgetNode s e
image Text
path = forall e s. WidgetEvent e => Text -> [ImageCfg e] -> WidgetNode s e
image_ Text
path forall a. Default a => a
def

-- | Creates an image with the given local path or url. Accepts config.
image_
  :: WidgetEvent e
  => Text            -- ^ The local path or url.
  -> [ImageCfg e]    -- ^ The configuration of the image.
  -> WidgetNode s e  -- ^ The created image widget.
image_ :: forall e s. WidgetEvent e => Text -> [ImageCfg e] -> WidgetNode s e
image_ Text
path [ImageCfg e]
configs = forall s e. WidgetType -> Widget s e -> WidgetNode s e
defaultWidgetNode WidgetType
"image" forall {s}. Widget s e
widget where
  config :: ImageCfg e
config = forall a. Monoid a => [a] -> a
mconcat [ImageCfg e]
configs
  source :: ImageSource
source = Text -> ImageSource
ImagePath Text
path
  imageState :: ImageState
imageState = ImageSource -> Maybe (ByteString, Size) -> ImageState
ImageState ImageSource
source forall a. Maybe a
Nothing
  widget :: Widget s e
widget = forall e s.
WidgetEvent e =>
ImageSource -> ImageCfg e -> ImageState -> Widget s e
makeImage ImageSource
source ImageCfg e
config ImageState
imageState

-- | Creates an image with the given binary data.
imageMem
  :: WidgetEvent e
  => Text            -- ^ The logical name of the image.
  -> ByteString      -- ^ The image data as 4-byte RGBA blocks.
  -> Size            -- ^ The size of the image.
  -> WidgetNode s e  -- ^ The created image widget.
imageMem :: forall e s.
WidgetEvent e =>
Text -> ByteString -> Size -> WidgetNode s e
imageMem Text
name ByteString
imgData Size
imgSize = forall e s.
WidgetEvent e =>
Text -> ByteString -> Size -> [ImageCfg e] -> WidgetNode s e
imageMem_ Text
name ByteString
imgData Size
imgSize forall a. Default a => a
def

-- | Creates an image with the given binary data. Accepts config.
imageMem_
  :: WidgetEvent e
  => Text            -- ^ The logical name of the image.
  -> ByteString      -- ^ The image data as 4-byte RGBA blocks.
  -> Size            -- ^ The size of the image.
  -> [ImageCfg e]    -- ^ The configuration of the image.
  -> WidgetNode s e  -- ^ The created image widget.
imageMem_ :: forall e s.
WidgetEvent e =>
Text -> ByteString -> Size -> [ImageCfg e] -> WidgetNode s e
imageMem_ Text
name ByteString
imgData Size
imgSize [ImageCfg e]
configs = forall s e. WidgetType -> Widget s e -> WidgetNode s e
defaultWidgetNode WidgetType
"image" forall {s}. Widget s e
widget where
  config :: ImageCfg e
config = forall a. Monoid a => [a] -> a
mconcat [ImageCfg e]
configs
  source :: ImageSource
source = Text -> ImageSource
ImageMem Text
name
  imageState :: ImageState
imageState = ImageSource -> Maybe (ByteString, Size) -> ImageState
ImageState ImageSource
source (forall a. a -> Maybe a
Just (ByteString
imgData, Size
imgSize))
  widget :: Widget s e
widget = forall e s.
WidgetEvent e =>
ImageSource -> ImageCfg e -> ImageState -> Widget s e
makeImage ImageSource
source ImageCfg e
config ImageState
imageState

makeImage
  :: WidgetEvent e => ImageSource -> ImageCfg e -> ImageState -> Widget s e
makeImage :: forall e s.
WidgetEvent e =>
ImageSource -> ImageCfg e -> ImageState -> Widget s e
makeImage !ImageSource
imgSource !ImageCfg e
config !ImageState
state = forall {s}. Widget s e
widget where
  widget :: Widget s e
widget = forall a s e. WidgetModel a => a -> Single s e a -> Widget s e
createSingle ImageState
state forall a. Default a => a
def {
    singleUseScissor :: Bool
singleUseScissor = Bool
True,
    singleInit :: SingleInitHandler s e
singleInit = forall {s} {s} {e}.
WidgetEnv s e -> WidgetNode s e -> WidgetResult s e
init,
    singleMerge :: SingleMergeHandler s e ImageState
singleMerge = forall {s} {s} {p}.
WidgetEnv s e
-> WidgetNode s e -> p -> ImageState -> WidgetResult s e
merge,
    singleDispose :: SingleInitHandler s e
singleDispose = forall {s} {e} {s} {e}.
WidgetEnv s e -> WidgetNode s e -> WidgetResult s e
dispose,
    singleHandleMessage :: SingleMessageHandler s e
singleHandleMessage = forall {p} {p} {s} {p}.
Typeable p =>
p -> WidgetNode s e -> p -> p -> Maybe (WidgetResult s e)
handleMessage,
    singleGetSizeReq :: SingleGetSizeReqHandler s e
singleGetSizeReq = forall {p} {p}. p -> p -> (SizeReq, SizeReq)
getSizeReq,
    singleRender :: SingleRenderHandler s e
singleRender = forall {s} {e}.
WidgetEnv s e -> WidgetNode s e -> Renderer -> IO ()
render
  }

  isImageMem :: ImageSource -> Bool
isImageMem !ImageSource
source = case ImageSource
source of
    ImageMem{} -> Bool
True
    ImageSource
_ -> Bool
False

  imgName :: ImageSource -> Text
imgName !ImageSource
source = case ImageSource
source of
    ImageMem Text
path -> Text
path
    ImagePath Text
path -> Text
path

  init :: WidgetEnv s e -> WidgetNode s e -> WidgetResult s e
init WidgetEnv s e
wenv WidgetNode s e
node = WidgetResult s e
result where
    wid :: WidgetId
wid = WidgetNode s e
node forall s a. s -> Getting a s a -> a
^. forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasWidgetId s a => Lens' s a
L.widgetId
    path :: Path
path = WidgetNode s e
node forall s a. s -> Getting a s a -> a
^. forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasPath s a => Lens' s a
L.path
    imgPath :: Text
imgPath = ImageSource -> Text
imgName ImageSource
imgSource

    reqs :: [WidgetRequest s e]
reqs = [forall s e i.
Typeable i =>
WidgetId -> Path -> IO i -> WidgetRequest s e
RunTask WidgetId
wid Path
path forall a b. (a -> b) -> a -> b
$ forall e s. ImageCfg e -> WidgetEnv s e -> Text -> IO ImageMessage
handleImageLoad ImageCfg e
config WidgetEnv s e
wenv Text
imgPath]
    result :: WidgetResult s e
result = case ImageSource
imgSource of
      ImageMem Text
_ -> forall s e. WidgetNode s e -> WidgetResult s e
resultNode WidgetNode s e
node
      ImagePath Text
_ -> forall s e.
WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
resultReqs WidgetNode s e
node forall {s} {e}. [WidgetRequest s e]
reqs

  merge :: WidgetEnv s e
-> WidgetNode s e -> p -> ImageState -> WidgetResult s e
merge WidgetEnv s e
wenv WidgetNode s e
newNode p
oldNode ImageState
oldState = WidgetResult s e
result where
    wid :: WidgetId
wid = WidgetNode s e
newNode forall s a. s -> Getting a s a -> a
^. forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasWidgetId s a => Lens' s a
L.widgetId
    path :: Path
path = WidgetNode s e
newNode forall s a. s -> Getting a s a -> a
^. forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasPath s a => Lens' s a
L.path

    oldSource :: ImageSource
oldSource = ImageState -> ImageSource
isImageSource ImageState
oldState

    newPath :: Text
newPath = ImageSource -> Text
imgName ImageSource
imgSource
    oldPath :: Text
oldPath = ImageSource -> Text
imgName ImageSource
oldSource
    isNewMem :: Bool
isNewMem = ImageSource -> Bool
isImageMem ImageSource
imgSource
    isOldMem :: Bool
isOldMem = ImageSource -> Bool
isImageMem ImageSource
oldSource

    sameImgNode :: WidgetNode s e
sameImgNode = WidgetNode s e
newNode
      forall a b. a -> (a -> b) -> b
& forall s a. HasWidget s a => Lens' s a
L.widget forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall e s.
WidgetEvent e =>
ImageSource -> ImageCfg e -> ImageState -> Widget s e
makeImage ImageSource
imgSource ImageCfg e
config ImageState
oldState

    disposeOld :: [WidgetRequest s e]
disposeOld = [ forall s e i.
Typeable i =>
WidgetId -> Path -> IO i -> WidgetRequest s e
RunTask WidgetId
wid Path
path (forall s e. WidgetEnv s e -> Text -> IO ()
handleImageDispose WidgetEnv s e
wenv Text
oldPath) | Bool -> Bool
not Bool
isOldMem ]

    newMemReqs :: [WidgetRequest s e]
newMemReqs = forall {s} {e}. [WidgetRequest s e]
disposeOld forall a. [a] -> [a] -> [a]
++ [
        forall s e. Text -> WidgetRequest s e
RemoveRendererImage Text
oldPath,
        forall s e. WidgetId -> WidgetRequest s e
ResizeWidgets WidgetId
wid
      ]
    newImgReqs :: [WidgetRequest s e]
newImgReqs = forall {s} {e}. [WidgetRequest s e]
disposeOld forall a. [a] -> [a] -> [a]
++ [
        forall s e. Text -> WidgetRequest s e
RemoveRendererImage Text
oldPath,
        forall s e i.
Typeable i =>
WidgetId -> Path -> IO i -> WidgetRequest s e
RunTask WidgetId
wid Path
path (forall e s. ImageCfg e -> WidgetEnv s e -> Text -> IO ImageMessage
handleImageLoad ImageCfg e
config WidgetEnv s e
wenv Text
newPath)
      ]
    result :: WidgetResult s e
result
      | ImageSource
oldSource forall a. Eq a => a -> a -> Bool
== ImageSource
imgSource = forall s e. WidgetNode s e -> WidgetResult s e
resultNode WidgetNode s e
sameImgNode
      | Bool
isNewMem = forall s e.
WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
resultReqs WidgetNode s e
newNode forall {s} {e}. [WidgetRequest s e]
newMemReqs
      | Bool
otherwise = forall s e.
WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
resultReqs WidgetNode s e
newNode forall {s} {e}. [WidgetRequest s e]
newImgReqs

  dispose :: WidgetEnv s e -> WidgetNode s e -> WidgetResult s e
dispose WidgetEnv s e
wenv WidgetNode s e
node = forall s e.
WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
resultReqs WidgetNode s e
node forall {s} {e}. [WidgetRequest s e]
reqs where
    wid :: WidgetId
wid = WidgetNode s e
node forall s a. s -> Getting a s a -> a
^. forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasWidgetId s a => Lens' s a
L.widgetId
    path :: Path
path = WidgetNode s e
node forall s a. s -> Getting a s a -> a
^. forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasPath s a => Lens' s a
L.path
    imgPath :: Text
imgPath = ImageSource -> Text
imgName ImageSource
imgSource
    reqs :: [WidgetRequest s e]
reqs = [
        forall s e. Text -> WidgetRequest s e
RemoveRendererImage Text
imgPath,
        forall s e i.
Typeable i =>
WidgetId -> Path -> IO i -> WidgetRequest s e
RunTask WidgetId
wid Path
path (forall s e. WidgetEnv s e -> Text -> IO ()
handleImageDispose WidgetEnv s e
wenv Text
imgPath)
      ]

  handleMessage :: p -> WidgetNode s e -> p -> p -> Maybe (WidgetResult s e)
handleMessage p
wenv WidgetNode s e
node p
target p
message = Maybe (WidgetResult s e)
result where
    result :: Maybe (WidgetResult s e)
result = forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast p
message forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {s}.
WidgetNode s e -> ImageMessage -> Maybe (WidgetResult s e)
useImage WidgetNode s e
node

  useImage :: WidgetNode s e -> ImageMessage -> Maybe (WidgetResult s e)
useImage WidgetNode s e
node (ImageFailed ImageLoadError
msg) = Maybe (WidgetResult s e)
result where
    evts :: [e]
evts = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> a -> b
$ ImageLoadError
msg) (forall e. ImageCfg e -> [ImageLoadError -> e]
_imcLoadError ImageCfg e
config)
    result :: Maybe (WidgetResult s e)
result = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall e s. Typeable e => WidgetNode s e -> [e] -> WidgetResult s e
resultEvts WidgetNode s e
node [e]
evts
  useImage WidgetNode s e
node (ImageLoaded ImageState
newState) = Maybe (WidgetResult s e)
result where
    widgetId :: WidgetId
widgetId = WidgetNode s e
node forall s a. s -> Getting a s a -> a
^. forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasWidgetId s a => Lens' s a
L.widgetId
    newNode :: WidgetNode s e
newNode = WidgetNode s e
node
      forall a b. a -> (a -> b) -> b
& forall s a. HasWidget s a => Lens' s a
L.widget forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall e s.
WidgetEvent e =>
ImageSource -> ImageCfg e -> ImageState -> Widget s e
makeImage ImageSource
imgSource ImageCfg e
config ImageState
newState
    result :: Maybe (WidgetResult s e)
result = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall s e.
WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
resultReqs WidgetNode s e
newNode [forall s e. WidgetId -> WidgetRequest s e
ResizeWidgets WidgetId
widgetId]

  getSizeReq :: p -> p -> (SizeReq, SizeReq)
getSizeReq p
wenv p
node = (SizeReq
sizeW, SizeReq
sizeH) where
    Size Double
w Double
h = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Default a => a
def forall a b. (a, b) -> b
snd (ImageState -> Maybe (ByteString, Size)
isImageData ImageState
state)
    factorW :: Double
factorW = forall a. a -> Maybe a -> a
fromMaybe Double
1 (forall e. ImageCfg e -> Maybe Double
_imcFactorW ImageCfg e
config)
    factorH :: Double
factorH = forall a. a -> Maybe a -> a
fromMaybe Double
1 (forall e. ImageCfg e -> Maybe Double
_imcFactorH ImageCfg e
config)

    sizeW :: SizeReq
sizeW
      | forall a. Num a => a -> a
abs Double
factorW forall a. Ord a => a -> a -> Bool
< Double
0.01 = Double -> SizeReq
fixedSize Double
w
      | Bool
otherwise = Double -> Double -> SizeReq
expandSize Double
w Double
factorW
    sizeH :: SizeReq
sizeH
      | forall a. Num a => a -> a
abs Double
factorH forall a. Ord a => a -> a -> Bool
< Double
0.01 = Double -> SizeReq
fixedSize Double
h
      | Bool
otherwise = Double -> Double -> SizeReq
expandSize Double
h Double
factorH

  render :: WidgetEnv s e -> WidgetNode s e -> Renderer -> IO ()
render WidgetEnv s e
wenv WidgetNode s e
node Renderer
renderer = do
    Maybe ImageDef
imageDef <- Renderer -> Text -> IO (Maybe ImageDef)
getImage Renderer
renderer Text
imgPath

    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
imageLoaded Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isNothing Maybe ImageDef
imageDef) forall a b. (a -> b) -> a -> b
$
      Renderer -> Text -> Size -> ByteString -> [ImageFlag] -> IO ()
addImage Renderer
renderer Text
imgPath Size
imgSize ByteString
imgBytes [ImageFlag]
imgFlags

    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
imageLoaded forall a b. (a -> b) -> a -> b
$
      Renderer
-> Text
-> [ImageFlag]
-> Size
-> Rect
-> Rect
-> Maybe Radius
-> Double
-> IO ()
showImage Renderer
renderer Text
imgPath [ImageFlag]
imgFlags Size
imgSize Rect
carea Rect
imgRect Maybe Radius
imgRadius Double
alpha
    where
      style :: StyleState
style = forall s e. WidgetEnv s e -> WidgetNode s e -> StyleState
currentStyle WidgetEnv s e
wenv WidgetNode s e
node
      border :: Maybe Border
border = StyleState
style forall s a. s -> Getting a s a -> a
^. forall s a. HasBorder s a => Lens' s a
L.border
      radius :: Maybe Radius
radius = StyleState
style forall s a. s -> Getting a s a -> a
^. forall s a. HasRadius s a => Lens' s a
L.radius
      carea :: Rect
carea = forall s e. WidgetNode s e -> StyleState -> Rect
getContentArea WidgetNode s e
node StyleState
style

      alpha :: Double
alpha = forall a. a -> Maybe a -> a
fromMaybe Double
1 (forall e. ImageCfg e -> Maybe Double
_imcTransparency ImageCfg e
config)
      alignH :: AlignH
alignH = forall a. a -> Maybe a -> a
fromMaybe AlignH
ALeft (forall e. ImageCfg e -> Maybe AlignH
_imcAlignH ImageCfg e
config)
      alignV :: AlignV
alignV = forall a. a -> Maybe a -> a
fromMaybe AlignV
ATop (forall e. ImageCfg e -> Maybe AlignV
_imcAlignV ImageCfg e
config)

      imgPath :: Text
imgPath = ImageSource -> Text
imgName ImageSource
imgSource
      imgFlags :: [ImageFlag]
imgFlags = forall e. ImageCfg e -> [ImageFlag]
_imcFlags ImageCfg e
config
      imgFit :: ImageFit
imgFit = forall a. a -> Maybe a -> a
fromMaybe ImageFit
FitNone (forall e. ImageCfg e -> Maybe ImageFit
_imcFit ImageCfg e
config)
      imgRect :: Rect
imgRect = Rect -> Size -> [ImageFlag] -> ImageFit -> AlignH -> AlignV -> Rect
fitImage Rect
carea Size
imgSize [ImageFlag]
imgFlags ImageFit
imgFit AlignH
alignH AlignV
alignV
      imgRadius :: Maybe Radius
imgRadius = Maybe Border -> Radius -> Radius
subtractBorderFromRadius Maybe Border
border forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Radius
radius

      ImageState ImageSource
_ Maybe (ByteString, Size)
imgData = ImageState
state
      imageLoaded :: Bool
imageLoaded = forall a. Maybe a -> Bool
isJust Maybe (ByteString, Size)
imgData
      (ByteString
imgBytes, Size
imgSize) = forall a. HasCallStack => Maybe a -> a
fromJust Maybe (ByteString, Size)
imgData

showImage
  :: Renderer
  -> Text
  -> [ImageFlag]
  -> Size
  -> Rect
  -> Rect
  -> Maybe Radius
  -> Double
  -> IO ()
showImage :: Renderer
-> Text
-> [ImageFlag]
-> Size
-> Rect
-> Rect
-> Maybe Radius
-> Double
-> IO ()
showImage Renderer
renderer Text
imgPath [ImageFlag]
imgFlags Size
imgSize Rect
vp Rect
rect Maybe Radius
radius Double
alpha =
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isJust Maybe Rect
targetRect) forall a b. (a -> b) -> a -> b
$ do
    Renderer -> IO ()
beginPath Renderer
renderer
    Renderer -> Text -> Point -> Size -> Double -> Double -> IO ()
setFillImagePattern Renderer
renderer Text
imgPath Point
topLeft Size
size Double
angle Double
alpha
    Renderer -> Rect -> Radius -> IO ()
drawRoundedRect Renderer
renderer (forall a. HasCallStack => Maybe a -> a
fromJust Maybe Rect
targetRect) (forall a. a -> Maybe a -> a
fromMaybe forall a. Default a => a
def Maybe Radius
radius)
    Renderer -> IO ()
fill Renderer
renderer
  where
    Rect Double
x Double
y Double
w Double
h = Rect
rect
    Size Double
dw Double
dh = Size
imgSize
    targetRect :: Maybe Rect
targetRect = Rect -> Rect -> Maybe Rect
intersectRects Rect
vp Rect
rect
    iw :: Double
iw
      | ImageFlag
ImageRepeatX forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ImageFlag]
imgFlags = Double
dw
      | Bool
otherwise = Double
w
    ih :: Double
ih
      | ImageFlag
ImageRepeatY forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ImageFlag]
imgFlags = Double
dh
      | Bool
otherwise = Double
h
    topLeft :: Point
topLeft = Double -> Double -> Point
Point Double
x Double
y
    size :: Size
size = Double -> Double -> Size
Size Double
iw Double
ih
    angle :: Double
angle = Double
0

fitImage :: Rect -> Size -> [ImageFlag] -> ImageFit -> AlignH -> AlignV -> Rect
fitImage :: Rect -> Size -> [ImageFlag] -> ImageFit -> AlignH -> AlignV -> Rect
fitImage Rect
viewport Size
imageSize [ImageFlag]
imgFlags ImageFit
imgFit AlignH
alignH AlignV
alignV = case ImageFit
imgFit of
  ImageFit
FitNone -> Double -> Double -> Rect
alignImg Double
iw Double
ih
  ImageFit
FitFill -> Double -> Double -> Rect
alignImg Double
w Double
h
  ImageFit
FitWidth -> Rect
fitWidth
  ImageFit
FitHeight -> Rect
fitHeight
  ImageFit
FitEither
    | Double
w forall a. Num a => a -> a -> a
* Double
ih forall a. Ord a => a -> a -> Bool
> Double
h forall a. Num a => a -> a -> a
* Double
iw -> Rect
fitHeight
    | Bool
otherwise -> Rect
fitWidth
  where
    Rect Double
x Double
y Double
w Double
h = Rect
viewport
    Size Double
iw Double
ih = Size
imageSize
    alignImg :: Double -> Double -> Rect
alignImg Double
nw Double
nh = Rect -> Rect -> AlignH -> AlignV -> Rect
alignInRect Rect
viewport (Double -> Double -> Double -> Double -> Rect
Rect Double
x Double
y Double
nw Double
nh) AlignH
alignH AlignV
alignV
    fitWidth :: Rect
fitWidth
      | ImageFlag
ImageRepeatY forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ImageFlag]
imgFlags = Double -> Double -> Rect
alignImg Double
w Double
ih
      | Bool
otherwise = Double -> Double -> Rect
alignImg Double
w (Double
w forall a. Num a => a -> a -> a
* Double
ih forall a. Fractional a => a -> a -> a
/ Double
iw)
    fitHeight :: Rect
fitHeight
      | ImageFlag
ImageRepeatX forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ImageFlag]
imgFlags = Double -> Double -> Rect
alignImg Double
iw Double
h
      | Bool
otherwise = Double -> Double -> Rect
alignImg (Double
h forall a. Num a => a -> a -> a
* Double
iw forall a. Fractional a => a -> a -> a
/ Double
ih) Double
h


handleImageLoad :: ImageCfg e -> WidgetEnv s e -> Text -> IO ImageMessage
handleImageLoad :: forall e s. ImageCfg e -> WidgetEnv s e -> Text -> IO ImageMessage
handleImageLoad ImageCfg e
config WidgetEnv s e
wenv Text
path = do
  -- Get the image's MVar. One MVar per image name/path is created, to allow
  -- loading images in parallel. The main MVar is only taken until the image's
  -- MVar is retrieved/created.
  (Map Text WidgetShared
sharedMap, Session
sess) <- forall a. MVar a -> IO a
takeMVar MVar (Map Text WidgetShared)
sharedMapMVar forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Map Text WidgetShared -> IO (Map Text WidgetShared, Session)
getImagesSession

  MVar (Maybe (ImageState, Int))
sharedImgMVar <- case forall i. Typeable i => Maybe WidgetShared -> Maybe i
useShared (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
key Map Text WidgetShared
sharedMap) of
    Just MVar (Maybe (ImageState, Int))
mvar -> forall (m :: * -> *) a. Monad m => a -> m a
return MVar (Maybe (ImageState, Int))
mvar
    Maybe (MVar (Maybe (ImageState, Int)))
Nothing -> forall a. a -> IO (MVar a)
newMVar Maybe (ImageState, Int)
emptyImgState
  forall a. MVar a -> a -> IO ()
putMVar MVar (Map Text WidgetShared)
sharedMapMVar (Map Text WidgetShared
sharedMap forall a b. a -> (a -> b) -> b
& forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Text
key forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ forall i. Typeable i => i -> WidgetShared
WidgetShared MVar (Maybe (ImageState, Int))
sharedImgMVar)

  -- Take the image's MVar until done
  Maybe (ImageState, Int)
sharedImg <- forall a. MVar a -> IO a
takeMVar MVar (Maybe (ImageState, Int))
sharedImgMVar

  (ImageMessage
result, Maybe (ImageState, Int)
newSharedImg) <- case Maybe (ImageState, Int)
sharedImg of
    Just (ImageState
oldState, Int
oldCount) -> do
      forall (m :: * -> *) a. Monad m => a -> m a
return (ImageState -> ImageMessage
ImageLoaded ImageState
oldState, forall a. a -> Maybe a
Just (ImageState
oldState, Int
oldCount forall a. Num a => a -> a -> a
+ Int
1))
    Maybe (ImageState, Int)
Nothing -> do
      Either ImageLoadError ByteString
res <- Session -> Text -> IO (Either ImageLoadError ByteString)
loadImage Session
sess Text
path

      case Either ImageLoadError ByteString
res forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Either ImageLoadError DynamicImage
decodeImage of
        Left ImageLoadError
loadError -> forall (m :: * -> *) a. Monad m => a -> m a
return (ImageLoadError -> ImageMessage
ImageFailed ImageLoadError
loadError, forall a. Maybe a
Nothing)
        Right DynamicImage
dimg -> do
          let newState :: ImageState
newState = forall e s.
ImageCfg e -> WidgetEnv s e -> Text -> DynamicImage -> ImageState
makeImgState ImageCfg e
config WidgetEnv s e
wenv Text
path DynamicImage
dimg
          forall (m :: * -> *) a. Monad m => a -> m a
return (ImageState -> ImageMessage
ImageLoaded ImageState
newState, forall a. a -> Maybe a
Just (ImageState
newState, Int
1))

  forall a. MVar a -> a -> IO ()
putMVar MVar (Maybe (ImageState, Int))
sharedImgMVar Maybe (ImageState, Int)
newSharedImg
  forall (m :: * -> *) a. Monad m => a -> m a
return ImageMessage
result
  where
    key :: Text
key = Text -> Text
imgKey Text
path
    sharedMapMVar :: MVar (Map Text WidgetShared)
sharedMapMVar = WidgetEnv s e
wenv forall s a. s -> Getting a s a -> a
^. forall s a. HasWidgetShared s a => Lens' s a
L.widgetShared
    emptyImgState :: Maybe (ImageState, Int)
    emptyImgState :: Maybe (ImageState, Int)
emptyImgState = forall a. Maybe a
Nothing

handleImageDispose :: WidgetEnv s e -> Text -> IO ()
handleImageDispose :: forall s e. WidgetEnv s e -> Text -> IO ()
handleImageDispose WidgetEnv s e
wenv Text
path = do
  Map Text WidgetShared
sharedMap <- forall a. MVar a -> IO a
takeMVar MVar (Map Text WidgetShared)
sharedMapMVar

  Map Text WidgetShared
newSharedMap <- case forall i. Typeable i => Maybe WidgetShared -> Maybe i
useShared (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
key Map Text WidgetShared
sharedMap) of
    Just MVar (Maybe (ImageState, Int))
mvar -> do
      Maybe (ImageState, Int)
sharedImg <- forall a. MVar a -> IO a
takeMVar MVar (Maybe (ImageState, Int))
mvar

      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Maybe (ImageState, Int)
sharedImg of
        Just (ImageState
oldState :: ImageState, Int
oldCount :: Int)
          | Int
oldCount forall a. Ord a => a -> a -> Bool
> Int
1 ->
              Map Text WidgetShared
sharedMap forall a b. a -> (a -> b) -> b
& forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Text
key forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ forall i. Typeable i => i -> WidgetShared
WidgetShared (ImageState
oldState, Int
oldCount forall a. Num a => a -> a -> a
- Int
1)
        Maybe (ImageState, Int)
_ -> Map Text WidgetShared
sharedMap forall a b. a -> (a -> b) -> b
& forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Text
key forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. Maybe a
Nothing
    Maybe (MVar (Maybe (ImageState, Int)))
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Map Text WidgetShared
sharedMap

  forall a. MVar a -> a -> IO ()
putMVar MVar (Map Text WidgetShared)
sharedMapMVar Map Text WidgetShared
newSharedMap
  where
    sharedMapMVar :: MVar (Map Text WidgetShared)
sharedMapMVar = WidgetEnv s e
wenv forall s a. s -> Getting a s a -> a
^. forall s a. HasWidgetShared s a => Lens' s a
L.widgetShared
    key :: Text
key = Text -> Text
imgKey Text
path

imgKey :: Text -> Text
imgKey :: Text -> Text
imgKey Text
path = Text
"image-widget-key-" forall a. Semigroup a => a -> a -> a
<> Text
path

loadImage :: Session -> Text -> IO (Either ImageLoadError ByteString)
loadImage :: Session -> Text -> IO (Either ImageLoadError ByteString)
loadImage Session
sess Text
path
  | Bool -> Bool
not (Text -> Bool
isUrl Text
path) = Text -> IO (Either ImageLoadError ByteString)
loadLocal Text
path
  | Bool
otherwise = Session -> Text -> IO (Either ImageLoadError ByteString)
loadRemote Session
sess Text
path

decodeImage :: ByteString -> Either ImageLoadError DynamicImage
decodeImage :: ByteString -> Either ImageLoadError DynamicImage
decodeImage ByteString
bs = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ImageLoadError
ImageInvalid) forall a b. b -> Either a b
Right (ByteString -> Either [Char] DynamicImage
Pic.decodeImage ByteString
bs)

loadLocal :: Text -> IO (Either ImageLoadError ByteString)
loadLocal :: Text -> IO (Either ImageLoadError ByteString)
loadLocal Text
name = do
  let path :: [Char]
path = Text -> [Char]
T.unpack Text
name
  ByteString
content <- [Char] -> IO ByteString
BS.readFile [Char]
path

  if ByteString -> Int
BS.length ByteString
content forall a. Eq a => a -> a -> Bool
== Int
0
    then forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ImageLoadError
ImageLoadFailed forall a b. (a -> b) -> a -> b
$ [Char]
"Failed to load: " forall a. [a] -> [a] -> [a]
++ [Char]
path
    else forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ ByteString
content

loadRemote :: Session -> Text -> IO (Either ImageLoadError ByteString)
loadRemote :: Session -> Text -> IO (Either ImageLoadError ByteString)
loadRemote Session
sess Text
name = do
  let path :: [Char]
path = Text -> [Char]
T.unpack Text
name
  Either HttpException (Response ByteString)
eresp <- forall e a. Exception e => IO a -> IO (Either e a)
try forall a b. (a -> b) -> a -> b
$ [Char] -> IO (Response ByteString)
getUrl [Char]
path

  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Either HttpException (Response ByteString)
eresp of
    Left HttpException
e -> [Char] -> HttpException -> Either ImageLoadError ByteString
remoteException [Char]
path HttpException
e
    Right Response ByteString
r -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Response ByteString -> ByteString
respBody Response ByteString
r
  where
    respBody :: Response ByteString -> ByteString
respBody Response ByteString
r = ByteString -> ByteString
BSL.toStrict forall a b. (a -> b) -> a -> b
$ Response ByteString
r forall s a. s -> Getting a s a -> a
^. forall body0 body1.
Lens (Response body0) (Response body1) body0 body1
responseBody
    getUrl :: [Char] -> IO (Response ByteString)
getUrl = Options -> Session -> [Char] -> IO (Response ByteString)
Sess.getWith (Options
defaults forall a b. a -> (a -> b) -> b
& Lens' Options (Maybe ResponseChecker)
checkResponse forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ (\Request
_ Response (IO ByteString)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ())) Session
sess

remoteException
  :: String -> HttpException -> Either ImageLoadError ByteString
remoteException :: [Char] -> HttpException -> Either ImageLoadError ByteString
remoteException [Char]
path (HttpExceptionRequest Request
_ (StatusCodeException Response ()
r ByteString
_)) =
  forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ImageLoadError
ImageLoadFailed forall a b. (a -> b) -> a -> b
$ [Char] -> ShowS
respErrorMsg [Char]
path forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show (forall a. Response a -> Int
respCode Response ()
r)
remoteException [Char]
path HttpException
_ =
  forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ImageLoadError
ImageLoadFailed forall a b. (a -> b) -> a -> b
$ [Char] -> ShowS
respErrorMsg [Char]
path [Char]
"Unknown"

respCode :: Response a -> Int
respCode :: forall a. Response a -> Int
respCode Response a
r = Response a
r forall s a. s -> Getting a s a -> a
^. forall body. Lens' (Response body) Status
responseStatus forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Status Int
statusCode

respErrorMsg :: String -> String -> String
respErrorMsg :: [Char] -> ShowS
respErrorMsg [Char]
path [Char]
code = [Char]
"Status: " forall a. [a] -> [a] -> [a]
++ [Char]
code forall a. [a] -> [a] -> [a]
++ [Char]
" - Path: " forall a. [a] -> [a] -> [a]
++ [Char]
path

makeImgState
  :: ImageCfg e
  -> WidgetEnv s e
  -> Text
  -> DynamicImage
  -> ImageState
makeImgState :: forall e s.
ImageCfg e -> WidgetEnv s e -> Text -> DynamicImage -> ImageState
makeImgState ImageCfg e
config WidgetEnv s e
wenv Text
name DynamicImage
dimg = ImageState
newState where
  img :: Image PixelRGBA8
img = DynamicImage -> Image PixelRGBA8
Pic.convertRGBA8 DynamicImage
dimg
  cw :: Int
cw = forall a. Image a -> Int
imageWidth Image PixelRGBA8
img
  ch :: Int
ch = forall a. Image a -> Int
imageHeight Image PixelRGBA8
img
  size :: Size
size = Double -> Double -> Size
Size (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
cw) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ch)
  bs :: ByteString
bs = forall a. Storable a => Vector a -> ByteString
vectorToByteString forall a b. (a -> b) -> a -> b
$ forall a. Image a -> Vector (PixelBaseComponent a)
imageData Image PixelRGBA8
img
  newState :: ImageState
newState = ImageState {
    isImageSource :: ImageSource
isImageSource = Text -> ImageSource
ImagePath Text
name,
    isImageData :: Maybe (ByteString, Size)
isImageData = forall a. a -> Maybe a
Just (ByteString
bs, Size
size)
  }

getImagesSession
  :: Map Text WidgetShared
  -> IO (Map Text WidgetShared, Sess.Session)
getImagesSession :: Map Text WidgetShared -> IO (Map Text WidgetShared, Session)
getImagesSession Map Text WidgetShared
sharedMap = case forall i. Typeable i => Maybe WidgetShared -> Maybe i
useShared (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
key Map Text WidgetShared
sharedMap) of
  Just Session
sess -> forall (m :: * -> *) a. Monad m => a -> m a
return (Map Text WidgetShared
sharedMap, Session
sess)
  Maybe Session
Nothing -> do
    Session
sess <- IO Session
Sess.newAPISession
    forall (m :: * -> *) a. Monad m => a -> m a
return (Map Text WidgetShared
sharedMap forall a b. a -> (a -> b) -> b
& forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Text
key forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ forall i. Typeable i => i -> WidgetShared
WidgetShared Session
sess, Session
sess)
  where
    key :: Text
key = Text
"image-widget-wreq-session"

isUrl :: Text -> Bool
isUrl :: Text -> Bool
isUrl Text
url = Text -> Text -> Bool
T.isPrefixOf Text
"http://" Text
lurl Bool -> Bool -> Bool
|| Text -> Text -> Bool
T.isPrefixOf Text
"https://" Text
lurl where
  lurl :: Text
lurl = Text -> Text
T.toLower Text
url