{-|
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.

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 (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 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
  deriving (ImageFit -> ImageFit -> Bool
(ImageFit -> ImageFit -> Bool)
-> (ImageFit -> ImageFit -> Bool) -> Eq ImageFit
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 -> String
(Int -> ImageFit -> ShowS)
-> (ImageFit -> String) -> ([ImageFit] -> ShowS) -> Show ImageFit
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ImageFit] -> ShowS
$cshowList :: [ImageFit] -> ShowS
show :: ImageFit -> String
$cshow :: ImageFit -> String
showsPrec :: Int -> ImageFit -> ShowS
$cshowsPrec :: Int -> ImageFit -> ShowS
Show)

-- | Posible errors when loading an image.
data ImageLoadError
  = ImageLoadFailed String
  | ImageInvalid String
  deriving (ImageLoadError -> ImageLoadError -> Bool
(ImageLoadError -> ImageLoadError -> Bool)
-> (ImageLoadError -> ImageLoadError -> Bool) -> Eq ImageLoadError
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 -> String
(Int -> ImageLoadError -> ShowS)
-> (ImageLoadError -> String)
-> ([ImageLoadError] -> ShowS)
-> Show ImageLoadError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ImageLoadError] -> ShowS
$cshowList :: [ImageLoadError] -> ShowS
show :: ImageLoadError -> String
$cshow :: ImageLoadError -> String
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 streching 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.
- 'alignLeft': aligns left if extra space is available.
- 'alignRight': aligns right if extra space is available.
- 'alignCenter': aligns center if extra space is available.
- 'alignTop': aligns top if extra space is available.
- 'alignMiddle': aligns middle if extra space is available.
- 'alignBottom': aligns bottom if extra space is available.
-}
data ImageCfg e = ImageCfg {
  ImageCfg e -> [ImageLoadError -> e]
_imcLoadError :: [ImageLoadError -> e],
  ImageCfg e -> [ImageFlag]
_imcFlags :: [ImageFlag],
  ImageCfg e -> Maybe ImageFit
_imcFit :: Maybe ImageFit,
  ImageCfg e -> Maybe Double
_imcTransparency :: Maybe Double,
  ImageCfg e -> Maybe AlignH
_imcAlignH :: Maybe AlignH,
  ImageCfg e -> Maybe AlignV
_imcAlignV :: Maybe AlignV,
  ImageCfg e -> Maybe Double
_imcFactorW :: Maybe Double,
  ImageCfg e -> Maybe Double
_imcFactorH :: Maybe Double
}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

data ImageSource
  = ImageMem Text
  | ImagePath Text
  deriving (ImageSource -> ImageSource -> Bool
(ImageSource -> ImageSource -> Bool)
-> (ImageSource -> ImageSource -> Bool) -> Eq ImageSource
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 -> String
(Int -> ImageSource -> ShowS)
-> (ImageSource -> String)
-> ([ImageSource] -> ShowS)
-> Show ImageSource
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ImageSource] -> ShowS
$cshowList :: [ImageSource] -> ShowS
show :: ImageSource -> String
$cshow :: ImageSource -> String
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
(ImageState -> ImageState -> Bool)
-> (ImageState -> ImageState -> Bool) -> Eq ImageState
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 -> String
(Int -> ImageState -> ShowS)
-> (ImageState -> String)
-> ([ImageState] -> ShowS)
-> Show ImageState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ImageState] -> ShowS
$cshowList :: [ImageState] -> ShowS
show :: ImageState -> String
$cshow :: ImageState -> String
showsPrec :: Int -> ImageState -> ShowS
$cshowsPrec :: Int -> ImageState -> ShowS
Show, (forall x. ImageState -> Rep ImageState x)
-> (forall x. Rep ImageState x -> ImageState) -> Generic ImageState
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 -> WidgetNode s e
image :: Text -> WidgetNode s e
image Text
path = Text -> [ImageCfg e] -> WidgetNode s e
forall e s. WidgetEvent e => Text -> [ImageCfg e] -> WidgetNode s e
image_ Text
path [ImageCfg e]
forall a. Default a => a
def

-- | Creates an image with the given local path or url. Accepts config.
image_ :: WidgetEvent e => Text -> [ImageCfg e] -> WidgetNode s e
image_ :: Text -> [ImageCfg e] -> WidgetNode s e
image_ Text
path [ImageCfg e]
configs = WidgetType -> Widget s e -> WidgetNode s e
forall s e. WidgetType -> Widget s e -> WidgetNode s e
defaultWidgetNode WidgetType
"image" Widget s e
forall s. Widget s e
widget where
  config :: ImageCfg e
config = [ImageCfg e] -> ImageCfg e
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 Maybe (ByteString, Size)
forall a. Maybe a
Nothing
  widget :: Widget s e
