{-# 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 = forall a. Maybe a
Nothing,
_bscAlignH :: Maybe AlignH
_bscAlignH = forall a. Maybe a
Nothing,
_bscAlignV :: Maybe AlignV
_bscAlignV = 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
c1 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> BoxShadowCfg -> Maybe Double
_bscRadius BoxShadowCfg
c2,
_bscAlignH :: Maybe AlignH
_bscAlignH = BoxShadowCfg -> Maybe AlignH
_bscAlignH BoxShadowCfg
c1 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> BoxShadowCfg -> Maybe AlignH
_bscAlignH BoxShadowCfg
c2,
_bscAlignV :: Maybe AlignV
_bscAlignV = BoxShadowCfg -> Maybe AlignV
_bscAlignV BoxShadowCfg
c1 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> BoxShadowCfg -> Maybe AlignV
_bscAlignV BoxShadowCfg
c2
}
instance Monoid BoxShadowCfg where
mempty :: BoxShadowCfg
mempty = forall a. Default a => a
def
instance CmbRadius BoxShadowCfg where
radius :: Double -> BoxShadowCfg
radius Double
r = forall a. Default a => a
def {
_bscRadius :: Maybe Double
_bscRadius = forall a. a -> Maybe a
Just Double
r
}
instance CmbAlignLeft BoxShadowCfg where
alignLeft_ :: Bool -> BoxShadowCfg
alignLeft_ Bool
False = forall a. Default a => a
def
alignLeft_ Bool
True = forall a. Default a => a
def {
_bscAlignH :: Maybe AlignH
_bscAlignH = forall a. a -> Maybe a
Just AlignH
ALeft
}
instance CmbAlignCenter BoxShadowCfg where
alignCenter_ :: Bool -> BoxShadowCfg
alignCenter_ Bool
False = forall a. Default a => a
def
alignCenter_ Bool
True = forall a. Default a => a
def {
_bscAlignH :: Maybe AlignH
_bscAlignH = forall a. a -> Maybe a
Just AlignH
ACenter
}
instance CmbAlignRight BoxShadowCfg where
alignRight_ :: Bool -> BoxShadowCfg
alignRight_ Bool
False = forall a. Default a => a
def
alignRight_ Bool
True = forall a. Default a => a
def {
_bscAlignH :: Maybe AlignH
_bscAlignH = forall a. a -> Maybe a
Just AlignH
ARight
}
instance CmbAlignTop BoxShadowCfg where
alignTop_ :: Bool -> BoxShadowCfg
alignTop_ Bool
False = forall a. Default a => a
def
alignTop_ Bool
True = forall a. Default a => a
def {
_bscAlignV :: Maybe AlignV
_bscAlignV = forall a. a -> Maybe a
Just AlignV
ATop
}
instance CmbAlignMiddle BoxShadowCfg where
alignMiddle_ :: Bool -> BoxShadowCfg
alignMiddle_ Bool
False = forall a. Default a => a
def
alignMiddle_ Bool
True = forall a. Default a => a
def {
_bscAlignV :: Maybe AlignV
_bscAlignV = forall a. a -> Maybe a
Just AlignV
AMiddle
}
instance CmbAlignBottom BoxShadowCfg where
alignBottom_ :: Bool -> BoxShadowCfg
alignBottom_ Bool
False = forall a. Default a => a
def
alignBottom_ Bool
True = forall a. Default a => a
def {
_bscAlignV :: Maybe AlignV
_bscAlignV = forall a. a -> Maybe a
Just AlignV
ABottom
}
boxShadow
:: WidgetNode s e
-> WidgetNode s e
boxShadow :: forall s e. WidgetNode s e -> WidgetNode s e
boxShadow = forall s e. [BoxShadowCfg] -> WidgetNode s e -> WidgetNode s e
boxShadow_ 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 =
forall s e. WidgetType -> Widget s e -> WidgetNode s e
defaultWidgetNode WidgetType
"boxShadow" (forall s e. BoxShadowCfg -> Widget s e
boxShadowWidget (forall a. Monoid a => [a] -> a
mconcat [BoxShadowCfg]
config))
forall a b. a -> (a -> b) -> b
& forall s a. HasChildren s a => Lens' s a
L.children forall s t a b. ASetter s t a b -> b -> s -> t
.~ 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 = forall {s} {e}. Widget s e
widget where
widget :: Widget s e
widget = forall a s e. WidgetModel a => a -> Container s e a -> Widget s e
createContainer () forall a. Default a => a
def {
containerGetSizeReq :: ContainerGetSizeReqHandler s e
containerGetSizeReq = forall {p} {p} {s} {e}.
p -> p -> Seq (WidgetNode s e) -> (SizeReq, SizeReq)
getSizeReq,
containerResize :: ContainerResizeHandler s e
containerResize = forall {f :: * -> *} {s} {e} {s} {e}.
Functor f =>
WidgetEnv s e
-> WidgetNode s e
-> Rect
-> f (WidgetNode s e)
-> (WidgetResult s e, f Rect)
resize,
containerRender :: ContainerRenderHandler s e
containerRender = forall {s} {e}.
WidgetEnv s e -> WidgetNode s e -> Renderer -> IO ()
render
}
shadowRadius :: Double
shadowRadius = forall a. a -> Maybe a -> a
fromMaybe Double
8 (BoxShadowCfg -> Maybe Double
_bscRadius BoxShadowCfg
config)
shadowDiameter :: Double
shadowDiameter = Double
shadowRadius 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 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Double -> SizeReq
fixedSize Double
0) (Double -> SizeReq -> SizeReq
addFixed Double
shadowDiameter forall b c a. (b -> c) -> (a -> b) -> a -> c
. WidgetNodeInfo -> SizeReq
_wniSizeReqW forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s e. WidgetNode s e -> WidgetNodeInfo
_wnInfo) Maybe (WidgetNode s e)
vchild
sizeReqH :: SizeReq
sizeReqH = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Double -> SizeReq
fixedSize Double
0) (Double -> SizeReq -> SizeReq
addFixed Double
shadowDiameterforall b c a. (b -> c) -> (a -> b) -> a -> c
. WidgetNodeInfo -> SizeReq
_wniSizeReqH forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s e. WidgetNode s e -> WidgetNodeInfo
_wnInfo) Maybe (WidgetNode s e)
vchild
vchildren :: Seq (WidgetNode s e)
vchildren = forall a. (a -> Bool) -> Seq a -> Seq a
Seq.filter (WidgetNodeInfo -> Bool
_wniVisible forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s e. WidgetNode s e -> WidgetNodeInfo
_wnInfo) Seq (WidgetNode s e)
children
vchild :: Maybe (WidgetNode s e)
vchild = 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 = (forall s e. WidgetNode s e -> WidgetResult s e
resultNode WidgetNode s e
node, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {s} {e}. WidgetNode s e -> Rect
assignArea f (WidgetNode s e)
children) 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 a. a -> Maybe a -> a
fromMaybe 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 = forall a. Default a => a
def
where
visible :: Bool
visible = (WidgetNodeInfo -> Bool
_wniVisible forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall s e. WidgetEnv s e -> WidgetNode s e -> ThemeState
currentTheme WidgetEnv s e
wenv WidgetNode s e
node
shadowAlignH :: AlignH
shadowAlignH = forall a. a -> Maybe a -> a
fromMaybe (ThemeState
theme forall s a. s -> Getting a s a -> a
^. forall s a. HasShadowAlignH s a => Lens' s a
L.shadowAlignH) (BoxShadowCfg -> Maybe AlignH
_bscAlignH BoxShadowCfg
config)
shadowAlignV :: AlignV
shadowAlignV = forall a. a -> Maybe a -> a
fromMaybe (ThemeState
theme forall s a. s -> Getting a s a -> a
^. forall s a. HasShadowAlignV s a => Lens' s a
L.shadowAlignV) (BoxShadowCfg -> Maybe AlignV
_bscAlignV BoxShadowCfg
config)
offset :: Double
offset = Double
shadowRadius 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 = forall s e. WidgetEnv s e -> WidgetNode s e -> StyleState
currentStyle WidgetEnv s e
wenv WidgetNode s e
node
vp :: Rect
vp = forall s e. WidgetNode s e -> StyleState -> Rect
getContentArea WidgetNode s e
node StyleState
style
shadowColor :: Color
shadowColor = WidgetEnv s e
wenv forall s a. s -> Getting a s a -> a
^. forall s a. HasTheme s a => Lens' s a
L.theme forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasBasic s a => Lens' s a
L.basic forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasShadowColor s a => Lens' s a
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 forall a. Ord a => a -> a -> Bool
> Double
shadowDiameter = (Double
pos forall a. Num a => a -> a -> a
+ Double
shadowRadius, Double
size forall a. Num a => a -> a -> a
- Double
shadowDiameter)
| Bool
otherwise = (Double
pos forall a. Num a => a -> a -> a
+ Double
size 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 :: Double
_szrFixed = SizeReq -> Double
_szrFixed SizeReq
sReq forall a. Num a => a -> a -> a
+ Double
f }