BoxShadow.hs

{-|
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 {
  _bscRadius :: Maybe Double,
  _bscAlignH :: Maybe AlignH,
  _bscAlignV :: Maybe AlignV
}

instance Default BoxShadowCfg where
  def = BoxShadowCfg {
    _bscRadius = Nothing,
    _bscAlignH = Nothing,
    _bscAlignV = Nothing
  }

instance Semigroup BoxShadowCfg where
  (<>) c1 c2 = BoxShadowCfg {
    _bscRadius = _bscRadius c2 <|> _bscRadius c1,
    _bscAlignH = _bscAlignH c2 <|> _bscAlignH c1,
    _bscAlignV = _bscAlignV c2 <|> _bscAlignV c1
  }

instance Monoid BoxShadowCfg where
  mempty = def

instance CmbRadius BoxShadowCfg where
  radius r = def {
    _bscRadius = Just r
  }

instance CmbAlignLeft BoxShadowCfg where
  alignLeft_ False = def
  alignLeft_ True = def {
    _bscAlignH = Just ALeft
  }

instance CmbAlignCenter BoxShadowCfg where
  alignCenter_ False = def
  alignCenter_ True = def {
    _bscAlignH = Just ACenter
  }

instance CmbAlignRight BoxShadowCfg where
  alignRight_ False = def
  alignRight_ True = def {
    _bscAlignH = Just ARight
  }

instance CmbAlignTop BoxShadowCfg where
  alignTop_ False = def
  alignTop_ True = def {
    _bscAlignV = Just ATop
  }

instance CmbAlignMiddle BoxShadowCfg where
  alignMiddle_ False = def
  alignMiddle_ True = def {
    _bscAlignV = Just AMiddle
  }

instance CmbAlignBottom BoxShadowCfg where
  alignBottom_ False = def
  alignBottom_ True = 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 = boxShadow_ 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_ config child =
  defaultWidgetNode "boxShadow" (boxShadowWidget (mconcat config))
   & L.children .~ Seq.singleton child

boxShadowWidget :: BoxShadowCfg -> Widget s e
boxShadowWidget config = widget where
  widget = createContainer () def {
    containerGetSizeReq = getSizeReq,
    containerResize = resize,
    containerRender = render
  }

  shadowRadius = fromMaybe 8 (_bscRadius config)
  shadowDiameter = shadowRadius * 2

  getSizeReq wenv node children = (sizeReqW, sizeReqH) where
    sizeReqW = maybe (fixedSize 0) (addFixed shadowDiameter . _wniSizeReqW . _wnInfo) vchild
    sizeReqH = maybe (fixedSize 0) (addFixed shadowDiameter. _wniSizeReqH . _wnInfo) vchild
    vchildren = Seq.filter (_wniVisible . _wnInfo) children
    vchild = Seq.lookup 0 vchildren

  resize wenv node viewport children = (resultNode node, fmap assignArea children) where
    style = currentStyle wenv node
    contentArea = fromMaybe def (removeOuterBounds style viewport)
    
    assignArea child
      | visible = moveRect childOffset (subtractShadow contentArea)
      | otherwise = def
      where
        visible = (_wniVisible . _wnInfo) child
    
    childOffset = Point offsetX offsetY where
      theme = currentTheme wenv node
      shadowAlignH = fromMaybe (theme ^. L.shadowAlignH) (_bscAlignH config)
      shadowAlignV = fromMaybe (theme ^. L.shadowAlignV) (_bscAlignV config)
      offset = shadowRadius / 4
      offsetX = case shadowAlignH of
        ALeft -> offset
        ACenter -> 0
        ARight -> -offset
      offsetY = case shadowAlignV of
        ATop -> offset
        AMiddle -> 0
        ABottom -> -offset
  
  render wenv node renderer = do
    beginPath renderer
    setFillBoxGradient renderer (subtractShadow vp) shadowRadius shadowDiameter shadowColor transparent
    renderRect renderer vp
    fill renderer
    where
      style = currentStyle wenv node
      vp = getContentArea node style
      shadowColor = wenv ^. L.theme . L.basic . L.shadowColor
      transparent = rgba 0 0 0 0
  
  subtractShadow (Rect l t w h) = Rect l' t' w' h' where
    (l', w') = subtractDim l w
    (t', h') = subtractDim t h
    subtractDim pos size
      | size > shadowDiameter = (pos + shadowRadius, size - shadowDiameter)
      | otherwise = (pos + size / 2, 0)

addFixed :: Double -> SizeReq -> SizeReq
addFixed f sReq =
  sReq { _szrFixed = _szrFixed sReq + f }