widget = ImageSource -> ImageCfg e -> ImageState -> Widget s e
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 :: Text -> ByteString -> Size -> WidgetNode s e
imageMem Text
name ByteString
imgData Size
imgSize = Text -> ByteString -> Size -> [ImageCfg e] -> WidgetNode s e
forall e s.
WidgetEvent e =>
Text -> ByteString -> Size -> [ImageCfg e] -> WidgetNode s e
imageMem_ Text
name ByteString
imgData Size
imgSize [ImageCfg e]
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_ :: Text -> ByteString -> Size -> [ImageCfg e] -> WidgetNode s e
imageMem_ Text
name ByteString
imgData Size
imgSize [ImageCfg e]
configs = WidgetType -> Widget s e -> WidgetNode s e
forall s e. WidgetType -> Widget s e -> WidgetNode s e
defaultWidgetNode WidgetType
"image" Widget s e
forall s. Widget s e
widget where
  config :: ImageCfg e
config = [ImageCfg e] -> ImageCfg e
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 ((ByteString, Size) -> Maybe (ByteString, Size)
forall a. a -> Maybe a
Just (ByteString
imgData, Size
imgSize))
  widget :: Widget s e
widget = ImageSource -> ImageCfg e -> ImageState -> Widget s e
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 :: ImageSource -> ImageCfg e -> ImageState -> Widget s e
makeImage !ImageSource
imgSource !ImageCfg e
config !ImageState
state = Widget s e
forall s. Widget s e
widget where
  widget :: Widget s e
widget = ImageState -> Single s e ImageState -> Widget s e
forall a s e. WidgetModel a => a -> Single s e a -> Widget s e
createSingle ImageState
state Single s e Any
forall a. Default a => a
def {
    singleUseScissor :: Bool
singleUseScissor = Bool
True,
    singleInit :: SingleInitHandler s e
singleInit = SingleInitHandler s e
forall s s e. WidgetEnv s e -> WidgetNode s e -> WidgetResult s e
init,
    singleMerge :: SingleMergeHandler s e ImageState
singleMerge = SingleMergeHandler s e ImageState
forall s s p.
WidgetEnv s e
-> WidgetNode s e -> p -> ImageState -> WidgetResult s e
merge,
    singleDispose :: SingleInitHandler s e
singleDispose = SingleInitHandler s e
forall s e s e. WidgetEnv s e -> WidgetNode s e -> WidgetResult s e
dispose,
    singleHandleMessage :: SingleMessageHandler s e
singleHandleMessage = SingleMessageHandler s e
forall a p s p.
Typeable a =>
p -> WidgetNode s e -> p -> a -> Maybe (WidgetResult s e)
handleMessage,
    singleGetSizeReq :: SingleGetSizeReqHandler s e
singleGetSizeReq = SingleGetSizeReqHandler s e
forall p p. p -> p -> (SizeReq, SizeReq)
getSizeReq,
    singleRender :: SingleRenderHandler s e
singleRender = SingleRenderHandler s e
forall s e. WidgetEnv s e -> WidgetNode s e -> Renderer -> IO ()
render
  }

  !isImageMem :: Bool
isImageMem = case ImageSource
imgSource 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 WidgetNode s e
-> Getting WidgetId (WidgetNode s e) WidgetId -> WidgetId
forall s a. s -> Getting a s a -> a
^. (WidgetNodeInfo -> Const WidgetId WidgetNodeInfo)
-> WidgetNode s e -> Const WidgetId (WidgetNode s e)
forall s a. HasInfo s a => Lens' s a
L.info ((WidgetNodeInfo -> Const WidgetId WidgetNodeInfo)
 -> WidgetNode s e -> Const WidgetId (WidgetNode s e))
-> ((WidgetId -> Const WidgetId WidgetId)
    -> WidgetNodeInfo -> Const WidgetId WidgetNodeInfo)
-> Getting WidgetId (WidgetNode s e) WidgetId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WidgetId -> Const WidgetId WidgetId)
-> WidgetNodeInfo -> Const WidgetId WidgetNodeInfo
forall s a. HasWidgetId s a => Lens' s a
L.widgetId
    path :: Path
path = WidgetNode s e
node WidgetNode s e -> Getting Path (WidgetNode s e) Path -> Path
forall s a. s -> Getting a s a -> a
^. (WidgetNodeInfo -> Const Path WidgetNodeInfo)
-> WidgetNode s e -> Const Path (WidgetNode s e)
forall s a. HasInfo s a => Lens' s a
L.info ((WidgetNodeInfo -> Const Path WidgetNodeInfo)
 -> WidgetNode s e -> Const Path (WidgetNode s e))
-> ((Path -> Const Path Path)
    -> WidgetNodeInfo -> Const Path WidgetNodeInfo)
-> Getting Path (WidgetNode s e) Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Path -> Const Path Path)
-> WidgetNodeInfo -> Const Path WidgetNodeInfo
forall s a. HasPath s a => Lens' s a
L.path
    imgPath :: Text
imgPath = ImageSource -> Text
imgName ImageSource
imgSource

    reqs :: [WidgetRequest s e]
