{-|
Module      : Monomer.Widgets.Containers.BoxShadow
Copyright   : (c) 2022 Gareth Smith, Francisco Vallarino
License     : BSD-3-Clause (see the LICENSE file)
Maintainer  : fjvallarino@gmail.com
Stability   : experimental
Portability : non-portable

A rectangular drop-shadow. Normally used around alert boxes to give the illusion
they are floating above the widgets underneath them.
-}
{-# LANGUAGE Strict #-}

module Monomer.Widgets.Containers.BoxShadow (
  -- * Configuration
  BoxShadowCfg,
  -- * Constructors
  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

{-|
Configuration options for boxShadow:

- 'radius': the radius of the corners of the shadow.
- 'alignLeft': aligns the shadow to the left.
- 'alignCenter': aligns the shadow to the horizontal center.
- 'alignRight': aligns the shadow to the right.
- 'alignTop': aligns the shadow to the top.
- 'alignMiddle': aligns the shadow to the vertical middle.
- 'alignBottom': aligns the shadow to the bottom.
-}
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
  }

-- | Creates a boxShadow around the provided content.
boxShadow
  :: WidgetNode s e  -- ^ The content to display inside the boxShadow.
  -> WidgetNode s e  -- ^ The created boxShadow.
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

-- | Creates a boxShadow around the provided content. Accepts config.
boxShadow_
  :: [BoxShadowCfg]  -- ^ The config options for the boxShadow.
  -> WidgetNode s e  -- ^ The content to display inside the boxShadow.
  -> WidgetNode s e  -- ^ The created boxShadow.
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 }