{-|
Module      : Monomer.Core.StyleUtil
Copyright   : (c) 2018 Francisco Vallarino
License     : BSD-3-Clause (see the LICENSE file)
Maintainer  : fjvallarino@gmail.com
Stability   : experimental
Portability : non-portable

Helper functions for style types.
-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE Strict #-}

module Monomer.Core.StyleUtil (
  getContentArea,
  nodeKey,
  nodeEnabled,
  nodeVisible,
  nodeFocusable,
  styleFont,
  styleFontSize,
  styleFontSpaceH,
  styleFontSpaceV,
  styleFontColor,
  styleTextAlignH,
  styleTextAlignV,
  styleTextLineBreak,
  styleBgColor,
  styleFgColor,
  styleSndColor,
  styleHlColor,
  getOuterSize,
  addOuterSize,
  addOuterBounds,
  removeOuterSize,
  removeOuterBounds,
  addBorder,
  addPadding,
  subtractBorder,
  subtractPadding,
  subtractBorderFromRadius,
  mapStyleStates
) where

import Control.Lens
import Data.Default
import Data.Maybe
import Data.Text (Text)

import Monomer.Common
import Monomer.Core.Combinators
import Monomer.Core.StyleTypes
import Monomer.Core.WidgetTypes
import Monomer.Graphics.Types
import Monomer.Helper

import qualified Monomer.Core.Lens as L

instance CmbStyleBasic Style where
  styleBasic :: Style -> [StyleState] -> Style
styleBasic Style
oldStyle [StyleState]
states = Style
newStyle where
    newStyle :: Style
newStyle = Style
oldStyle forall a b. a -> (a -> b) -> b
& forall s a. HasBasic s a => Lens' s a
L.basic forall a s t. Semigroup a => ASetter s t a a -> a -> s -> t
<>~ forall a. Monoid a => [a] -> Maybe a
maybeConcat [StyleState]
states

  styleBasicSet :: Style -> [StyleState] -> Style
styleBasicSet Style
oldStyle [StyleState]
states = Style
newStyle where
    newStyle :: Style
newStyle = Style
oldStyle forall a b. a -> (a -> b) -> b
& forall s a. HasBasic s a => Lens' s a
L.basic forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. Monoid a => [a] -> Maybe a
maybeConcat [StyleState]
states

instance CmbStyleHover Style where
  styleHover :: Style -> [StyleState] -> Style
styleHover Style
oldStyle [StyleState]
states = Style
newStyle where
    newStyle :: Style
newStyle = Style
oldStyle forall a b. a -> (a -> b) -> b
& forall s a. HasHover s a => Lens' s a
L.hover forall a s t. Semigroup a => ASetter s t a a -> a -> s -> t
<>~ forall a. Monoid a => [a] -> Maybe a
maybeConcat [StyleState]
states

  styleHoverSet :: Style -> [StyleState] -> Style
styleHoverSet Style
oldStyle [StyleState]
states = Style
newStyle where
    newStyle :: Style
newStyle = Style
oldStyle forall a b. a -> (a -> b) -> b
& forall s a. HasHover s a => Lens' s a
L.hover forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. Monoid a => [a] -> Maybe a
maybeConcat [StyleState]
states

instance CmbStyleFocus Style where
  styleFocus :: Style -> [StyleState] -> Style
styleFocus Style
oldStyle [StyleState]
states = Style
newStyle where
    newStyle :: Style
newStyle = Style
oldStyle forall a b. a -> (a -> b) -> b
& forall s a. HasFocus s a => Lens' s a
L.focus forall a s t. Semigroup a => ASetter s t a a -> a -> s -> t
<>~ forall a. Monoid a => [a] -> Maybe a
maybeConcat [StyleState]
states

  styleFocusSet :: Style -> [StyleState] -> Style
styleFocusSet Style
oldStyle [StyleState]
states = Style
newStyle where
    newStyle :: Style
newStyle = Style
oldStyle forall a b. a -> (a -> b) -> b
& forall s a. HasFocus s a => Lens' s a
L.focus forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. Monoid a => [a] -> Maybe a
maybeConcat [StyleState]
states

instance CmbStyleFocusHover Style where
  styleFocusHover :: Style -> [StyleState] -> Style
styleFocusHover Style
oldStyle [StyleState]
states = Style
newStyle where
    newStyle :: Style
newStyle = Style
oldStyle forall a b. a -> (a -> b) -> b
& forall s a. HasFocusHover s a => Lens' s a
L.focusHover forall a s t. Semigroup a => ASetter s t a a -> a -> s -> t
<>~ forall a. Monoid a => [a] -> Maybe a
maybeConcat [StyleState]
states

  styleFocusHoverSet :: Style -> [StyleState] -> Style
styleFocusHoverSet Style
oldStyle [StyleState]
states = Style
newStyle where
    newStyle :: Style
newStyle = Style
oldStyle forall a b. a -> (a -> b) -> b
& forall s a. HasFocusHover s a => Lens' s a
L.focusHover forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. Monoid a => [a] -> Maybe a
maybeConcat [StyleState]
states

instance CmbStyleActive Style where
  styleActive :: Style -> [StyleState] -> Style
styleActive Style
oldStyle [StyleState]
states = Style
newStyle where
    newStyle :: Style
newStyle = Style
oldStyle forall a b. a -> (a -> b) -> b
& forall s a. HasActive s a => Lens' s a
L.active forall a s t. Semigroup a => ASetter s t a a -> a -> s -> t
<>~ forall a. Monoid a => [a] -> Maybe a
maybeConcat [StyleState]
states

  styleActiveSet :: Style -> [StyleState] -> Style
styleActiveSet Style
oldStyle [StyleState]
states = Style
newStyle where
    newStyle :: Style
newStyle = Style
oldStyle forall a b. a -> (a -> b) -> b
& forall s a. HasActive s a => Lens' s a
L.active forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. Monoid a => [a] -> Maybe a
maybeConcat [StyleState]
states

instance CmbStyleDisabled Style where
  styleDisabled :: Style -> [StyleState] -> Style
styleDisabled Style
oldStyle [StyleState]
states = Style
newStyle where
    newStyle :: Style
newStyle = Style
oldStyle forall a b. a -> (a -> b) -> b
& forall s a. HasDisabled s a => Lens' s a
L.disabled forall a s t. Semigroup a => ASetter s t a a -> a -> s -> t
<>~ forall a. Monoid a => [a] -> Maybe a
maybeConcat [StyleState]
states

  styleDisabledSet :: Style -> [StyleState] -> Style
styleDisabledSet Style
oldStyle [StyleState]
states = Style
newStyle where
    newStyle :: Style
newStyle = Style
oldStyle forall a b. a -> (a -> b) -> b
& forall s a. HasDisabled s a => Lens' s a
L.disabled forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. Monoid a => [a] -> Maybe a
maybeConcat [StyleState]
states

instance CmbStyleBasic (WidgetNode s e) where
  styleBasic :: WidgetNode s e -> [StyleState] -> WidgetNode s e
styleBasic WidgetNode s e
node [StyleState]
states = WidgetNode s e
newNode where
    newNode :: WidgetNode s e
newNode = forall s e.
Lens' Style (Maybe StyleState)
-> WidgetNode s e -> [StyleState] -> WidgetNode s e
mergeNodeStyleState forall s a. HasBasic s a => Lens' s a
L.basic WidgetNode s e
node [StyleState]
states

  styleBasicSet :: WidgetNode s e -> [StyleState] -> WidgetNode s e
styleBasicSet WidgetNode s e
node [StyleState]
states = WidgetNode s e
newNode where
    newNode :: WidgetNode s e
newNode = forall s e.
Lens' Style (Maybe StyleState)
-> WidgetNode s e -> [StyleState] -> WidgetNode s e
setNodeStyleState forall s a. HasBasic s a => Lens' s a
L.basic WidgetNode s e
node [StyleState]
states

instance CmbStyleHover (WidgetNode s e) where
  styleHover :: WidgetNode s e -> [StyleState] -> WidgetNode s e
styleHover WidgetNode s e
node [StyleState]
states = WidgetNode s e
newNode where
    newNode :: WidgetNode s e
newNode = forall s e.
Lens' Style (Maybe StyleState)
-> WidgetNode s e -> [StyleState] -> WidgetNode s e
mergeNodeStyleState forall s a. HasHover s a => Lens' s a
L.hover WidgetNode s e
node [StyleState]
states

  styleHoverSet :: WidgetNode s e -> [StyleState] -> WidgetNode s e
styleHoverSet WidgetNode s e
node [StyleState]
states = WidgetNode s e
newNode where
    newNode :: WidgetNode s e
newNode = forall s e.
Lens' Style (Maybe StyleState)
-> WidgetNode s e -> [StyleState] -> WidgetNode s e
setNodeStyleState forall s a. HasHover s a => Lens' s a
L.hover WidgetNode s e
node [StyleState]
states

instance CmbStyleFocus (WidgetNode s e) where
  styleFocus :: WidgetNode s e -> [StyleState] -> WidgetNode s e
styleFocus WidgetNode s e
node [StyleState]
states = WidgetNode s e
newNode where
    newNode :: WidgetNode s e
newNode = forall s e.
Lens' Style (Maybe StyleState)
-> WidgetNode s e -> [StyleState] -> WidgetNode s e
mergeNodeStyleState forall s a. HasFocus s a => Lens' s a
L.focus WidgetNode s e
node [StyleState]
states

  styleFocusSet :: WidgetNode s e -> [StyleState] -> WidgetNode s e
styleFocusSet WidgetNode s e
node [StyleState]
states = WidgetNode s e
newNode where
    newNode :: WidgetNode s e
newNode = forall s e.
Lens' Style (Maybe StyleState)
-> WidgetNode s e -> [StyleState] -> WidgetNode s e
setNodeStyleState forall s a. HasFocus s a => Lens' s a
L.focus WidgetNode s e
node [StyleState]
states

instance CmbStyleFocusHover (WidgetNode s e) where
  styleFocusHover :: WidgetNode s e -> [StyleState] -> WidgetNode s e
styleFocusHover WidgetNode s e
node [StyleState]
states = WidgetNode s e
newNode where
    newNode :: WidgetNode s e
newNode = forall s e.
Lens' Style (Maybe StyleState)
-> WidgetNode s e -> [StyleState] -> WidgetNode s e
mergeNodeStyleState forall s a. HasFocusHover s a => Lens' s a
L.focusHover WidgetNode s e
node [StyleState]
states

  styleFocusHoverSet :: WidgetNode s e -> [StyleState] -> WidgetNode s e
styleFocusHoverSet WidgetNode s e
node [StyleState]
states = WidgetNode s e
newNode where
    newNode :: WidgetNode s e
newNode = forall s e.
Lens' Style (Maybe StyleState)
-> WidgetNode s e -> [StyleState] -> WidgetNode s e
setNodeStyleState forall s a. HasFocusHover s a => Lens' s a
L.focusHover WidgetNode s e
node [StyleState]
states

instance CmbStyleActive (WidgetNode s e) where
  styleActive :: WidgetNode s e -> [StyleState] -> WidgetNode s e
styleActive WidgetNode s e
node [StyleState]
states = WidgetNode s e
newNode where
    newNode :: WidgetNode s e
newNode = forall s e.
Lens' Style (Maybe StyleState)
-> WidgetNode s e -> [StyleState] -> WidgetNode s e
mergeNodeStyleState forall s a. HasActive s a => Lens' s a
L.active WidgetNode s e
node [StyleState]
states

  styleActiveSet :: WidgetNode s e -> [StyleState] -> WidgetNode s e
styleActiveSet WidgetNode s e
node [StyleState]
states = WidgetNode s e
newNode where
    newNode :: WidgetNode s e
newNode = forall s e.
Lens' Style (Maybe StyleState)
-> WidgetNode s e -> [StyleState] -> WidgetNode s e
setNodeStyleState forall s a. HasActive s a => Lens' s a
L.active WidgetNode s e
node [StyleState]
states

instance CmbStyleDisabled (WidgetNode s e) where
  styleDisabled :: WidgetNode s e -> [StyleState] -> WidgetNode s e
styleDisabled WidgetNode s e
node [StyleState]
states = WidgetNode s e
newNode where
    newNode :: WidgetNode s e
newNode = forall s e.
Lens' Style (Maybe StyleState)
-> WidgetNode s e -> [StyleState] -> WidgetNode s e
mergeNodeStyleState forall s a. HasDisabled s a => Lens' s a
L.disabled WidgetNode s e
node [StyleState]
states

  styleDisabledSet :: WidgetNode s e -> [StyleState] -> WidgetNode s e
styleDisabledSet WidgetNode s e
node [StyleState]
states = WidgetNode s e
newNode where
    newNode :: WidgetNode s e
newNode = forall s e.
Lens' Style (Maybe StyleState)
-> WidgetNode s e -> [StyleState] -> WidgetNode s e
setNodeStyleState forall s a. HasDisabled s a => Lens' s a
L.disabled WidgetNode s e
node [StyleState]
states

infixl 5 `nodeKey`
infixl 5 `nodeEnabled`
infixl 5 `nodeVisible`
infixl 5 `nodeFocusable`

-- | Sets the key of the given node.
nodeKey :: WidgetNode s e -> Text -> WidgetNode s e
nodeKey :: forall s e. WidgetNode s e -> Text -> WidgetNode s e
nodeKey WidgetNode s e
node Text
key = WidgetNode s e
node forall a b. a -> (a -> b) -> b
& forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasKey s a => Lens' s a
L.key forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Text -> WidgetKey
WidgetKey Text
key

-- | Sets whether the given node is enabled.
nodeEnabled :: WidgetNode s e -> Bool -> WidgetNode s e
nodeEnabled :: forall s e. WidgetNode s e -> Bool -> WidgetNode s e
nodeEnabled WidgetNode s e
node Bool
state = WidgetNode s e
node forall a b. a -> (a -> b) -> b
& forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasEnabled s a => Lens' s a
L.enabled forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
state

-- | Sets whether the given node is visible.
nodeVisible :: WidgetNode s e -> Bool -> WidgetNode s e
nodeVisible :: forall s e. WidgetNode s e -> Bool -> WidgetNode s e
nodeVisible WidgetNode s e
node Bool
visibility = WidgetNode s e
node forall a b. a -> (a -> b) -> b
& forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasVisible s a => Lens' s a
L.visible forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
visibility

-- | Sets whether the given node is focusable.
nodeFocusable :: WidgetNode s e -> Bool -> WidgetNode s e
nodeFocusable :: forall s e. WidgetNode s e -> Bool -> WidgetNode s e
nodeFocusable WidgetNode s e
node Bool
isFocusable = WidgetNode s e
node forall a b. a -> (a -> b) -> b
& forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasFocusable s a => Lens' s a
L.focusable forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
isFocusable

-- | Returns the content area (i.e., ignoring border and padding) of the node.
getContentArea :: WidgetNode s e -> StyleState -> Rect
getContentArea :: forall s e. WidgetNode s e -> StyleState -> Rect
getContentArea WidgetNode s e
node StyleState
style = forall a. a -> Maybe a -> a
fromMaybe forall a. Default a => a
def Maybe Rect
area where
  area :: Maybe Rect
area = StyleState -> Rect -> Maybe Rect
removeOuterBounds StyleState
style (WidgetNode s e
node forall s a. s -> Getting a s a -> a
^. forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasViewport s a => Lens' s a
L.viewport)

-- | Returns the font of the given style state, or the default.
styleFont :: StyleState -> Font
styleFont :: StyleState -> Font
styleFont StyleState
style = forall a. a -> Maybe a -> a
fromMaybe forall a. Default a => a
def Maybe Font
font where
  font :: Maybe Font
font = StyleState
style forall s a. s -> Getting (First a) s a -> Maybe a
^? forall s a. HasText s a => Lens' s a
L.text forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasFont s a => Lens' s a
L.font forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just

-- | Returns the font size of the given style state, or the default.
styleFontSize :: StyleState -> FontSize
styleFontSize :: StyleState -> FontSize
styleFontSize StyleState
style = forall a. a -> Maybe a -> a
fromMaybe forall a. Default a => a
def Maybe FontSize
fontSize where
  fontSize :: Maybe FontSize
fontSize = StyleState
style forall s a. s -> Getting (First a) s a -> Maybe a
^? forall s a. HasText s a => Lens' s a
L.text forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasFontSize s a => Lens' s a
L.fontSize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just

-- | Returns the horizontal spacing of the given style state, or the default.
styleFontSpaceH :: StyleState -> FontSpace
styleFontSpaceH :: StyleState -> FontSpace
styleFontSpaceH StyleState
style = forall a. a -> Maybe a -> a
fromMaybe forall a. Default a => a
def Maybe FontSpace
fontSpaceH where
  fontSpaceH :: Maybe FontSpace
fontSpaceH = StyleState
style forall s a. s -> Getting (First a) s a -> Maybe a
^? forall s a. HasText s a => Lens' s a
L.text forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasFontSpaceH s a => Lens' s a
L.fontSpaceH forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just

-- | Returns the vertical spacing of the given style state, or the default.
styleFontSpaceV :: StyleState -> FontSpace
styleFontSpaceV :: StyleState -> FontSpace
styleFontSpaceV StyleState
style = forall a. a -> Maybe a -> a
fromMaybe forall a. Default a => a
def Maybe FontSpace
fontSpaceV where
  fontSpaceV :: Maybe FontSpace
fontSpaceV = StyleState
style forall s a. s -> Getting (First a) s a -> Maybe a
^? forall s a. HasText s a => Lens' s a
L.text forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasFontSpaceV s a => Lens' s a
L.fontSpaceV forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just

-- | Returns the font color of the given style state, or the default.
styleFontColor :: StyleState -> Color
styleFontColor :: StyleState -> Color
styleFontColor StyleState
style = forall a. a -> Maybe a -> a
fromMaybe forall a. Default a => a
def Maybe Color
fontColor where
  fontColor :: Maybe Color
fontColor = StyleState
style forall s a. s -> Getting (First a) s a -> Maybe a
^? forall s a. HasText s a => Lens' s a
L.text forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasFontColor s a => Lens' s a
L.fontColor forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just

-- | Returns the horizontal alignment of the given style state, or the default.
styleTextAlignH :: StyleState -> AlignTH
styleTextAlignH :: StyleState -> AlignTH
styleTextAlignH StyleState
style = forall a. a -> Maybe a -> a
fromMaybe forall a. Default a => a
def Maybe AlignTH
alignH where
  alignH :: Maybe AlignTH
alignH = StyleState
style forall s a. s -> Getting (First a) s a -> Maybe a
^? forall s a. HasText s a => Lens' s a
L.text forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasAlignH s a => Lens' s a
L.alignH forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just

-- | Returns the vertical alignment of the given style state, or the default.
styleTextAlignV :: StyleState -> AlignTV
styleTextAlignV :: StyleState -> AlignTV
styleTextAlignV StyleState
style = forall a. a -> Maybe a -> a
fromMaybe forall a. Default a => a
def Maybe AlignTV
alignV where
  alignV :: Maybe AlignTV
alignV = StyleState
style forall s a. s -> Getting (First a) s a -> Maybe a
^? forall s a. HasText s a => Lens' s a
L.text forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasAlignV s a => Lens' s a
L.alignV forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just

-- | Returns the line break option of the given style state, or the
styleTextLineBreak :: StyleState -> LineBreak
styleTextLineBreak :: StyleState -> LineBreak
styleTextLineBreak StyleState
style = forall a. a -> Maybe a -> a
fromMaybe forall a. Default a => a
def Maybe LineBreak
lineBreak where
  lineBreak :: Maybe LineBreak
lineBreak = StyleState
style forall s a. s -> Getting (First a) s a -> Maybe a
^? forall s a. HasText s a => Lens' s a
L.text forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasLineBreak s a => Lens' s a
L.lineBreak forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just

-- | Returns the background color of the given style state, or the default.
styleBgColor :: StyleState -> Color
styleBgColor :: StyleState -> Color
styleBgColor StyleState
style = forall a. a -> Maybe a -> a
fromMaybe forall a. Default a => a
def Maybe Color
bgColor where
  bgColor :: Maybe Color
bgColor = StyleState
style forall s a. s -> Getting (First a) s a -> Maybe a
^? forall s a. HasBgColor s a => Lens' s a
L.bgColor forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just

-- | Returns the foreground color of the given style state, or the default.
styleFgColor :: StyleState -> Color
styleFgColor :: StyleState -> Color
styleFgColor StyleState
style = forall a. a -> Maybe a -> a
fromMaybe forall a. Default a => a
def Maybe Color
fgColor where
  fgColor :: Maybe Color
fgColor = StyleState
style forall s a. s -> Getting (First a) s a -> Maybe a
^? forall s a. HasFgColor s a => Lens' s a
L.fgColor forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just

-- | Returns the secondary color of the given style state, or the default.
styleSndColor :: StyleState -> Color
styleSndColor :: StyleState -> Color
styleSndColor StyleState
style = forall a. a -> Maybe a -> a
fromMaybe forall a. Default a => a
def Maybe Color
sndColor where
  sndColor :: Maybe Color
sndColor = StyleState
style forall s a. s -> Getting (First a) s a -> Maybe a
^? forall s a. HasSndColor s a => Lens' s a
L.sndColor forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just

-- | Returns the highlight color of the given style state, or the default.
styleHlColor :: StyleState -> Color
styleHlColor :: StyleState -> Color
styleHlColor StyleState
style = forall a. a -> Maybe a -> a
fromMaybe forall a. Default a => a
def Maybe Color
hlColor where
  hlColor :: Maybe Color
hlColor = StyleState
style forall s a. s -> Getting (First a) s a -> Maybe a
^? forall s a. HasHlColor s a => Lens' s a
L.hlColor forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just

-- | Returns the size used by border and padding.
getOuterSize :: StyleState -> Size
getOuterSize :: StyleState -> Size
getOuterSize StyleState
style = forall a. a -> Maybe a -> a
fromMaybe forall a. Default a => a
def Maybe Size
size where
  size :: Maybe Size
size = StyleState -> Size -> Maybe Size
addOuterSize StyleState
style forall a. Default a => a
def

-- | Adds border and padding to the given size.
addOuterSize :: StyleState -> Size -> Maybe Size
addOuterSize :: StyleState -> Size -> Maybe Size
addOuterSize StyleState
style Size
sz =
  Size -> Maybe Border -> Maybe Size
addBorderSize Size
sz (StyleState -> Maybe Border
_sstBorder StyleState
style)
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Size -> Maybe Padding -> Maybe Size
`addPaddingSize` StyleState -> Maybe Padding
_sstPadding StyleState
style)

