{-|
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
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
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 {
    _tmcClearBg :: Maybe Bool
_tmcClearBg = forall a. Maybe a
Nothing
  }

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

instance Monoid ThemeSwitchCfg where
  mempty :: ThemeSwitchCfg
mempty = 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 = forall a. Default a => a
def {
  _tmcClearBg :: Maybe Bool
_tmcClearBg = 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           -- ^ The new theme.
  -> WidgetNode s e  -- ^ The child node.
  -> WidgetNode s e  -- ^ The created themeSwitch container.
themeSwitch :: forall s e. Theme -> WidgetNode s e -> WidgetNode s e
themeSwitch Theme
theme WidgetNode s e
managed = forall s e.
Theme -> [ThemeSwitchCfg] -> WidgetNode s e -> WidgetNode s e
themeSwitch_ Theme
theme forall a. Default a => a
def WidgetNode s e
managed

-- | Switches to a new theme starting from its child node. Accepts config.
themeSwitch_
  :: Theme             -- ^ The new theme.
  -> [ThemeSwitchCfg]  -- ^ The config options.
  -> WidgetNode s e    -- ^ The child node.
  -> WidgetNode s e    -- ^ The created themeSwitch container.
themeSwitch_ :: forall s e.
Theme -> [ThemeSwitchCfg] -> WidgetNode s e -> WidgetNode s e
themeSwitch_ Theme
theme [ThemeSwitchCfg]
configs WidgetNode s e
managed = forall s e. Widget s e -> WidgetNode s e -> WidgetNode s e
makeNode forall {s} {e}. Widget s e
widget WidgetNode s e
managed where
  config :: ThemeSwitchCfg
config = forall a. Monoid a => [a] -> a
mconcat [ThemeSwitchCfg]
configs
  state :: ThemeSwitchState
state = Maybe Theme -> Bool -> ThemeSwitchState
ThemeSwitchState forall a. Maybe a
Nothing Bool
False
  widget :: Widget s e
widget = 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 :: forall s e. Widget s e -> WidgetNode s e -> WidgetNode s e
makeNode Widget s e
widget WidgetNode s e
managedWidget = forall s e. WidgetType -> Widget s e -> WidgetNode s e
defaultWidgetNode WidgetType
"themeSwitch" Widget s e
widget
  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
False
  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
managedWidget

makeThemeSwitch :: Theme -> ThemeSwitchCfg -> ThemeSwitchState -> Widget s e
makeThemeSwitch :: forall s e.
Theme -> ThemeSwitchCfg -> ThemeSwitchState -> Widget s e
makeThemeSwitch Theme
theme ThemeSwitchCfg
config ThemeSwitchState
state = 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 ThemeSwitchState
state forall a. Default a => a
def {
    containerUpdateCWenv :: ContainerUpdateCWenvHandler s e
containerUpdateCWenv = forall {p} {p} {p} {p}.
(HasTheme p Theme, HasThemeChanged p Bool) =>
p -> p -> p -> p -> p
updateCWenv,
    containerGetCurrentStyle :: ContainerGetCurrentStyle s e
containerGetCurrentStyle = forall {t} {p} {p}. (CmbBgColor t, Default t) => p -> p -> t
getCurrentStyle,
    containerInit :: ContainerInitHandler s e
containerInit = forall {p} {s} {e}. p -> WidgetNode s e -> WidgetResult s e
init,
    containerMerge :: ContainerMergeHandler s e ThemeSwitchState
containerMerge = forall {p} {s} {e} {p}.
p -> WidgetNode s e -> p -> ThemeSwitchState -> WidgetResult s e
merge
  }

  updateCWenv :: p -> p -> p -> p -> p
updateCWenv p
wenv p
cidx p
cnode p
node = p
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
|| forall a. a -> Maybe a
Just Theme
theme forall a. Eq a => a -> a -> Bool
/= Maybe Theme
oldTheme
    parentChanged :: Bool
parentChanged = p
wenv forall s a. s -> Getting a s a -> a
^. forall s a. HasThemeChanged s a => Lens' s a
L.themeChanged
    newWenv :: p
newWenv = p
wenv
      forall a b. a -> (a -> b) -> b
& forall s a. HasTheme s a => Lens' s a
L.theme forall s t a b. ASetter s t a b -> b -> s -> t
.~ Theme
theme
      forall a b. a -> (a -> b) -> b
& forall s a. HasThemeChanged s a => Lens' s a
L.themeChanged forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Bool
themeChanged Bool -> Bool -> Bool
|| Bool
parentChanged)

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

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