{-|
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 = 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
  }

-- | 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 = forall s e. [BoxShadowCfg] -> WidgetNode s e -> WidgetNode s e
boxShadow_ 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 =
  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 }