-- | Removes border and padding from the given size.
removeOuterSize :: StyleState -> Size -> Maybe Size
removeOuterSize :: StyleState -> Size -> Maybe Size
removeOuterSize StyleState
style Size
sz =
  Size -> Maybe Border -> Maybe Size
subtractBorderSize Size
sz (StyleState -> Maybe Border
_sstBorder StyleState
style)
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Size -> Maybe Padding -> Maybe Size
`subtractPaddingSize` StyleState -> Maybe Padding
_sstPadding StyleState
style)

-- | Adds border and padding to the given rect.
addOuterBounds :: StyleState -> Rect -> Maybe Rect
addOuterBounds :: StyleState -> Rect -> Maybe Rect
addOuterBounds StyleState
style Rect
rect =
  Rect -> Maybe Border -> Maybe Rect
addBorder Rect
rect (StyleState -> Maybe Border
_sstBorder StyleState
style)
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Rect -> Maybe Padding -> Maybe Rect
`addPadding` StyleState -> Maybe Padding
_sstPadding StyleState
style)

-- | Removes border and padding from the given rect.
removeOuterBounds :: StyleState -> Rect -> Maybe Rect
removeOuterBounds :: StyleState -> Rect -> Maybe Rect
removeOuterBounds StyleState
style Rect
rect =
  Rect -> Maybe Border -> Maybe Rect
