{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Monomer.Widgets.Singles.Icon (
IconCfg,
IconType(..),
icon,
icon_
) where
import Control.Lens ((^.))
import Control.Applicative ((<|>))
import Data.Default
import Data.Maybe
import qualified Data.Text as T
import Monomer.Graphics.Util
import Monomer.Widgets.Single
import qualified Monomer.Lens as L
data IconType
= IconClose
| IconPlus
| IconMinus
deriving (IconType -> IconType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IconType -> IconType -> Bool
$c/= :: IconType -> IconType -> Bool
== :: IconType -> IconType -> Bool
$c== :: IconType -> IconType -> Bool
Eq, Int -> IconType -> ShowS
[IconType] -> ShowS
IconType -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IconType] -> ShowS
$cshowList :: [IconType] -> ShowS
show :: IconType -> String
$cshow :: IconType -> String
showsPrec :: Int -> IconType -> ShowS
$cshowsPrec :: Int -> IconType -> ShowS
Show)
newtype IconCfg = IconCfg {
IconCfg -> Maybe Double
_icWidth :: Maybe Double
}
instance Default IconCfg where
def :: IconCfg
def = IconCfg {
_icWidth :: Maybe Double
_icWidth = forall a. Maybe a
Nothing
}
instance Semigroup IconCfg where
<> :: IconCfg -> IconCfg -> IconCfg
(<>) IconCfg
i1 IconCfg
i2 = IconCfg {
_icWidth :: Maybe Double
_icWidth = IconCfg -> Maybe Double
_icWidth IconCfg
i2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> IconCfg -> Maybe Double
_icWidth IconCfg
i1
}
instance Monoid IconCfg where
mempty :: IconCfg
mempty = forall a. Default a => a
def
instance CmbWidth IconCfg where
width :: Double -> IconCfg
width Double
w = forall a. Default a => a
def {
_icWidth :: Maybe Double
_icWidth = forall a. a -> Maybe a
Just Double
w
}
icon
:: IconType
-> WidgetNode s e
icon :: forall s e. IconType -> WidgetNode s e
icon IconType
iconType = forall s e. IconType -> [IconCfg] -> WidgetNode s e
icon_ IconType
iconType forall a. Default a => a
def
icon_
:: IconType
-> [IconCfg]
-> WidgetNode s e
icon_ :: forall s e. IconType -> [IconCfg] -> WidgetNode s e
icon_ IconType
iconType [IconCfg]
configs = forall s e. WidgetType -> Widget s e -> WidgetNode s e
defaultWidgetNode WidgetType
widgetType forall {s} {e}. Widget s e
widget where
iconName :: Text
iconName = String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show IconType
iconType
widgetType :: WidgetType
widgetType = Text -> WidgetType
WidgetType (Text
"i" forall a. Semigroup a => a -> a -> a
<> Text -> Text
T.tail Text
iconName)
config :: IconCfg
config = forall a. Monoid a => [a] -> a
mconcat [IconCfg]
configs
widget :: Widget s e
widget = forall s e. IconType -> IconCfg -> Widget s e
makeImage IconType
iconType IconCfg
config
makeImage :: IconType -> IconCfg -> Widget s e
makeImage :: forall s e. IconType -> IconCfg -> Widget s e
makeImage IconType
iconType IconCfg
config = forall {s} {e}. 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 () forall a. Default a => a
def {
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
}
getSizeReq :: p -> p -> (SizeReq, SizeReq)
getSizeReq p
wenv p
node = (SizeReq, SizeReq)
sizeReq where
(Double
w, Double
h) = (Double
16, Double
16)
factor :: Double
factor = Double
1
sizeReq :: (SizeReq, SizeReq)
sizeReq = (Double -> Double -> SizeReq
minSize Double
w Double
factor, Double -> Double -> SizeReq
minSize Double
h Double
factor)
render :: WidgetEnv s e -> WidgetNode s e -> Renderer -> IO ()
render WidgetEnv s e
wenv WidgetNode s e
node Renderer
renderer = do
Renderer -> StyleState -> IconType -> Rect -> Double -> IO ()
drawIcon Renderer
renderer StyleState
style IconType
iconType Rect
iconVp Double
width
where
style :: StyleState
style = forall s e. WidgetEnv s e -> WidgetNode s e -> StyleState
currentStyle WidgetEnv s e
wenv WidgetNode s e
node
contentArea :: Rect
contentArea = forall s e. WidgetNode s e -> StyleState -> Rect
getContentArea WidgetNode s e
node StyleState
style
vp :: Rect
vp = 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. HasViewport s a => Lens' s a
L.viewport
dim :: Double
dim = forall a. Ord a => a -> a -> a
min (Rect
vp forall s a. s -> Getting a s a -> a
^. forall s a. HasW s a => Lens' s a
L.w) (Rect
vp forall s a. s -> Getting a s a -> a
^. forall s a. HasH s a => Lens' s a
L.h)
width :: Double
width = forall a. a -> Maybe a -> a
fromMaybe (Double
dim forall a. Fractional a => a -> a -> a
/ Double
2) (IconCfg -> Maybe Double
_icWidth IconCfg
config)
iconVp :: Rect
iconVp = Rect -> Rect
centeredSquare Rect
contentArea
centeredSquare :: Rect -> Rect
centeredSquare :: Rect -> Rect
centeredSquare (Rect Double
x Double
y Double
w Double
h) = Double -> Double -> Double -> Double -> Rect
Rect Double
newX Double
newY Double
dim Double
dim where
dim :: Double
dim = forall a. Ord a => a -> a -> a
min Double
w Double
h
newX :: Double
newX = Double
x forall a. Num a => a -> a -> a
+ (Double
w forall a. Num a => a -> a -> a
- Double
dim) forall a. Fractional a => a -> a -> a
/ Double
2
newY :: Double
newY = Double
y forall a. Num a => a -> a -> a
+ (Double
h forall a. Num a => a -> a -> a
- Double
dim) forall a. Fractional a => a -> a -> a
/ Double
2
drawIcon :: Renderer -> StyleState -> IconType -> Rect -> Double -> IO ()
drawIcon :: Renderer -> StyleState -> IconType -> Rect -> Double -> IO ()
drawIcon Renderer
renderer StyleState
style IconType
iconType Rect
viewport Double
lw = case IconType
iconType of
IconType
IconClose ->
Renderer -> Rect -> Double -> Maybe Color -> IO ()
drawTimesX Renderer
renderer Rect
viewport Double
lw (forall a. a -> Maybe a
Just Color
fgColor)
IconType
IconPlus -> do
Renderer -> IO ()
beginPath Renderer
renderer
Renderer -> Color -> IO ()
setFillColor Renderer
renderer Color
fgColor
Renderer -> Rect -> IO ()
renderRect Renderer
renderer (Double -> Double -> Double -> Double -> Rect
Rect (Double
cx forall a. Num a => a -> a -> a
- Double
hw) Double
y Double
lw Double
h)
Renderer -> Rect -> IO ()
renderRect Renderer
renderer (Double -> Double -> Double -> Double -> Rect
Rect Double
x (Double
cy forall a. Num a => a -> a -> a
- Double
hw) Double
w Double
lw)
Renderer -> IO ()
fill Renderer
renderer
IconType
IconMinus -> do
Renderer -> IO ()
beginPath Renderer
renderer
Renderer -> Color -> IO ()
setFillColor Renderer
renderer Color
fgColor
Renderer -> Rect -> IO ()
renderRect Renderer
renderer (Double -> Double -> Double -> Double -> Rect
Rect Double
x (Double
cy forall a. Num a => a -> a -> a
- Double
hw) Double
w Double
lw)
Renderer -> IO ()
fill Renderer
renderer
where
Rect Double
x Double
y Double
w Double
h = Rect
viewport
fgColor :: Color
fgColor = forall a. a -> Maybe a -> a
fromMaybe (Int -> Int -> Int -> Color
rgb Int
0 Int
0 Int
0) (StyleState
style forall s a. s -> Getting a s a -> a
^. forall s a. HasFgColor s a => Lens' s a
L.fgColor)
hw :: Double
hw = Double
lw forall a. Fractional a => a -> a -> a
/ Double
2
cx :: Double
cx = Double
x forall a. Num a => a -> a -> a
+ Double
w forall a. Fractional a => a -> a -> a
/ Double
2
cy :: Double
cy = Double
y forall a. Num a => a -> a -> a
+ Double
h forall a. Fractional a => a -> a -> a
/ Double
2
mx :: Double
mx = Double
x forall a. Num a => a -> a -> a
+ Double
w
my :: Double
my = Double
y forall a. Num a => a -> a -> a
+ Double
h