reqs = [WidgetId -> Path -> IO ImageMessage -> WidgetRequest s e
forall s e i.
Typeable i =>
WidgetId -> Path -> IO i -> WidgetRequest s e
RunTask WidgetId
wid Path
path (IO ImageMessage -> WidgetRequest s e)
-> IO ImageMessage -> WidgetRequest s e
forall a b. (a -> b) -> a -> b
$ ImageCfg e -> WidgetEnv s e -> Text -> IO ImageMessage
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
_ -> WidgetNode s e -> WidgetResult s e
forall s e. WidgetNode s e -> WidgetResult s e
resultNode WidgetNode s e
node
      ImagePath Text
_ -> WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
forall s e.
WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
resultReqs WidgetNode s e
node [WidgetRequest s e]
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 WidgetNode s e
-> Getting WidgetId (WidgetNode s e) WidgetId -> WidgetId
forall s a. s -> Getting a s a -> a
^. (WidgetNodeInfo -> Const WidgetId WidgetNodeInfo)
-> WidgetNode s e -> Const WidgetId (WidgetNode s e)
forall s a. HasInfo s a => Lens' s a
L.info ((WidgetNodeInfo -> Const WidgetId WidgetNodeInfo)
 -> WidgetNode s e -> Const WidgetId (WidgetNode s e))
-> ((WidgetId -> Const WidgetId WidgetId)
    -> WidgetNodeInfo -> Const WidgetId WidgetNodeInfo)
-> Getting WidgetId (WidgetNode s e) WidgetId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WidgetId -> Const WidgetId WidgetId)
-> WidgetNodeInfo -> Const WidgetId WidgetNodeInfo
forall s a. HasWidgetId s a => Lens' s a
L.widgetId
    path :: Path
path = WidgetNode s e
newNode WidgetNode s e -> Getting Path (WidgetNode s e) Path -> Path
forall s a. s -> Getting a s a -> a
^. (WidgetNodeInfo -> Const Path WidgetNodeInfo)
-> WidgetNode s e -> Const Path (WidgetNode s e)
forall s a. HasInfo s a => Lens' s a
L.info ((WidgetNodeInfo -> Const Path WidgetNodeInfo)
 -> WidgetNode s e -> Const Path (WidgetNode s e))
-> ((Path -> Const Path Path)
    -> WidgetNodeInfo -> Const Path WidgetNodeInfo)
-> Getting Path (WidgetNode s e) Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Path -> Const Path Path)
-> WidgetNodeInfo -> Const Path WidgetNodeInfo
forall s a. HasPath s a => Lens' s a
L.path
    oldSource :: ImageSource
oldSource = ImageState -> ImageSource
isImageSource ImageState
oldState
    imgPath :: Text
imgPath = ImageSource -> Text
imgName ImageSource
imgSource
    prevPath :: Text
prevPath = ImageSource -> Text
imgName ImageSource
oldSource

    sameImgNode :: WidgetNode s e
sameImgNode = WidgetNode s e
newNode
      WidgetNode s e
-> (WidgetNode s e -> WidgetNode s e) -> WidgetNode s e
forall a b. a -> (a -> b) -> b
& (Widget s e -> Identity (Widget s e))
-> WidgetNode s e -> Identity (WidgetNode s e)
forall s a. HasWidget s a => Lens' s a
L.widget ((Widget s e -> Identity (Widget s e))
 -> WidgetNode s e -> Identity (WidgetNode s e))
-> Widget s e -> WidgetNode s e -> WidgetNode s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ImageSource -> ImageCfg e -> ImageState -> Widget s e
forall e s.
WidgetEvent e =>
ImageSource -> ImageCfg e -> ImageState -> Widget s e
makeImage ImageSource
imgSource ImageCfg e
config ImageState
oldState
    newMemReqs :: [WidgetRequest s e]
newMemReqs = [ Text -> WidgetRequest s e
forall s e. Text -> WidgetRequest s e
RemoveRendererImage Text
prevPath ]
    newImgReqs :: [WidgetRequest s e]