subtractBorder Rect
rect (StyleState -> Maybe Border
_sstBorder StyleState
style)
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Rect -> Maybe Padding -> Maybe Rect
`subtractPadding` StyleState -> Maybe Padding
_sstPadding StyleState
style)

-- | Adds border widths to the given rect.
addBorder :: Rect -> Maybe Border -> Maybe Rect
addBorder :: Rect -> Maybe Border -> Maybe Rect
addBorder Rect
rect Maybe Border
border = Maybe Rect
nRect where
  (Double
bl, Double
br, Double
bt, Double
bb) = Maybe Border -> (Double, Double, Double, Double)
borderWidths Maybe Border
border
  nRect :: Maybe Rect
nRect = Rect -> Double -> Double -> Double -> Double -> Maybe Rect
addToRect Rect
rect Double
bl Double
br Double
bt Double
bb

-- | Adds padding the given rect.
addPadding :: Rect -> Maybe Padding -> Maybe Rect
addPadding :: Rect -> Maybe Padding -> Maybe Rect
addPadding Rect
rect Maybe Padding
Nothing = forall a. a -> Maybe a
Just Rect
rect
addPadding Rect
rect (Just (Padding Maybe Double
l Maybe Double
r Maybe Double
t Maybe Double
b)) = Maybe Rect
nRect where
  nRect :: Maybe Rect
