{-|
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.

@
theme = case activeTheme of
  DarkTheme -> darkTheme
  LightTheme -> lightTheme

widgetTree = themeSwitch theme $ vstack [
    hstack [
      label "Select theme:",
      spacer,
      textDropdownS activeTheme [DarkTheme, LightTheme]
    ]
  ]
@

Note: this widget ignores style settings applied to itself. 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 #-}
{-# LANGUAGE StrictData #-}

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