newImgReqs = [
        Text -> WidgetRequest s e
forall s e. Text -> WidgetRequest s e
RemoveRendererImage Text
prevPath,
        WidgetId -> Path -> IO ImageMessage -> WidgetRequest s e
forall s e i.
Typeable i =>
WidgetId -> Path -> IO i -> WidgetRequest s e
RunTask WidgetId
wid Path
path (ImageCfg e -> WidgetEnv s e -> Text -> IO ImageMessage
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
      | ImageSource
oldSource ImageSource -> ImageSource -> Bool
forall a. Eq a => a -> a -> Bool
== ImageSource
imgSource = WidgetNode s e -> WidgetResult s e
forall s e. WidgetNode s e -> WidgetResult s e
resultNode WidgetNode s e
sameImgNode
      | Bool
isImageMem = WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
forall s e.
WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
resultReqs WidgetNode s e
newNode [WidgetRequest s e]
forall s e. [WidgetRequest s e]
newMemReqs
      | Bool
otherwise = WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
forall s e.
WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
resultReqs WidgetNode s e
newNode [WidgetRequest s e]
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 = WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
forall s e.
WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
resultReqs WidgetNode s e
node [WidgetRequest s e]
forall s e. [WidgetRequest s e]
reqs where
    wid :: WidgetId
wid = WidgetNode s e
node WidgetNode s e
-> Getting WidgetId (WidgetNode s e) WidgetId -> WidgetId
forall s a. s -> Getting a s a -> a
^. (WidgetNodeInfo -> Const WidgetId WidgetNodeInfo)
-> WidgetNode s e -> Const WidgetId (WidgetNode s e)
forall s a. HasInfo s a => Lens' s a
L.info ((WidgetNodeInfo -> Const WidgetId WidgetNodeInfo)
 -> WidgetNode s e -> Const WidgetId (WidgetNode s e))
-> ((WidgetId -> Const WidgetId WidgetId)
    -> WidgetNodeInfo -> Const WidgetId WidgetNodeInfo)
-> Getting WidgetId (WidgetNode s e) WidgetId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WidgetId -> Const WidgetId WidgetId)
-> WidgetNodeInfo -> Const WidgetId WidgetNodeInfo
forall s a. HasWidgetId s a => Lens' s a
L.widgetId
    path :: Path
path = WidgetNode s e
node WidgetNode s e -> Getting Path (WidgetNode s e) Path -> Path
forall s a. s -> Getting a s a -> a
^. (WidgetNodeInfo -> Const Path WidgetNodeInfo)
-> WidgetNode s e -> Const Path (WidgetNode s e)
forall s a. HasInfo s a => Lens' s a
L.info ((WidgetNodeInfo -> Const Path WidgetNodeInfo)
 -> WidgetNode s e -> Const Path (WidgetNode s e))
-> ((Path -> Const Path Path)
    -> WidgetNodeInfo -> Const Path WidgetNodeInfo)
-> Getting Path (WidgetNode s e) Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Path -> Const Path Path)
-> WidgetNodeInfo -> Const Path WidgetNodeInfo
forall s a. HasPath s a => Lens' s a
L.path
    imgPath :: Text
imgPath = ImageSource -> Text
imgName ImageSource
imgSource
    reqs :: [WidgetRequest s e]
reqs = [
        Text -> WidgetRequest s e
forall s e. Text -> WidgetRequest s e
RemoveRendererImage Text
imgPath,
        WidgetId -> Path -> IO () -> WidgetRequest s e
forall s e i.
Typeable i =>
WidgetId -> Path -> IO i -> WidgetRequest s e
RunTask WidgetId
wid Path
path (WidgetEnv s e -> Text -> IO ()
forall s e. WidgetEnv s e -> Text -> IO ()
handleImageDispose WidgetEnv s e
wenv Text
imgPath)
      ]

  handleMessage :: p -> WidgetNode s e -> p -> a -> Maybe (WidgetResult s e)
handleMessage p
wenv WidgetNode s e
node p
target a
message = Maybe (WidgetResult s e)
result where
    result :: Maybe (WidgetResult s e)
result = a -> Maybe ImageMessage
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
message Maybe ImageMessage
-> (ImageMessage -> Maybe (WidgetResult s e))
-> Maybe (WidgetResult s e)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= WidgetNode s e -> ImageMessage -> Maybe (WidgetResult s e)
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 = ((ImageLoadError -> e) -> e) -> [ImageLoadError -> e] -> [e]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ImageLoadError -> e) -> ImageLoadError -> e
forall a b. (a -> b) -> a -> b
$ ImageLoadError
msg) (ImageCfg e -> [ImageLoadError -> e]
forall e. ImageCfg e -> [ImageLoadError -> e]
_imcLoadError ImageCfg e
config)
    result :: Maybe (WidgetResult s e)
result = WidgetResult s e -> Maybe (WidgetResult s e)
forall a. a -> Maybe a
Just (WidgetResult s e -> Maybe (WidgetResult s e))
-> WidgetResult s e -> Maybe (WidgetResult s e)
forall a b. (a -> b) -> a -> b
$ WidgetNode s e -> [e] -> WidgetResult s e
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 WidgetNode s e
-> Getting WidgetId (WidgetNode s e) WidgetId -> WidgetId
forall s a. s -> Getting a s a -> a
^. (WidgetNodeInfo -> Const WidgetId WidgetNodeInfo)
-> WidgetNode s e -> Const WidgetId (WidgetNode s e)
forall s a. HasInfo s a => Lens' s a
L.info ((WidgetNodeInfo -> Const WidgetId WidgetNodeInfo)
 -> WidgetNode s e -> Const WidgetId (WidgetNode s e))
-> ((WidgetId -> Const WidgetId WidgetId)
    -> WidgetNodeInfo -> Const WidgetId WidgetNodeInfo)
-> Getting WidgetId (WidgetNode s e) WidgetId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WidgetId -> Const WidgetId WidgetId)
-> WidgetNodeInfo -> Const WidgetId WidgetNodeInfo
forall s a. HasWidgetId s a => Lens' s a
L.widgetId
    newNode :: WidgetNode s e