nRect = Rect -> Double -> Double -> Double -> Double -> Maybe Rect
addToRect Rect
rect (forall a. Default a => Maybe a -> a
justDef Maybe Double
l) (forall a. Default a => Maybe a -> a
justDef Maybe Double
r) (forall a. Default a => Maybe a -> a
justDef Maybe Double
t) (forall a. Default a => Maybe a -> a
justDef Maybe Double
b)

-- | Subtracts border widths from the given rect.
subtractBorder :: Rect -> Maybe Border -> Maybe Rect
subtractBorder :: Rect -> Maybe Border -> Maybe Rect
subtractBorder Rect
rect Maybe Border
border = Maybe Rect
nRect where
  (Double
bl, Double
br, Double
bt, Double
bb) = Maybe Border -> (Double, Double, Double, Double)
borderWidths Maybe Border
border
  nRect :: Maybe Rect
nRect = Rect -> Double -> Double -> Double -> Double -> Maybe Rect
subtractFromRect Rect
rect Double
bl Double
br Double
bt Double
bb

-- | Subbtracts padding from the given rect.
subtractPadding :: Rect -> Maybe Padding -> Maybe Rect
subtractPadding :: Rect -> Maybe Padding -> Maybe Rect
subtractPadding Rect
rect Maybe Padding
Nothing = forall a. a -> Maybe a
Just Rect
rect
subtractPadding Rect
rect (Just (Padding Maybe Double
l Maybe Double
r Maybe Double
t Maybe Double
b)) = Maybe Rect
nRect where
  nRect :: Maybe Rect
