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

Switches to the provided theme for its child nodes.

Note: this widget ignores style settings. If you need to display borders or any
other kind of style configuration, set it on the child node or wrap the
themeSwitch widget in a "Monomer.Widgets.Containers.Box".
-}
{-# LANGUAGE FlexibleContexts #-}

module Monomer.Widgets.Containers.ThemeSwitch (
  -- * Configuration
  ThemeSwitchCfg,
  themeClearBg,
  themeClearBg_,
  -- * Constructors
  themeSwitch,
  themeSwitch_
) where

import Control.Applicative ((<|>))
import Control.Monad (when)
import Control.Lens ((&), (^.), (.~), (%~), at)
import Data.Default
import Data.Maybe

import qualified Data.Sequence as Seq

import Monomer.Widgets.Container

import qualified Monomer.Lens as L

{-|
Configuration options for themeSwitch:

- 'themeClearBg': indicates the clear color of the theme should be applied
  before rendering children. Defaults to False.
-}
newtype ThemeSwitchCfg = ThemeSwitchCfg {
  ThemeSwitchCfg -> Maybe Bool
_tmcClearBg :: Maybe Bool
} deriving (ThemeSwitchCfg -> ThemeSwitchCfg -> Bool
(ThemeSwitchCfg -> ThemeSwitchCfg -> Bool)
-> (ThemeSwitchCfg -> ThemeSwitchCfg -> Bool) -> Eq ThemeSwitchCfg
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ThemeSwitchCfg -> ThemeSwitchCfg -> Bool
$c/= :: ThemeSwitchCfg -> ThemeSwitchCfg -> Bool
== :: ThemeSwitchCfg -> ThemeSwitchCfg -> Bool
$c== :: ThemeSwitchCfg -> ThemeSwitchCfg -> Bool
Eq, Int -> ThemeSwitchCfg -> ShowS
[ThemeSwitchCfg] -> ShowS
ThemeSwitchCfg -> String
(Int -> ThemeSwitchCfg -> ShowS)
-> (ThemeSwitchCfg -> String)
-> ([ThemeSwitchCfg] -> ShowS)
-> Show ThemeSwitchCfg
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ThemeSwitchCfg] -> ShowS
$cshowList :: [ThemeSwitchCfg] -> ShowS
show :: ThemeSwitchCfg -> String
$cshow :: ThemeSwitchCfg -> String
showsPrec :: Int -> ThemeSwitchCfg -> ShowS
$cshowsPrec :: Int -> ThemeSwitchCfg -> ShowS
Show)


instance Default ThemeSwitchCfg where
  def :: ThemeSwitchCfg
def = ThemeSwitchCfg :: Maybe Bool -> ThemeSwitchCfg
ThemeSwitchCfg {
    _tmcClearBg :: Maybe Bool
_tmcClearBg = Maybe Bool
forall a. Maybe a
Nothing
  }

instance Semigroup ThemeSwitchCfg where
  <> :: ThemeSwitchCfg -> ThemeSwitchCfg -> ThemeSwitchCfg
(<>) ThemeSwitchCfg
s1 ThemeSwitchCfg
s2 = ThemeSwitchCfg :: Maybe Bool -> ThemeSwitchCfg
ThemeSwitchCfg {
    _tmcClearBg :: Maybe Bool
_tmcClearBg = ThemeSwitchCfg -> Maybe Bool
_tmcClearBg ThemeSwitchCfg
s2 Maybe Bool -> Maybe Bool -> Maybe Bool
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ThemeSwitchCfg -> Maybe Bool
_tmcClearBg ThemeSwitchCfg
s1
  }

instance Monoid ThemeSwitchCfg where
  mempty :: ThemeSwitchCfg
mempty = ThemeSwitchCfg
forall a. Default a => a
def

-- | Indicates the clear color should be applied before rendering children.
themeClearBg :: ThemeSwitchCfg
themeClearBg :: ThemeSwitchCfg
themeClearBg = Bool -> ThemeSwitchCfg
themeClearBg_ Bool
True

-- | Sets whether the clear color should be applied before rendering children.
themeClearBg_ :: Bool -> ThemeSwitchCfg
themeClearBg_ :: Bool -> ThemeSwitchCfg
themeClearBg_ Bool
clear = ThemeSwitchCfg
forall a. Default a => a
def {
  _tmcClearBg :: Maybe Bool
_tmcClearBg = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
clear
}

data ThemeSwitchState = ThemeSwitchState {
  ThemeSwitchState -> Maybe Theme
_tssPrevTheme :: Maybe Theme,
  ThemeSwitchState -> Bool
_tssChanged :: Bool
}

-- | Switches to a new theme starting from its child node.
themeSwitch :: Theme -> WidgetNode s e -> WidgetNode s e
themeSwitch :: Theme -> WidgetNode s e -> WidgetNode s e
themeSwitch Theme
theme WidgetNode s e
managed = Theme -> [ThemeSwitchCfg] -> WidgetNode s e -> WidgetNode s e
forall s e.
Theme -> [ThemeSwitchCfg] -> WidgetNode s e -> WidgetNode s e
themeSwitch_ Theme
theme [ThemeSwitchCfg]
forall a. Default a => a
def WidgetNode s e
managed