newNode = WidgetNode s e
node
      WidgetNode s e
-> (WidgetNode s e -> WidgetNode s e) -> WidgetNode s e
forall a b. a -> (a -> b) -> b
& (Widget s e -> Identity (Widget s e))
-> WidgetNode s e -> Identity (WidgetNode s e)
forall s a. HasWidget s a => Lens' s a
L.widget ((Widget s e -> Identity (Widget s e))
 -> WidgetNode s e -> Identity (WidgetNode s e))
-> Widget s e -> WidgetNode s e -> WidgetNode s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ImageSource -> ImageCfg e -> ImageState -> Widget s e
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 = WidgetResult s e -> Maybe (WidgetResult s e)
forall a. a -> Maybe a
Just (WidgetResult s e -> Maybe (WidgetResult s e))
-> WidgetResult s e -> Maybe (WidgetResult s e)
forall a b. (a -> b) -> a -> b
$ WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
forall s e.
WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
resultReqs WidgetNode s e
newNode [WidgetId -> WidgetRequest s e
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 = Size
-> ((ByteString, Size) -> Size) -> Maybe (ByteString, Size) -> Size
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Size
forall a. Default a => a
def (ByteString, Size) -> Size
forall a b. (a, b) -> b
snd (ImageState -> Maybe (ByteString, Size)
isImageData ImageState
state)
    factorW :: Double
factorW = Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
1 (ImageCfg e -> Maybe Double
forall e. ImageCfg e -> Maybe Double
_imcFactorW ImageCfg e
config)
    factorH :: Double
factorH = Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
1 (ImageCfg e -> Maybe Double
forall e. ImageCfg e -> Maybe Double
_imcFactorH ImageCfg e
config)

    sizeW :: SizeReq
sizeW
      | Double -> Double
forall a. Num a => a -> a
abs Double
factorW Double -> Double -> Bool
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
      | Double -> Double
forall a. Num a => a -> a
abs Double
factorH Double -> Double -> Bool
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

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

    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
imageLoaded (IO () -> IO ()) -> IO () -> IO ()
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 = WidgetEnv s e -> WidgetNode s e -> StyleState
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 StyleState
-> Getting (Maybe Border) StyleState (Maybe Border) -> Maybe Border
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Border) StyleState (Maybe Border)
forall s a. HasBorder s a => Lens' s a
L.border
      radius :: Maybe Radius
radius = StyleState
style StyleState
-> Getting (Maybe Radius) StyleState (Maybe Radius) -> Maybe Radius
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Radius) StyleState (Maybe Radius)
forall s a. HasRadius s a => Lens' s a
L.radius
      carea :: Rect
carea = WidgetNode s e -> StyleState -> Rect
forall s e. WidgetNode s e -> StyleState -> Rect
getContentArea WidgetNode s e
node StyleState
style

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

      imgPath :: Text
imgPath = ImageSource -> Text
imgName ImageSource
imgSource
      imgFlags :: [ImageFlag]
imgFlags = ImageCfg e -> [ImageFlag]
forall e. ImageCfg e -> [ImageFlag]
_imcFlags ImageCfg e
config
      imgFit :: ImageFit
imgFit = ImageFit -> Maybe ImageFit -> ImageFit
forall a. a -> Maybe a -> a
fromMaybe ImageFit
FitNone (ImageCfg e -> Maybe ImageFit
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 (Radius -> Radius) -> Maybe Radius -> Maybe Radius
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 = Maybe (ByteString, Size) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (ByteString, Size)
imgData
      (ByteString
imgBytes, Size
imgSize) = Maybe (ByteString, Size) -> (ByteString, Size)
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 =
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Rect -> Bool
forall a. Maybe a -> Bool
isJust Maybe Rect
targetRect) (IO () -> IO ()) -> IO () -> IO ()
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 (Maybe Rect -> Rect
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Rect
targetRect) (Radius -> Maybe Radius -> Radius
forall a. a -> Maybe a -> a
fromMaybe Radius
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 ImageFlag -> [ImageFlag] -> Bool
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 ImageFlag -> [ImageFlag] -> Bool
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
    | ImageFlag
ImageRepeatY ImageFlag -> [ImageFlag] -> Bool
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 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
ih Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
iw)
  ImageFit
FitHeight
    | ImageFlag
ImageRepeatX ImageFlag -> [ImageFlag] -> Bool
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 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
iw Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
ih) Double
h
  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