nRect = Rect -> Double -> Double -> Double -> Double -> Maybe Rect
subtractFromRect Rect
rect (forall a. Default a => Maybe a -> a
justDef Maybe Double
l) (forall a. Default a => Maybe a -> a
justDef Maybe Double
r) (forall a. Default a => Maybe a -> a
justDef Maybe Double
t) (forall a. Default a => Maybe a -> a
justDef Maybe Double
b)

{-|
Subtracts border width from radius. This is useful when rendering nested shapes
with rounded corners, which would otherwise have gaps in the corners.
-}
subtractBorderFromRadius :: Maybe Border -> Radius -> Radius
subtractBorderFromRadius :: Maybe Border -> Radius -> Radius
subtractBorderFromRadius Maybe Border
border (Radius Maybe RadiusCorner
rtl Maybe RadiusCorner
rtr Maybe RadiusCorner
rbl Maybe RadiusCorner
rbr) = Radius
newRadius where
  (Double
bl, Double
br, Double
bt, Double
bb) = Maybe Border -> (Double, Double, Double, Double)
borderWidths Maybe Border
border
  ntl :: Maybe RadiusCorner
ntl = Maybe RadiusCorner
rtl forall a b. a -> (a -> b) -> b
& forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasWidth s a => Lens' s a
L.width forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ \Double
w -> forall a. Ord a => a -> a -> a
max Double
0 (Double
w forall a. Num a => a -> a -> a
- forall a. Ord a => a -> a -> a
max Double
bl Double
bt)
  ntr :: Maybe RadiusCorner
