{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE StrictData #-}
module Monomer.Widgets.Singles.SeparatorLine (
SeparatorLineCfg,
separatorLine,
separatorLine_
) where
import Control.Applicative ((<|>))
import Control.Lens ((^.))
import Data.Default
import Data.Maybe
import Data.Tuple
import Monomer.Widgets.Single
import qualified Monomer.Core.Lens as L
data SeparatorLineCfg = SeparatorLineCfg {
SeparatorLineCfg -> Maybe Double
_slcWidth :: Maybe Double,
SeparatorLineCfg -> Maybe Double
_slcFactor :: Maybe Double
}
instance Default SeparatorLineCfg where
def :: SeparatorLineCfg
def = SeparatorLineCfg :: Maybe Double -> Maybe Double -> SeparatorLineCfg
SeparatorLineCfg {
_slcWidth :: Maybe Double
_slcWidth = Maybe Double
forall a. Maybe a
Nothing,
_slcFactor :: Maybe Double
_slcFactor = Maybe Double
forall a. Maybe a
Nothing
}
instance Semigroup SeparatorLineCfg where
<> :: SeparatorLineCfg -> SeparatorLineCfg -> SeparatorLineCfg
(<>) SeparatorLineCfg
s1 SeparatorLineCfg
s2 = SeparatorLineCfg :: Maybe Double -> Maybe Double -> SeparatorLineCfg
SeparatorLineCfg {
_slcWidth :: Maybe Double
_slcWidth = SeparatorLineCfg -> Maybe Double
_slcWidth SeparatorLineCfg
s2 Maybe Double -> Maybe Double -> Maybe Double
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> SeparatorLineCfg -> Maybe Double
_slcWidth SeparatorLineCfg
s1,
_slcFactor :: Maybe Double
_slcFactor = SeparatorLineCfg -> Maybe Double
_slcFactor SeparatorLineCfg
s2 Maybe Double -> Maybe Double -> Maybe Double
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> SeparatorLineCfg -> Maybe Double
_slcFactor SeparatorLineCfg
s1
}
instance Monoid SeparatorLineCfg where
mempty :: SeparatorLineCfg
mempty = SeparatorLineCfg
forall a. Default a => a
def
instance CmbWidth SeparatorLineCfg where
width :: Double -> SeparatorLineCfg
width Double
w = SeparatorLineCfg
forall a. Default a => a
def {
_slcWidth :: Maybe Double
_slcWidth = Double -> Maybe Double
forall a. a -> Maybe a
Just Double
w
}
instance CmbResizeFactor SeparatorLineCfg where
resizeFactor :: Double -> SeparatorLineCfg
resizeFactor Double
f = SeparatorLineCfg
forall a. Default a => a
def {
_slcFactor :: Maybe Double
_slcFactor = Double -> Maybe Double
forall a. a -> Maybe a
Just Double
f
}
separatorLine :: WidgetNode s e
separatorLine :: WidgetNode s e
separatorLine = [SeparatorLineCfg] -> WidgetNode s e
forall s e. [SeparatorLineCfg] -> WidgetNode s e
separatorLine_ [SeparatorLineCfg]
forall a. Default a => a
def
separatorLine_ :: [SeparatorLineCfg] -> WidgetNode s e
separatorLine_ :: [SeparatorLineCfg] -> WidgetNode s e
separatorLine_ [SeparatorLineCfg]
configs = WidgetType -> Widget s e -> WidgetNode s e
forall s e. WidgetType -> Widget s e -> WidgetNode s e
defaultWidgetNode WidgetType
"separatorLine" Widget s e
forall s e. Widget s e
widget where
config :: SeparatorLineCfg
config = [SeparatorLineCfg] -> SeparatorLineCfg
forall a. Monoid a => [a] -> a
mconcat (Double -> SeparatorLineCfg
forall t. CmbResizeFactor t => Double -> t
resizeFactor Double
0 SeparatorLineCfg -> [SeparatorLineCfg] -> [SeparatorLineCfg]
forall a. a -> [a] -> [a]
: [SeparatorLineCfg]
configs)
widget :: Widget s e
widget = SeparatorLineCfg -> Widget s e
forall s e. SeparatorLineCfg -> Widget s e
makeSeparatorLine SeparatorLineCfg
config
makeSeparatorLine :: SeparatorLineCfg -> Widget s e
makeSeparatorLine :: SeparatorLineCfg -> Widget s e
makeSeparatorLine !SeparatorLineCfg
config = Widget s e
forall s e. Widget s e
widget where
widget :: Widget s e
widget = () -> Single s e () -> Widget s e
forall a s e. WidgetModel a => a -> Single s e a -> Widget s e
createSingle () Single s e ()
forall a. Default a => a
def {
singleGetBaseStyle :: SingleGetBaseStyle s e
singleGetBaseStyle = SingleGetBaseStyle s e
forall s e p. WidgetEnv s e -> p -> Maybe Style
getBaseStyle,
singleGetSizeReq :: SingleGetSizeReqHandler s e
singleGetSizeReq = SingleGetSizeReqHandler s e
forall s e. WidgetEnv s e -> WidgetNode s e -> (SizeReq, SizeReq)
getSizeReq,
singleRender :: SingleRenderHandler s e
singleRender = SingleRenderHandler s e
forall s e. WidgetEnv s e -> WidgetNode s e -> Renderer -> IO ()
render
}
getBaseStyle :: WidgetEnv s e -> p -> Maybe Style
getBaseStyle WidgetEnv s e
wenv p
node = Style -> Maybe Style
forall a. a -> Maybe a
Just Style
style where
style :: Style
style = WidgetEnv s e -> Lens' ThemeState StyleState -> Style
forall s e. WidgetEnv s e -> Lens' ThemeState StyleState -> Style
collectTheme WidgetEnv s e
wenv forall s a. HasSeparatorLineStyle s a => Lens' s a
Lens' ThemeState StyleState
L.separatorLineStyle
getSizeReq :: WidgetEnv s e -> WidgetNode s e -> (SizeReq, SizeReq)
getSizeReq WidgetEnv s e
wenv WidgetNode s e
node = (SizeReq, SizeReq)
sizeReq where
theme :: ThemeState
theme = WidgetEnv s e -> WidgetNode s e -> ThemeState
forall s e. WidgetEnv s e -> WidgetNode s e -> ThemeState
currentTheme WidgetEnv s e
wenv WidgetNode s e
node
direction :: LayoutDirection
direction = WidgetEnv s e
wenv WidgetEnv s e
-> Getting LayoutDirection (WidgetEnv s e) LayoutDirection
-> LayoutDirection
forall s a. s -> Getting a s a -> a
^. Getting LayoutDirection (WidgetEnv s e) LayoutDirection
forall s a. HasLayoutDirection s a => Lens' s a
L.layoutDirection
width :: Double
width = Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe (ThemeState
theme ThemeState -> Getting Double ThemeState Double -> Double
forall s a. s -> Getting a s a -> a
^. Getting Double ThemeState Double
forall s a. HasSeparatorLineWidth s a => Lens' s a
L.separatorLineWidth) (SeparatorLineCfg -> Maybe Double
_slcWidth SeparatorLineCfg
config)
factor :: Double
factor = Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
0 (SeparatorLineCfg -> Maybe Double
_slcFactor SeparatorLineCfg
config)
isFixed :: Bool
isFixed = Double
factor Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
0.01
flexSide :: SizeReq
flexSide = Double -> Double -> SizeReq
flexSize Double
10 Double
0.5
fixedW :: SizeReq
fixedW = Double -> SizeReq
fixedSize Double
width
flexW :: SizeReq
flexW = Double -> Double -> SizeReq
flexSize Double
width Double
factor
expandW :: SizeReq
expandW = Double -> Double -> SizeReq
expandSize Double
width Double
factor
sizeReq :: (SizeReq, SizeReq)
sizeReq
| Bool
isFixed Bool -> Bool -> Bool
&& LayoutDirection
direction LayoutDirection -> LayoutDirection -> Bool
forall a. Eq a => a -> a -> Bool
== LayoutDirection
LayoutNone = (SizeReq
fixedW, SizeReq
fixedW)
| Bool
isFixed Bool -> Bool -> Bool
&& LayoutDirection
direction LayoutDirection -> LayoutDirection -> Bool
forall a. Eq a => a -> a -> Bool
== LayoutDirection
LayoutHorizontal = (SizeReq
fixedW, SizeReq
flexSide)
| Bool
isFixed = (SizeReq
flexSide, SizeReq
fixedW)
| LayoutDirection
direction LayoutDirection -> LayoutDirection -> Bool
forall a. Eq a => a -> a -> Bool
== LayoutDirection
LayoutNone = (SizeReq
expandW, SizeReq
expandW)
| LayoutDirection
direction LayoutDirection -> LayoutDirection -> Bool
forall a. Eq a => a -> a -> Bool
== LayoutDirection
LayoutHorizontal = (SizeReq
expandW, SizeReq
flexW)
| Bool
otherwise = (SizeReq
flexW, SizeReq
expandW)
render :: WidgetEnv s e -> WidgetNode s e -> Renderer -> IO ()
render WidgetEnv s e
wenv WidgetNode s e
node Renderer
renderer = do
Renderer -> IO ()
beginPath Renderer
renderer
Renderer -> Color -> IO ()
setFillColor Renderer
renderer Color
fgColor
Renderer -> Rect -> IO ()
renderRect Renderer
renderer Rect
lineRect
Renderer -> IO ()
fill Renderer
renderer
where
theme :: ThemeState
theme = WidgetEnv s e -> WidgetNode s e -> ThemeState
forall s e. WidgetEnv s e -> WidgetNode s e -> ThemeState
currentTheme WidgetEnv s e
wenv WidgetNode s e
node
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
direction :: LayoutDirection
direction = WidgetEnv s e
wenv WidgetEnv s e
-> Getting LayoutDirection (WidgetEnv s e) LayoutDirection
-> LayoutDirection
forall s a. s -> Getting a s a -> a
^. Getting LayoutDirection (WidgetEnv s e) LayoutDirection
forall s a. HasLayoutDirection s a => Lens' s a
L.layoutDirection
fgColor :: Color
fgColor = StyleState -> Color
styleFgColor StyleState
style
width :: Double
width = Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe (ThemeState
theme ThemeState -> Getting Double ThemeState Double -> Double
forall s a. s -> Getting a s a -> a
^. Getting Double ThemeState Double
forall s a. HasSeparatorLineWidth s a => Lens' s a
L.separatorLineWidth) (SeparatorLineCfg -> Maybe Double
_slcWidth SeparatorLineCfg
config)
Rect Double
cx Double
cy Double
cw Double
ch = WidgetNode s e -> StyleState -> Rect
forall s e. WidgetNode s e -> StyleState -> Rect
getContentArea WidgetNode s e
node StyleState
style
lineW :: Double
lineW = Double
cx Double -> Double -> Double
forall a. Num a => a -> a -> a
+ (Double
cw Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
width) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2
lineH :: Double
lineH = Double
cy Double -> Double -> Double
forall a. Num a => a -> a -> a
+ (Double
ch Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
width) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2
lineRect :: Rect
lineRect
| LayoutDirection
direction LayoutDirection -> LayoutDirection -> Bool
forall a. Eq a => a -> a -> Bool
== LayoutDirection
LayoutNone = Double -> Double -> Double -> Double -> Rect
Rect Double
cx Double
cy Double
cw Double
ch
| LayoutDirection
direction LayoutDirection -> LayoutDirection -> Bool
forall a. Eq a => a -> a -> Bool
== LayoutDirection
LayoutHorizontal = Double -> Double -> Double -> Double -> Rect
Rect Double
lineW Double
cy Double
width Double
ch
| Bool
otherwise = Double -> Double -> Double -> Double -> Rect
Rect Double
cx Double
lineH Double
cw Double
width