handleImageLoad :: ImageCfg e -> WidgetEnv s e -> Text -> IO ImageMessage
handleImageLoad :: 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) <- MVar (Map Text WidgetShared) -> IO (Map Text WidgetShared)
forall a. MVar a -> IO a
takeMVar MVar (Map Text WidgetShared)
sharedMapMVar IO (Map Text WidgetShared)
-> (Map Text WidgetShared -> IO (Map Text WidgetShared, Session))
-> IO (Map Text WidgetShared, Session)
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 Maybe WidgetShared -> Maybe (MVar (Maybe (ImageState, Int)))
forall i. Typeable i => Maybe WidgetShared -> Maybe i
useShared (Text -> Map Text WidgetShared -> Maybe WidgetShared
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 -> MVar (Maybe (ImageState, Int))
-> IO (MVar (Maybe (ImageState, Int)))
forall (m :: * -> *) a. Monad m => a -> m a
return MVar (Maybe (ImageState, Int))
mvar
    Maybe (MVar (Maybe (ImageState, Int)))
Nothing -> Maybe (ImageState, Int) -> IO (MVar (Maybe (ImageState, Int)))
forall a. a -> IO (MVar a)
newMVar Maybe (ImageState, Int)
emptyImgState
  MVar (Map Text WidgetShared) -> Map Text WidgetShared -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Map Text WidgetShared)