ntr = Maybe RadiusCorner
rtr forall a b. a -> (a -> b) -> b
& forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasWidth s a => Lens' s a
L.width forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ \Double
w -> forall a. Ord a => a -> a -> a
max Double
0 (Double
w forall a. Num a => a -> a -> a
- forall a. Ord a => a -> a -> a
max Double
br Double
bt)
  nbl :: Maybe RadiusCorner
nbl = Maybe RadiusCorner
rbl forall a b. a -> (a -> b) -> b
& forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasWidth s a => Lens' s a
L.width forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ \Double
w -> forall a. Ord a => a -> a -> a
max Double
0 (Double
w forall a. Num a => a -> a -> a
- forall a. Ord a => a -> a -> a
max Double
bl Double
bb)
  nbr :: Maybe RadiusCorner
nbr = Maybe RadiusCorner
rbr forall a b. a -> (a -> b) -> b
& forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasWidth s a => Lens' s a
L.width forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ \Double
w -> forall a. Ord a => a -> a -> a
max Double
0 (Double
w forall a. Num a => a -> a -> a
- forall a. Ord a => a -> a -> a
max Double
br Double
bb)
  newRadius :: Radius
newRadius = Maybe RadiusCorner
-> Maybe RadiusCorner
-> Maybe RadiusCorner
-> Maybe RadiusCorner
-> Radius
Radius Maybe RadiusCorner
ntl Maybe RadiusCorner
ntr Maybe RadiusCorner
nbl Maybe RadiusCorner
nbr