-- | Switches to a new theme starting from its child node. Accepts config.
themeSwitch_ :: Theme -> [ThemeSwitchCfg] -> WidgetNode s e -> WidgetNode s e
themeSwitch_ :: Theme -> [ThemeSwitchCfg] -> WidgetNode s e -> WidgetNode s e
themeSwitch_ Theme
theme [ThemeSwitchCfg]
configs WidgetNode s e
managed = Widget s e -> WidgetNode s e -> WidgetNode s e
forall s e. Widget s e -> WidgetNode s e -> WidgetNode s e
makeNode Widget s e
forall s e. Widget s e
widget WidgetNode s e
managed where
  config :: ThemeSwitchCfg
config = [ThemeSwitchCfg] -> ThemeSwitchCfg
forall a. Monoid a => [a] -> a
mconcat [ThemeSwitchCfg]
configs
  state :: ThemeSwitchState
state = Maybe Theme -> Bool -> ThemeSwitchState
ThemeSwitchState Maybe Theme
forall a. Maybe a
Nothing Bool
False
  widget :: Widget s e
widget = Theme -> ThemeSwitchCfg -> ThemeSwitchState -> Widget s e
forall s e.
Theme -> ThemeSwitchCfg -> ThemeSwitchState -> Widget s e
makeThemeSwitch Theme
theme ThemeSwitchCfg
config ThemeSwitchState
state

makeNode :: Widget s e -> WidgetNode s e -> WidgetNode s e
makeNode :: Widget s e -> WidgetNode s e -> WidgetNode s e
makeNode Widget s e
widget WidgetNode s e
managedWidget = WidgetType -> Widget s e -> WidgetNode s e
forall s e. WidgetType -> Widget s e -> WidgetNode s e
defaultWidgetNode WidgetType
"themeSwitch" Widget s e
widget
  WidgetNode s e
-> (WidgetNode s e -> WidgetNode s e) -> WidgetNode s e
forall a b. a -> (a -> b) -> b
& (WidgetNodeInfo -> Identity WidgetNodeInfo)
-> WidgetNode s e -> Identity (WidgetNode s e)
forall s a. HasInfo s a => Lens' s a
L.info ((WidgetNodeInfo -> Identity WidgetNodeInfo)
 -> WidgetNode s e -> Identity (WidgetNode s e))
-> ((Bool -> Identity Bool)
    -> WidgetNodeInfo -> Identity WidgetNodeInfo)
-> (Bool -> Identity Bool)
-> WidgetNode s e
-> Identity (WidgetNode s e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Identity Bool)
-> WidgetNodeInfo -> Identity WidgetNodeInfo
forall s a. HasFocusable s a => Lens' s a
L.focusable ((Bool -> Identity Bool)
 -> WidgetNode s e -> Identity (WidgetNode s e))
-> Bool -> WidgetNode s e -> WidgetNode s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
False
  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
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
managedWidget

makeThemeSwitch :: Theme -> ThemeSwitchCfg -> ThemeSwitchState -> Widget s e
makeThemeSwitch :: Theme -> ThemeSwitchCfg -> ThemeSwitchState -> Widget s e
makeThemeSwitch Theme
theme ThemeSwitchCfg
config ThemeSwitchState
state = Widget s e
forall s e. Widget s e
widget where
  widget :: Widget s e
widget = ThemeSwitchState -> Container s e ThemeSwitchState -> Widget s e
forall a s e. WidgetModel a => a -> Container s e a -> Widget s e
createContainer ThemeSwitchState
state Container s e ThemeSwitchState
forall a. Default a => a
def {
    containerUpdateCWenv :: ContainerUpdateCWenvHandler s e
containerUpdateCWenv = ContainerUpdateCWenvHandler s e
forall b p p p.
(HasTheme b Theme, HasThemeChanged b Bool) =>
b -> p -> p -> p -> b
updateCWenv,
    containerGetCurrentStyle :: ContainerGetCurrentStyle s e
containerGetCurrentStyle = ContainerGetCurrentStyle s e
forall p p p. (CmbBgColor p, Default p) => p -> p -> p
getCurrentStyle,
    containerInit :: ContainerInitHandler s e
containerInit = ContainerInitHandler s e
forall p s e. p -> WidgetNode s e -> WidgetResult s e
init,
    containerMerge :: ContainerMergeHandler s e ThemeSwitchState
containerMerge = ContainerMergeHandler s e ThemeSwitchState
forall p s e p.
p -> WidgetNode s e -> p -> ThemeSwitchState -> WidgetResult s e
merge
  }

  updateCWenv :: b -> p -> p -> p -> b
updateCWenv b
wenv p
cidx p
cnode p
node = b
newWenv where
    oldTheme :: Maybe Theme
oldTheme = ThemeSwitchState -> Maybe Theme
_tssPrevTheme ThemeSwitchState
state
    -- When called during merge, the state has not yet been updated
    themeChanged :: Bool