sharedMapMVar (Map Text WidgetShared
sharedMap Map Text WidgetShared
-> (Map Text WidgetShared -> Map Text WidgetShared)
-> Map Text WidgetShared
forall a b. a -> (a -> b) -> b
& Index (Map Text WidgetShared)
-> Lens'
     (Map Text WidgetShared) (Maybe (IxValue (Map Text WidgetShared)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Text
Index (Map Text WidgetShared)
key ((Maybe WidgetShared -> Identity (Maybe WidgetShared))
 -> Map Text WidgetShared -> Identity (Map Text WidgetShared))
-> WidgetShared -> Map Text WidgetShared -> Map Text WidgetShared
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ MVar (Maybe (ImageState, Int)) -> WidgetShared
forall i. Typeable i => i -> WidgetShared
WidgetShared MVar (Maybe (ImageState, Int))
sharedImgMVar)

  -- Take the image's MVar until done
  Maybe (ImageState, Int)
sharedImg <- MVar (Maybe (ImageState, Int)) -> IO (Maybe (ImageState, Int))
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
      (ImageMessage, Maybe (ImageState, Int))
-> IO (ImageMessage, Maybe (ImageState, Int))
forall (m :: * -> *) a. Monad m => a -> m a
return (ImageState -> ImageMessage
ImageLoaded ImageState
oldState, (ImageState, Int) -> Maybe (ImageState, Int)
forall a. a -> Maybe a
Just (ImageState
oldState, Int
oldCount Int -> Int -> Int
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 Either ImageLoadError ByteString
-> (ByteString -> Either ImageLoadError DynamicImage)
-> Either ImageLoadError DynamicImage
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Either ImageLoadError DynamicImage
decodeImage of
        Left ImageLoadError
loadError -> (ImageMessage, Maybe (ImageState, Int))
-> IO (ImageMessage, Maybe (ImageState, Int))
forall (m :: * -> *) a. Monad m => a -> m a
return (ImageLoadError -> ImageMessage
ImageFailed ImageLoadError
loadError, Maybe (ImageState, Int)
forall a. Maybe a
Nothing)
        Right DynamicImage
dimg -> do
          let newState :: ImageState
newState = ImageCfg e -> WidgetEnv s e -> Text -> DynamicImage -> ImageState
forall e s.
ImageCfg e -> WidgetEnv s e -> Text -> DynamicImage -> ImageState
makeImgState ImageCfg e
config WidgetEnv s e
wenv Text
path DynamicImage
dimg
          (ImageMessage, Maybe (ImageState, Int))
-> IO (ImageMessage, Maybe (ImageState, Int))
forall (m :: * -> *) a. Monad m => a -> m a
return (ImageState -> ImageMessage
ImageLoaded ImageState
newState, (ImageState, Int) -> Maybe (ImageState, Int)
forall a. a -> Maybe a
Just (ImageState
newState, Int
1))

  MVar (Maybe (ImageState, Int)) -> Maybe (ImageState, Int) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Maybe (ImageState, Int))
sharedImgMVar Maybe (ImageState, Int)
newSharedImg
  ImageMessage -> IO ImageMessage
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 WidgetEnv s e
-> Getting
     (MVar (Map Text WidgetShared))
     (WidgetEnv s e)
     (MVar (Map Text WidgetShared))
-> MVar (Map Text WidgetShared)
forall s a. s -> Getting a s a -> a
^. Getting
  (MVar (Map Text WidgetShared))
  (WidgetEnv s e)
  (MVar (Map Text WidgetShared))
forall s a. HasWidgetShared s a => Lens' s a
L.widgetShared
    emptyImgState :: Maybe (ImageState, Int)
    emptyImgState :: Maybe (ImageState, Int)
emptyImgState = Maybe (ImageState, Int)
forall a. Maybe a
Nothing

handleImageDispose :: WidgetEnv s e -> Text -> IO ()
handleImageDispose :: WidgetEnv s e -> Text -> IO ()
handleImageDispose WidgetEnv s e
wenv Text
path = do
  Map Text WidgetShared
sharedMap <- MVar (Map Text WidgetShared) -> IO (Map Text WidgetShared)
forall a. MVar a -> IO a
takeMVar MVar (Map Text WidgetShared)
sharedMapMVar
  Map Text WidgetShared
newSharedMap <- case Maybe WidgetShared -> Maybe (MVar (Maybe (ImageState, Int)))
forall i. Typeable i => Maybe WidgetShared -> Maybe i
useShared (Text -> Map Text WidgetShared -> Maybe WidgetShared
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 <- MVar (Maybe (ImageState, Int)) -> IO (Maybe (ImageState, Int))
forall a. MVar a -> IO a
takeMVar MVar (Maybe (ImageState, Int))
mvar
      Map Text WidgetShared -> IO (Map Text WidgetShared)
forall (m :: * -> *) a. Monad m => a -> m a
return (Map Text WidgetShared -> IO (Map Text WidgetShared))
-> Map Text WidgetShared -> IO (Map Text WidgetShared)
forall a b. (a -> b) -> a -> b
$ case Maybe (ImageState, Int)
sharedImg of
        Just (ImageState
oldState :: ImageState, Int
oldCount :: Int)
          | Int
oldCount Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 ->
              Map Text WidgetShared
sharedMap Map Text WidgetShared
-> (Map Text WidgetShared -> Map Text WidgetShared)
-> Map Text WidgetShared
forall a b. a -> (a -> b) -> b
& Index (Map Text WidgetShared)
-> Lens'
     (Map Text WidgetShared) (Maybe (IxValue (Map Text WidgetShared)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Text
Index (Map Text WidgetShared)
key ((Maybe WidgetShared -> Identity (Maybe WidgetShared))
 -> Map Text WidgetShared -> Identity (Map Text WidgetShared))
-> WidgetShared -> Map Text WidgetShared -> Map Text WidgetShared
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ (ImageState, Int) -> WidgetShared
forall i. Typeable i => i -> WidgetShared
WidgetShared (ImageState
oldState, Int
oldCount Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
        Maybe (ImageState, Int)
_ -> Map Text WidgetShared
sharedMap Map Text WidgetShared
-> (Map Text WidgetShared -> Map Text WidgetShared)
-> Map Text WidgetShared
forall a b. a -> (a -> b) -> b
& Index (Map Text WidgetShared)
-> Lens'
     (Map Text WidgetShared) (Maybe (IxValue (Map Text WidgetShared)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Text
Index (Map Text WidgetShared)
key ((Maybe WidgetShared -> Identity (Maybe WidgetShared))
 -> Map Text WidgetShared -> Identity (Map Text WidgetShared))
-> Maybe WidgetShared
-> Map Text WidgetShared
-> Map Text WidgetShared
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Maybe WidgetShared
forall a. Maybe a
Nothing
    Maybe (MVar (Maybe (ImageState, Int)))
Nothing -> Map Text WidgetShared -> IO (Map Text WidgetShared)
forall (m :: * -> *) a. Monad m => a -> m a
return Map Text WidgetShared
sharedMap
  MVar (Map Text WidgetShared) -> Map Text WidgetShared -> IO ()
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 WidgetEnv s e
-> Getting
     (MVar (Map Text WidgetShared))
     (WidgetEnv s e)
     (MVar (Map Text WidgetShared))
-> MVar (Map Text WidgetShared)
forall s a. s -> Getting a s a -> a
^. Getting
  (MVar (Map Text WidgetShared))
  (WidgetEnv s e)
  (MVar (Map Text WidgetShared))
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-" Text -> Text -> Text
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 = (String -> Either ImageLoadError DynamicImage)
-> (DynamicImage -> Either ImageLoadError DynamicImage)
-> Either String DynamicImage
-> Either ImageLoadError DynamicImage
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ImageLoadError -> Either ImageLoadError DynamicImage
forall a b. a -> Either a b
Left (ImageLoadError -> Either ImageLoadError DynamicImage)
-> (String -> ImageLoadError)
-> String
-> Either ImageLoadError DynamicImage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ImageLoadError
ImageInvalid) DynamicImage -> Either ImageLoadError DynamicImage
forall a b. b -> Either a b
Right (ByteString -> Either String DynamicImage
Pic.decodeImage ByteString
bs)

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

  if ByteString -> Int
BS.length ByteString
content Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
    then Either ImageLoadError ByteString
-> IO (Either ImageLoadError ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ImageLoadError ByteString
 -> IO (Either ImageLoadError ByteString))
-> (String -> Either ImageLoadError ByteString)
-> String
-> IO (Either ImageLoadError ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImageLoadError -> Either ImageLoadError ByteString
forall a b. a -> Either a b
Left (ImageLoadError -> Either ImageLoadError ByteString)
-> (String -> ImageLoadError)
-> String
-> Either ImageLoadError ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ImageLoadError
ImageLoadFailed (String -> IO (Either ImageLoadError ByteString))
-> String -> IO (Either ImageLoadError ByteString)
forall a b. (a -> b) -> a -> b
$ String
"Failed to load: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
path
    else Either ImageLoadError ByteString
-> IO (Either ImageLoadError ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ImageLoadError ByteString
 -> IO (Either ImageLoadError ByteString))
-> (ByteString -> Either ImageLoadError ByteString)
-> ByteString
-> IO (Either ImageLoadError ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either ImageLoadError ByteString
forall a b. b -> Either a b
Right (ByteString -> IO (Either ImageLoadError ByteString))
-> ByteString -> IO (Either ImageLoadError ByteString)
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 :: String
path = Text -> String
T.unpack Text
name
  Either HttpException (Response ByteString)
eresp <- IO (Response ByteString)
-> IO (Either HttpException (Response ByteString))
forall e a. Exception e => IO a -> IO (Either e a)
try (IO (Response ByteString)
 -> IO (Either HttpException (Response ByteString)))
-> IO (Response ByteString)
-> IO (Either HttpException (Response ByteString))
forall a b. (a -> b) -> a -> b
$ String -> IO (Response ByteString)
getUrl String
path

  Either ImageLoadError ByteString
-> IO (Either ImageLoadError ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ImageLoadError ByteString
 -> IO (Either ImageLoadError ByteString))
-> Either ImageLoadError ByteString
-> IO (Either ImageLoadError ByteString)
forall a b. (a -> b) -> a -> b
$ case Either HttpException (Response ByteString)
eresp of
    Left HttpException
e -> String -> HttpException -> Either ImageLoadError ByteString
remoteException String
path HttpException
e
    Right Response ByteString
r -> ByteString -> Either ImageLoadError ByteString
forall a b. b -> Either a b
Right (ByteString -> Either ImageLoadError ByteString)
-> ByteString -> Either ImageLoadError ByteString
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 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Response ByteString
r Response ByteString
-> Getting ByteString (Response ByteString) ByteString
-> ByteString
forall s a. s -> Getting a s a -> a
^. Getting ByteString (Response ByteString) ByteString
forall body0 body1.
Lens (Response body0) (Response body1) body0 body1
responseBody
    getUrl :: String -> IO (Response ByteString)
getUrl = Options -> Session -> String -> IO (Response ByteString)
Sess.getWith (Options
defaults Options -> (Options -> Options) -> Options
forall a b. a -> (a -> b) -> b
& (Maybe ResponseChecker -> Identity (Maybe ResponseChecker))
-> Options -> Identity Options
Lens' Options (Maybe ResponseChecker)
checkResponse ((Maybe ResponseChecker -> Identity (Maybe ResponseChecker))
 -> Options -> Identity Options)
-> ResponseChecker -> Options -> Options
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ (\Request
_ Response (IO ByteString)
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())) Session
sess

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

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

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

makeImgState
  :: ImageCfg e
  -> WidgetEnv s e
  -> Text
  -> DynamicImage
  -> ImageState
makeImgState :: 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 = Image PixelRGBA8 -> Int
forall a. Image a -> Int
imageWidth Image PixelRGBA8
img
  ch :: Int
ch = Image PixelRGBA8 -> Int
forall a. Image a -> Int
imageHeight Image PixelRGBA8
img
  size :: Size
size = Double -> Double -> Size
Size (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
cw) (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ch)
  bs :: ByteString
bs = Vector Word8 -> ByteString
forall a. Storable a => Vector a -> ByteString
vectorToByteString (Vector Word8 -> ByteString) -> Vector Word8 -> ByteString
forall a b. (a -> b) -> a -> b
$ Image PixelRGBA8 -> Vector (PixelBaseComponent PixelRGBA8)
forall a. Image a -> Vector (PixelBaseComponent a)
imageData Image PixelRGBA8
img
  newState :: ImageState
newState = ImageState :: ImageSource -> Maybe (ByteString, Size) -> ImageState
ImageState {
    isImageSource :: ImageSource
isImageSource = Text -> ImageSource
ImagePath Text
name,
    isImageData :: Maybe (ByteString, Size)
isImageData = (ByteString, Size) -> Maybe (ByteString, Size)
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 Maybe WidgetShared -> Maybe Session
forall i. Typeable i => Maybe WidgetShared -> Maybe i
useShared (Text -> Map Text WidgetShared -> Maybe WidgetShared
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
key Map Text WidgetShared
sharedMap) of
  Just Session
sess -> (Map Text WidgetShared, Session)
-> IO (Map Text WidgetShared, Session)
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
    (Map Text WidgetShared, Session)
-> IO (Map Text WidgetShared, Session)
forall (m :: * -> *) a. Monad m => a -> m a
return (Map Text WidgetShared
sharedMap Map Text WidgetShared
-> (Map Text WidgetShared -> Map Text WidgetShared)
-> Map Text WidgetShared
forall a b. a -> (a -> b) -> b
& Index (Map Text WidgetShared)
-> Lens'
     (Map Text WidgetShared) (Maybe (IxValue (Map Text WidgetShared)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Text
Index (Map Text WidgetShared)
key ((Maybe WidgetShared -> Identity (Maybe WidgetShared))
 -> Map Text WidgetShared -> Identity (Map Text WidgetShared))
-> WidgetShared -> Map Text WidgetShared -> Map Text WidgetShared
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Session -> WidgetShared
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