{-|
Applies a function to all states of a given style. Useful when trying to set or
reset the same property in all different states.
-}
mapStyleStates :: (StyleState -> StyleState) -> Style -> Style
mapStyleStates :: (StyleState -> StyleState) -> Style -> Style
mapStyleStates StyleState -> StyleState
fn Style
style = Style
newStyle where
  newStyle :: Style
newStyle = Style {
    _styleBasic :: Maybe StyleState
_styleBasic = StyleState -> StyleState
fn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Style -> Maybe StyleState
_styleBasic Style
style,
    _styleHover :: Maybe StyleState
_styleHover = StyleState -> StyleState
fn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Style -> Maybe StyleState
_styleHover Style
style,
    _styleFocus :: Maybe StyleState
_styleFocus = StyleState -> StyleState
fn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Style -> Maybe StyleState
_styleFocus Style
style,
    _styleFocusHover :: Maybe StyleState
_styleFocusHover = StyleState -> StyleState
fn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Style -> Maybe StyleState
_styleFocusHover Style
style,
    _styleActive :: Maybe StyleState
_styleActive = StyleState -> StyleState
fn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Style -> Maybe StyleState
_styleActive Style
style,
    _styleDisabled :: Maybe StyleState
_styleDisabled = StyleState -> StyleState
fn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Style -> Maybe StyleState
_styleDisabled Style
style
  }

-- Internal
addBorderSize :: Size -> Maybe Border -> Maybe Size
addBorderSize :: Size -> Maybe Border -> Maybe Size
addBorderSize Size
sz Maybe Border
border = Maybe Size
nSize where
  (Double
bl, Double
br, Double
bt, Double
bb) = Maybe Border -> (Double, Double, Double, Double)
borderWidths Maybe Border
border
  nSize :: Maybe Size
nSize = Size -> Double -> Double -> Maybe Size
addToSize Size
sz (Double
bl forall a. Num a => a -> a -> a
+ Double
br) (Double
bt forall a. Num a => a -> a -> a
+ Double
bb)

addPaddingSize :: Size -> Maybe Padding -> Maybe Size
addPaddingSize :: Size -> Maybe Padding -> Maybe Size
addPaddingSize Size
sz Maybe Padding
Nothing = forall a. a -> Maybe a
Just Size
sz
addPaddingSize Size
sz (Just (Padding Maybe Double
l Maybe Double
r Maybe Double
t Maybe Double
b)) = Maybe Size
nSize where
  nSize :: Maybe Size
nSize = Size -> Double -> Double -> Maybe Size
addToSize Size
sz (forall a. Default a => Maybe a -> a
justDef Maybe Double
l forall a. Num a => a -> a -> a
+ forall a. Default a => Maybe a -> a
justDef Maybe Double
r) (forall a. Default a => Maybe a -> a
justDef Maybe Double
t forall a. Num a => a -> a -> a
+ forall a. Default a => Maybe a -> a
justDef Maybe Double
b)

subtractBorderSize :: Size -> Maybe Border -> Maybe Size
subtractBorderSize :: Size -> Maybe Border -> Maybe Size
subtractBorderSize Size
sz Maybe Border
border = Maybe Size
nSize where
  (Double
bl, Double
br, Double
bt, Double
bb) = Maybe Border -> (Double, Double, Double, Double)
borderWidths Maybe Border
border
  nSize :: Maybe Size
nSize = Size -> Double -> Double -> Maybe Size
subtractFromSize Size
sz (Double
bl forall a. Num a => a -> a -> a
+ Double
br) (Double
bt forall a. Num a => a -> a -> a
+ Double
bb)

