{-# LANGUAGE Strict #-}
module Monomer.Widgets.Containers.BoxShadow (
BoxShadowCfg,
boxShadow,
boxShadow_
) where
import Control.Applicative ((<|>))
import Control.Lens ((&), (.~), (^.))
import Data.Default
import Data.Maybe
import qualified Data.Sequence as Seq
import Monomer.Core
import Monomer.Core.Combinators
import Monomer.Widgets.Container
import qualified Monomer.Lens as L
data BoxShadowCfg = BoxShadowCfg {
BoxShadowCfg -> Maybe Double
_bscRadius :: Maybe Double,
BoxShadowCfg -> Maybe AlignH
_bscAlignH :: Maybe AlignH,
BoxShadowCfg -> Maybe AlignV
_bscAlignV :: Maybe AlignV
}
instance Default BoxShadowCfg where
def :: BoxShadowCfg
def = BoxShadowCfg {
_bscRadius :: Maybe Double
_bscRadius = Maybe Double
forall a. Maybe a
Nothing,
_bscAlignH :: Maybe AlignH
_bscAlignH = Maybe AlignH
forall a. Maybe a
Nothing,
_bscAlignV :: Maybe AlignV
_bscAlignV = Maybe AlignV
forall a. Maybe a
Nothing
}
instance Semigroup BoxShadowCfg where
<> :: BoxShadowCfg -> BoxShadowCfg -> BoxShadowCfg
(<>) BoxShadowCfg
c1 BoxShadowCfg
c2 = BoxShadowCfg {
_bscRadius :: Maybe Double
_bscRadius = BoxShadowCfg -> Maybe Double
_bscRadius BoxShadowCfg
c2 Maybe Double -> Maybe Double -> Maybe Double
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> BoxShadowCfg -> Maybe Double
_bscRadius BoxShadowCfg
c1,
_bscAlignH :: Maybe AlignH
_bscAlignH = BoxShadowCfg -> Maybe AlignH
_bscAlignH BoxShadowCfg
c2 Maybe AlignH -> Maybe AlignH -> Maybe AlignH
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> BoxShadowCfg -> Maybe AlignH
_bscAlignH BoxShadowCfg
c1,
_bscAlignV :: Maybe AlignV
_bscAlignV = BoxShadowCfg -> Maybe AlignV
_bscAlignV BoxShadowCfg
c2 Maybe AlignV -> Maybe AlignV -> Maybe AlignV
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> BoxShadowCfg -> Maybe AlignV
_bscAlignV BoxShadowCfg
c1
}
instance Monoid BoxShadowCfg where
mempty :: BoxShadowCfg
mempty = BoxShadowCfg
forall a. Default a => a
def
instance CmbRadius BoxShadowCfg where
radius :: Double -> BoxShadowCfg
radius Double
r = BoxShadowCfg
forall a. Default a => a
def {
_bscRadius = Just r
}
instance CmbAlignLeft BoxShadowCfg where
alignLeft_ :: Bool -> BoxShadowCfg
alignLeft_ Bool
False = BoxShadowCfg
forall a. Default a => a
def
alignLeft_ Bool
True = BoxShadowCfg
forall a. Default a => a
def {
_bscAlignH = Just ALeft
}
instance CmbAlignCenter BoxShadowCfg where
alignCenter_ :: Bool -> BoxShadowCfg
alignCenter_ Bool
False = BoxShadowCfg
forall a. Default a => a
def
alignCenter_ Bool
True = BoxShadowCfg
forall a. Default a => a
def {
_bscAlignH = Just ACenter
}
instance CmbAlignRight BoxShadowCfg where
alignRight_ :: Bool -> BoxShadowCfg
alignRight_ Bool
False = BoxShadowCfg
forall a. Default a => a
def
alignRight_ Bool
True = BoxShadowCfg
forall a. Default a => a
def {
_bscAlignH = Just ARight
}
instance CmbAlignTop BoxShadowCfg where
alignTop_ :: Bool -> BoxShadowCfg
alignTop_ Bool
False = BoxShadowCfg
forall a. Default a => a
def
alignTop_ Bool
True = BoxShadowCfg
forall a. Default a => a
def {
_bscAlignV = Just ATop
}
instance CmbAlignMiddle BoxShadowCfg where
alignMiddle_ :: Bool -> BoxShadowCfg
alignMiddle_ Bool
False = BoxShadowCfg
forall a. Default a => a
def
alignMiddle_ Bool
True = BoxShadowCfg
forall a. Default a => a
def {
_bscAlignV = Just AMiddle
}
instance CmbAlignBottom BoxShadowCfg where
alignBottom_ :: Bool -> BoxShadowCfg
alignBottom_ Bool
False = BoxShadowCfg
forall a. Default a => a
def
alignBottom_ Bool
True = BoxShadowCfg
forall a. Default a => a
def {
_bscAlignV = Just ABottom
}
boxShadow
:: WidgetNode s e
-> WidgetNode s e
boxShadow :: forall s e. WidgetNode s e -> WidgetNode s e
boxShadow = [BoxShadowCfg] -> WidgetNode s e -> WidgetNode s e
forall s e. [BoxShadowCfg] -> WidgetNode s e -> WidgetNode s e
boxShadow_ [BoxShadowCfg]
forall a. Default a => a
def
boxShadow_
:: [BoxShadowCfg]
-> WidgetNode s e
-> WidgetNode s e
boxShadow_ :: forall s e. [BoxShadowCfg] -> WidgetNode s e -> WidgetNode s e
boxShadow_ [BoxShadowCfg]
config WidgetNode s e
child =
WidgetType -> Widget s e -> WidgetNode s e
forall s e. WidgetType -> Widget s e -> WidgetNode s e
defaultWidgetNode WidgetType
"boxShadow" (BoxShadowCfg -> Widget s e
forall s e. BoxShadowCfg -> Widget s e
boxShadowWidget ([BoxShadowCfg] -> BoxShadowCfg
forall a. Monoid a => [a] -> a
mconcat [BoxShadowCfg]
config))
WidgetNode s e
-> (WidgetNode s e -> WidgetNode s e) -> WidgetNode s e
forall a b. a -> (a -> b) -> b
& (Seq (WidgetNode s e) -> Identity (Seq (WidgetNode s e)))
-> WidgetNode s e -> Identity (WidgetNode s e)
forall s a. HasChildren s a => Lens' s a
Lens' (WidgetNode s e) (Seq (WidgetNode s e))
L.children ((Seq (WidgetNode s e) -> Identity (Seq (WidgetNode s e)))
-> WidgetNode s e -> Identity (WidgetNode s e))
-> Seq (WidgetNode s e) -> WidgetNode s e -> WidgetNode s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ WidgetNode s e -> Seq (WidgetNode s e)
forall a. a -> Seq a
Seq.singleton WidgetNode s e
child
boxShadowWidget :: BoxShadowCfg -> Widget s e
boxShadowWidget :: forall s e. BoxShadowCfg -> Widget s e
boxShadowWidget BoxShadowCfg
config = Widget s e
forall {s} {e}. Widget s e
widget where
widget :: Widget s e
widget = () -> Container s e () -> Widget s e
forall a s e. WidgetModel a => a -> Container s e a -> Widget s e
createContainer () Container s e ()
forall a. Default a => a
def {
containerGetSizeReq = getSizeReq,
containerResize = resize,
containerRender = render
}
shadowRadius :: Double
shadowRadius = Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
8 (BoxShadowCfg -> Maybe Double
_bscRadius BoxShadowCfg
config)
shadowDiameter :: Double
shadowDiameter = Double
shadowRadius Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
2
getSizeReq :: p -> p -> Seq (WidgetNode s e) -> (SizeReq, SizeReq)
getSizeReq p
wenv p
node Seq (WidgetNode s e)
children = (SizeReq
sizeReqW, SizeReq
sizeReqH) where
sizeReqW :: SizeReq
sizeReqW = SizeReq
-> (WidgetNode s e -> SizeReq) -> Maybe (WidgetNode s e) -> SizeReq
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Double -> SizeReq
fixedSize Double
0) (Double -> SizeReq -> SizeReq
addFixed Double
shadowDiameter (SizeReq -> SizeReq)
-> (WidgetNode s e -> SizeReq) -> WidgetNode s e -> SizeReq
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WidgetNodeInfo -> SizeReq
_wniSizeReqW (WidgetNodeInfo -> SizeReq)
-> (WidgetNode s e -> WidgetNodeInfo) -> WidgetNode s e -> SizeReq
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WidgetNode s e -> WidgetNodeInfo
forall s e. WidgetNode s e -> WidgetNodeInfo
_wnInfo) Maybe (WidgetNode s e)
vchild
sizeReqH :: SizeReq
sizeReqH = SizeReq
-> (WidgetNode s e -> SizeReq) -> Maybe (WidgetNode s e) -> SizeReq
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Double -> SizeReq
fixedSize Double
0) (Double -> SizeReq -> SizeReq
addFixed Double
shadowDiameter(SizeReq -> SizeReq)
-> (WidgetNode s e -> SizeReq) -> WidgetNode s e -> SizeReq
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WidgetNodeInfo -> SizeReq
_wniSizeReqH (WidgetNodeInfo -> SizeReq)
-> (WidgetNode s e -> WidgetNodeInfo) -> WidgetNode s e -> SizeReq
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WidgetNode s e -> WidgetNodeInfo
forall s e. WidgetNode s e -> WidgetNodeInfo
_wnInfo) Maybe (WidgetNode s e)
vchild
vchildren :: Seq (WidgetNode s e)
vchildren = (WidgetNode s e -> Bool)
-> Seq (WidgetNode s e) -> Seq (WidgetNode s e)
forall a. (a -> Bool) -> Seq a -> Seq a
Seq.filter (WidgetNodeInfo -> Bool
_wniVisible (WidgetNodeInfo -> Bool)
-> (WidgetNode s e -> WidgetNodeInfo) -> WidgetNode s e -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WidgetNode s e -> WidgetNodeInfo
forall s e. WidgetNode s e -> WidgetNodeInfo
_wnInfo) Seq (WidgetNode s e)
children
vchild :: Maybe (WidgetNode s e)
vchild = Int -> Seq (WidgetNode s e) -> Maybe (WidgetNode s e)
forall a. Int -> Seq a -> Maybe a
Seq.lookup Int
0 Seq (WidgetNode s e)
vchildren
resize :: WidgetEnv s e
-> WidgetNode s e
-> Rect
-> f (WidgetNode s e)
-> (WidgetResult s e, f Rect)
resize WidgetEnv s e
wenv WidgetNode s e
node Rect
viewport f (WidgetNode s e)
children = (WidgetNode s e -> WidgetResult s e
forall s e. WidgetNode s e -> WidgetResult s e
resultNode WidgetNode s e
node, (WidgetNode s e -> Rect) -> f (WidgetNode s e) -> f Rect
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap WidgetNode s e -> Rect
forall {s} {e}. WidgetNode s e -> Rect
assignArea f (WidgetNode s e)
children) 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
contentArea :: Rect
contentArea = Rect -> Maybe Rect -> Rect
forall a. a -> Maybe a -> a
fromMaybe Rect
forall a. Default a => a
def (StyleState -> Rect -> Maybe Rect
removeOuterBounds StyleState
style Rect
viewport)
assignArea :: WidgetNode s e -> Rect
assignArea WidgetNode s e
child
| Bool
visible = Point -> Rect -> Rect
moveRect Point
childOffset (Rect -> Rect
subtractShadow Rect
contentArea)
| Bool
otherwise = Rect
forall a. Default a => a
def
where
visible :: Bool
visible = (WidgetNodeInfo -> Bool
_wniVisible (WidgetNodeInfo -> Bool)
-> (WidgetNode s e -> WidgetNodeInfo) -> WidgetNode s e -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WidgetNode s e -> WidgetNodeInfo
forall s e. WidgetNode s e -> WidgetNodeInfo
_wnInfo) WidgetNode s e
child
childOffset :: Point
childOffset = Double -> Double -> Point
Point Double
offsetX Double
offsetY 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
shadowAlignH :: AlignH
shadowAlignH = AlignH -> Maybe AlignH -> AlignH
forall a. a -> Maybe a -> a
fromMaybe (ThemeState
theme ThemeState -> Getting AlignH ThemeState AlignH -> AlignH
forall s a. s -> Getting a s a -> a
^. Getting AlignH ThemeState AlignH
forall s a. HasShadowAlignH s a => Lens' s a
Lens' ThemeState AlignH
L.shadowAlignH) (BoxShadowCfg -> Maybe AlignH
_bscAlignH BoxShadowCfg
config)
shadowAlignV :: AlignV
shadowAlignV = AlignV -> Maybe AlignV -> AlignV
forall a. a -> Maybe a -> a
fromMaybe (ThemeState
theme ThemeState -> Getting AlignV ThemeState AlignV -> AlignV
forall s a. s -> Getting a s a -> a
^. Getting AlignV ThemeState AlignV
forall s a. HasShadowAlignV s a => Lens' s a
Lens' ThemeState AlignV
L.shadowAlignV) (BoxShadowCfg -> Maybe AlignV
_bscAlignV BoxShadowCfg
config)
offset :: Double
offset = Double
shadowRadius Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
4
offsetX :: Double
offsetX = case AlignH
shadowAlignH of
AlignH
ALeft -> Double
offset
AlignH
ACenter -> Double
0
AlignH
ARight -> -Double
offset
offsetY :: Double
offsetY = case AlignV
shadowAlignV of
AlignV
ATop -> Double
offset
AlignV
AMiddle -> Double
0
AlignV
ABottom -> -Double
offset
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 -> Rect -> Double -> Double -> Color -> Color -> IO ()
setFillBoxGradient Renderer
renderer (Rect -> Rect
subtractShadow Rect
vp) Double
shadowRadius Double
shadowDiameter Color
shadowColor Color
transparent
Renderer -> Rect -> IO ()
renderRect Renderer
renderer Rect
vp
Renderer -> IO ()
fill Renderer
renderer
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
vp :: Rect
vp = WidgetNode s e -> StyleState -> Rect
forall s e. WidgetNode s e -> StyleState -> Rect
getContentArea WidgetNode s e
node StyleState
style
shadowColor :: Color
shadowColor = WidgetEnv s e
wenv WidgetEnv s e -> Getting Color (WidgetEnv s e) Color -> Color
forall s a. s -> Getting a s a -> a
^. (Theme -> Const Color Theme)
-> WidgetEnv s e -> Const Color (WidgetEnv s e)
forall s a. HasTheme s a => Lens' s a
Lens' (WidgetEnv s e) Theme
L.theme ((Theme -> Const Color Theme)
-> WidgetEnv s e -> Const Color (WidgetEnv s e))
-> ((Color -> Const Color Color) -> Theme -> Const Color Theme)
-> Getting Color (WidgetEnv s e) Color
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ThemeState -> Const Color ThemeState)
-> Theme -> Const Color Theme
forall s a. HasBasic s a => Lens' s a
Lens' Theme ThemeState
L.basic ((ThemeState -> Const Color ThemeState)
-> Theme -> Const Color Theme)
-> ((Color -> Const Color Color)
-> ThemeState -> Const Color ThemeState)
-> (Color -> Const Color Color)
-> Theme
-> Const Color Theme
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Color -> Const Color Color)
-> ThemeState -> Const Color ThemeState
forall s a. HasShadowColor s a => Lens' s a
Lens' ThemeState Color
L.shadowColor
transparent :: Color
transparent = Int -> Int -> Int -> Double -> Color
rgba Int
0 Int
0 Int
0 Double
0
subtractShadow :: Rect -> Rect
subtractShadow (Rect Double
l Double
t Double
w Double
h) = Double -> Double -> Double -> Double -> Rect
Rect Double
l' Double
t' Double
w' Double
h' where
(Double
l', Double
w') = Double -> Double -> (Double, Double)
subtractDim Double
l Double
w
(Double
t', Double
h') = Double -> Double -> (Double, Double)
subtractDim Double
t Double
h
subtractDim :: Double -> Double -> (Double, Double)
subtractDim Double
pos Double
size
| Double
size Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
shadowDiameter = (Double
pos Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
shadowRadius, Double
size Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
shadowDiameter)
| Bool
otherwise = (Double
pos Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
size Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2, Double
0)
addFixed :: Double -> SizeReq -> SizeReq
addFixed :: Double -> SizeReq -> SizeReq
addFixed Double
f SizeReq
sReq =
SizeReq
sReq { _szrFixed = _szrFixed sReq + f }