themeChanged = ThemeSwitchState -> Bool
_tssChanged ThemeSwitchState
state Bool -> Bool -> Bool
|| Theme -> Maybe Theme
forall a. a -> Maybe a
Just Theme
theme Maybe Theme -> Maybe Theme -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Theme
oldTheme
    parentChanged :: Bool
parentChanged = b
wenv b -> Getting Bool b Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool b Bool
forall s a. HasThemeChanged s a => Lens' s a
L.themeChanged
    newWenv :: b
newWenv = b
wenv
      b -> (b -> b) -> b
forall a b. a -> (a -> b) -> b
& (Theme -> Identity Theme) -> b -> Identity b
forall s a. HasTheme s a => Lens' s a
L.theme ((Theme -> Identity Theme) -> b -> Identity b) -> Theme -> b -> b
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Theme
theme
      b -> (b -> b) -> b
forall a b. a -> (a -> b) -> b
& (Bool -> Identity Bool) -> b -> Identity b
forall s a. HasThemeChanged s a => Lens' s a
L.themeChanged ((Bool -> Identity Bool) -> b -> Identity b) -> Bool -> b -> b
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Bool
themeChanged Bool -> Bool -> Bool
|| Bool
parentChanged)

  getCurrentStyle :: p -> p -> p
getCurrentStyle p
wenv p
node = p
style where
    clearBg :: Bool
clearBg = ThemeSwitchCfg -> Maybe Bool
_tmcClearBg ThemeSwitchCfg
config Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
    clearColor :: Color
clearColor = Theme
theme Theme -> Getting Color Theme Color -> Color
forall s a. s -> Getting a s a -> a
^. Getting Color Theme Color
forall s a. HasClearColor s a => Lens' s a
L.clearColor
    style :: p
style
      | Bool
clearBg = Color -> p
forall t. CmbBgColor t => Color -> t
bgColor Color
clearColor
      | Bool
otherwise = p
forall a. Default a => a
def

  init :: p -> WidgetNode s e -> WidgetResult s e
init p
wenv WidgetNode s e
node = WidgetNode s e -> WidgetResult s e
forall s e. WidgetNode s e -> WidgetResult s e
resultNode WidgetNode s e
newNode where
    newState :: ThemeSwitchState
newState = Maybe Theme -> Bool -> ThemeSwitchState
ThemeSwitchState (Theme -> Maybe Theme
forall a. a -> Maybe a
Just Theme
theme) Bool
False
    newNode :: WidgetNode s e
newNode = WidgetNode s e
node
      WidgetNode s e
-> (WidgetNode s e -> WidgetNode s e) -> WidgetNode s e
forall a b. a -> (a -> b) -> b
& (Widget s e -> Identity (Widget s e))
-> WidgetNode s e -> Identity (WidgetNode s e)
forall s a. HasWidget s a => Lens' s a
L.widget ((Widget s e -> Identity (Widget s e))
 -> WidgetNode s e -> Identity (WidgetNode s e))
-> Widget s e -> WidgetNode s e -> WidgetNode s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Theme -> ThemeSwitchCfg -> ThemeSwitchState -> Widget s e
forall s e.
Theme -> ThemeSwitchCfg -> ThemeSwitchState -> Widget s e
makeThemeSwitch Theme
theme ThemeSwitchCfg
config ThemeSwitchState
newState

  merge :: p -> WidgetNode s e -> p -> ThemeSwitchState -> WidgetResult s e
merge p
wenv WidgetNode s e
node p
oldNode ThemeSwitchState
oldState = WidgetNode s e -> WidgetResult s e
forall s e. WidgetNode s e -> WidgetResult s e
resultNode WidgetNode s e
newNode where
    oldTheme :: Maybe Theme
oldTheme = ThemeSwitchState -> Maybe Theme
_tssPrevTheme ThemeSwitchState
oldState
    newState :: ThemeSwitchState
newState = Maybe Theme -> Bool -> ThemeSwitchState
ThemeSwitchState (Theme -> Maybe Theme
forall a. a -> Maybe a
Just Theme
theme) (Theme -> Maybe Theme
forall a. a -> Maybe a
Just Theme
theme Maybe Theme -> Maybe Theme -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Theme
oldTheme)
    newNode :: WidgetNode s e
newNode = WidgetNode s e
node
      WidgetNode s e
-> (WidgetNode s e -> WidgetNode s e) -> WidgetNode s e
forall a b. a -> (a -> b) -> b
& (Widget s e -> Identity (Widget s e))
-> WidgetNode s e -> Identity (WidgetNode s e)
forall s a. HasWidget s a => Lens' s a
L.widget ((Widget s e -> Identity (Widget s e))
 -> WidgetNode s e -> Identity (WidgetNode s e))
-> Widget s e -> WidgetNode s e -> WidgetNode s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Theme -> ThemeSwitchCfg -> ThemeSwitchState -> Widget s e
forall s e.
Theme -> ThemeSwitchCfg -> ThemeSwitchState -> Widget s e
makeThemeSwitch Theme
theme ThemeSwitchCfg
config ThemeSwitchState
newState