subtractPaddingSize :: Size -> Maybe Padding -> Maybe Size
subtractPaddingSize :: Size -> Maybe Padding -> Maybe Size
subtractPaddingSize Size
sz Maybe Padding
Nothing = forall a. a -> Maybe a
Just Size
sz
subtractPaddingSize Size
sz (Just (Padding Maybe Double
l Maybe Double
r Maybe Double
t Maybe Double
b)) = Maybe Size
nSize where
  nSize :: Maybe Size
nSize = Size -> Double -> Double -> Maybe Size
subtractFromSize Size
sz (forall a. Default a => Maybe a -> a
justDef Maybe Double
l forall a. Num a => a -> a -> a
+ forall a. Default a => Maybe a -> a
justDef Maybe Double
r) (forall a. Default a => Maybe a -> a
justDef Maybe Double
t forall a. Num a => a -> a -> a
+ forall a. Default a => Maybe a -> a
justDef Maybe Double
b)

borderWidths :: Maybe Border -> (Double, Double, Double, Double)
borderWidths :: Maybe Border -> (Double, Double, Double, Double)
borderWidths Maybe Border
Nothing = (Double
0, Double
0, Double
0, Double
0)
borderWidths (Just Border
border) = (Double
bl, Double
br, Double
bt, Double
bb) where
  bl :: Double
bl = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Double
0 BorderSide -> Double
_bsWidth (Border -> Maybe BorderSide
_brdLeft Border
border)
  br :: Double
br = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Double
0 BorderSide -> Double
_bsWidth (Border -> Maybe BorderSide
_brdRight Border
border)
  bt :: Double
bt = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Double
0 BorderSide -> Double
_bsWidth (Border -> Maybe BorderSide
_brdTop Border
border)
  bb :: Double
bb = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Double
0 BorderSide -> Double
_bsWidth (Border -> Maybe BorderSide
_brdBottom Border
border)

mergeNodeStyleState
  :: Lens' Style (Maybe StyleState)
  -> WidgetNode s e
  -> [StyleState]
  -> WidgetNode s e
mergeNodeStyleState :: forall s e.
Lens' Style (Maybe StyleState)
-> WidgetNode s e -> [StyleState] -> WidgetNode s e
mergeNodeStyleState Lens' Style (Maybe StyleState)
field WidgetNode s e
node [StyleState]
states = WidgetNode s e
newNode where
  oldStyle :: Style
oldStyle = WidgetNode s e
node forall s a. s -> Getting a s a -> a
^. forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasStyle s a => Lens' s a
L.style
  oldState :: StyleState
oldState = Style
oldStyle forall s a. s -> Getting a s a -> a
^. Lens' Style (Maybe StyleState)
field forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => a -> Iso' (Maybe a) a
non forall a. Default a => a
def
  !mcatStates :: StyleState
mcatStates = forall a. Monoid a => [a] -> a
mconcat [StyleState]
states
  !newStates :: StyleState
newStates = StyleState
oldState forall a. Semigroup a => a -> a -> a
<> StyleState
mcatStates
  !newStyle :: Style
newStyle = Style
oldStyle
    forall a b. a -> (a -> b) -> b
& Lens' Style (Maybe StyleState)
field forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ StyleState
newStates
  !newNode :: WidgetNode s e
newNode = WidgetNode s e
node
    forall a b. a -> (a -> b) -> b
& forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasStyle s a => Lens' s a
L.style forall s t a b. ASetter s t a b -> b -> s -> t
.~ Style
newStyle

setNodeStyleState
  :: Lens' Style (Maybe StyleState)
  -> WidgetNode s e
  -> [StyleState]
  -> WidgetNode s e
setNodeStyleState :: forall s e.
Lens' Style (Maybe StyleState)
-> WidgetNode s e -> [StyleState] -> WidgetNode s e
setNodeStyleState Lens' Style (Maybe StyleState)
field WidgetNode s e
node [StyleState]
states = WidgetNode s e
newNode where
  oldStyle :: Style
oldStyle = WidgetNode s e
node forall s a. s -> Getting a s a -> a
^. forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasStyle s a => Lens' s a
L.style
  !newStates :: StyleState
newStates = forall a. Monoid a => [a] -> a
mconcat [StyleState]
states
  !newStyle :: Style
newStyle = Style
oldStyle
    forall a b. a -> (a -> b) -> b
& Lens' Style (Maybe StyleState)
field forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ StyleState
newStates
  !newNode :: WidgetNode s e
newNode = WidgetNode s e
node
    forall a b. a -> (a -> b) -> b
& forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasStyle s a => Lens' s a
L.style forall s t a b. ASetter s t a b -> b -> s -> t
.~ Style
newStyle

justDef :: (Default a) => Maybe a -> a
justDef :: forall a. Default a => Maybe a -> a
justDef Maybe a
val = forall a. a -> Maybe a -> a
fromMaybe forall a. Default a => a
def Maybe a
val