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

Button widget, with support for multiline text. At the most basic level, a
button consists of a caption and an event to raise when clicked.
-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}

module Monomer.Widgets.Singles.Button (
  -- * Configuration
  ButtonCfg,
  -- * Constructors
  button,
  button_,
  mainButton,
  mainButton_
) where

import Control.Applicative ((<|>))
import Control.Lens ((&), (^.), (.~))
import Data.Default
import Data.Maybe
import Data.Text (Text)

import qualified Data.Sequence as Seq

import Monomer.Widgets.Container
import Monomer.Widgets.Singles.Label

import qualified Monomer.Lens as L

data ButtonType
  = ButtonNormal
  | ButtonMain
  deriving (ButtonType -> ButtonType -> Bool
(ButtonType -> ButtonType -> Bool)
-> (ButtonType -> ButtonType -> Bool) -> Eq ButtonType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ButtonType -> ButtonType -> Bool
$c/= :: ButtonType -> ButtonType -> Bool
== :: ButtonType -> ButtonType -> Bool
$c== :: ButtonType -> ButtonType -> Bool
Eq, Int -> ButtonType -> ShowS
[ButtonType] -> ShowS
ButtonType -> String
(Int -> ButtonType -> ShowS)
-> (ButtonType -> String)
-> ([ButtonType] -> ShowS)
-> Show ButtonType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ButtonType] -> ShowS
$cshowList :: [ButtonType] -> ShowS
show :: ButtonType -> String
$cshow :: ButtonType -> String
showsPrec :: Int -> ButtonType -> ShowS
$cshowsPrec :: Int -> ButtonType -> ShowS
Show)

{-|
Configuration options for button:

- 'trimSpaces': whether to remove leading/trailing spaces in the caption.
- 'ellipsis': if ellipsis should be used for overflown text.
- 'multiline': if text may be split in multiple lines.
- 'maxLines': maximum number of text lines to show.
- 'onFocus': event to raise when focus is received.
- 'onFocusReq': 'WidgetRequest' to generate when focus is received.
- 'onBlur': event to raise when focus is lost.
- 'onBlurReq': 'WidgetRequest' to generate when focus is lost.
- 'onClick': event to raise when button is clicked.
- 'onClickReq': 'WidgetRequest' to generate when button is clicked.
- 'resizeFactor': flexibility to have more or less spaced assigned.
- 'resizeFactorW': flexibility to have more or less horizontal spaced assigned.
- 'resizeFactorH': flexibility to have more or less vertical spaced assigned.
-}
data ButtonCfg s e = ButtonCfg {
  ButtonCfg s e -> Maybe ButtonType
_btnButtonType :: Maybe ButtonType,
  ButtonCfg s e -> Maybe Bool
_btnIgnoreTheme :: Maybe Bool,
  ButtonCfg s e -> LabelCfg s e
_btnLabelCfg :: LabelCfg s e,
  ButtonCfg s e -> [Path -> WidgetRequest s e]
_btnOnFocusReq :: [Path -> WidgetRequest s e],
  ButtonCfg s e -> [Path -> WidgetRequest s e]
_btnOnBlurReq :: [Path -> WidgetRequest s e],
  ButtonCfg s e -> [WidgetRequest s e]
_btnOnClickReq :: [WidgetRequest s e]
}

instance Default (ButtonCfg s e) where
  def :: ButtonCfg s e
def = ButtonCfg :: forall s e.
Maybe ButtonType
-> Maybe Bool
-> LabelCfg s e
-> [Path -> WidgetRequest s e]
-> [Path -> WidgetRequest s e]
-> [WidgetRequest s e]
-> ButtonCfg s e
ButtonCfg {
    _btnButtonType :: Maybe ButtonType
_btnButtonType = Maybe ButtonType
forall a. Maybe a
Nothing,
    _btnIgnoreTheme :: Maybe Bool
_btnIgnoreTheme = Maybe Bool
forall a. Maybe a
Nothing,
    _btnLabelCfg :: LabelCfg s e
_btnLabelCfg = LabelCfg s e
forall a. Default a => a
def,
    _btnOnFocusReq :: [Path -> WidgetRequest s e]
_btnOnFocusReq = [],
    _btnOnBlurReq :: [Path -> WidgetRequest s e]
_btnOnBlurReq = [],
    _btnOnClickReq :: [WidgetRequest s e]
_btnOnClickReq = []
  }

instance Semigroup (ButtonCfg s e) where
  <> :: ButtonCfg s e -> ButtonCfg s e -> ButtonCfg s e
(<>) ButtonCfg s e
t1 ButtonCfg s e
t2 = ButtonCfg :: forall s e.
Maybe ButtonType
-> Maybe Bool
-> LabelCfg s e
-> [Path -> WidgetRequest s e]
-> [Path -> WidgetRequest s e]
-> [WidgetRequest s e]
-> ButtonCfg s e
ButtonCfg {
    _btnButtonType :: Maybe ButtonType
_btnButtonType = ButtonCfg s e -> Maybe ButtonType
forall s e. ButtonCfg s e -> Maybe ButtonType
_btnButtonType ButtonCfg s e
t2 Maybe ButtonType -> Maybe ButtonType -> Maybe ButtonType
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ButtonCfg s e -> Maybe ButtonType
forall s e. ButtonCfg s e -> Maybe ButtonType
_btnButtonType ButtonCfg s e
t1,
    _btnIgnoreTheme :: Maybe Bool
_btnIgnoreTheme = ButtonCfg s e -> Maybe Bool
forall s e. ButtonCfg s e -> Maybe Bool
_btnIgnoreTheme ButtonCfg s e
t2 Maybe Bool -> Maybe Bool -> Maybe Bool
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ButtonCfg s e -> Maybe Bool
forall s e. ButtonCfg s e -> Maybe Bool
_btnIgnoreTheme ButtonCfg s e
t1,
    _btnLabelCfg :: LabelCfg s e
_btnLabelCfg = ButtonCfg s e -> LabelCfg s e
forall s e. ButtonCfg s e -> LabelCfg s e
_btnLabelCfg ButtonCfg s e
t1 LabelCfg s e -> LabelCfg s e -> LabelCfg s e
forall a. Semigroup a => a -> a -> a
<> ButtonCfg s e -> LabelCfg s e
forall s e. ButtonCfg s e -> LabelCfg s e
_btnLabelCfg ButtonCfg s e
t2,
    _btnOnFocusReq :: [Path -> WidgetRequest s e]
_btnOnFocusReq = ButtonCfg s e -> [Path -> WidgetRequest s e]
forall s e. ButtonCfg s e -> [Path -> WidgetRequest s e]
_btnOnFocusReq ButtonCfg s e
t1 [Path -> WidgetRequest s e]
-> [Path -> WidgetRequest s e] -> [Path -> WidgetRequest s e]
forall a. Semigroup a => a -> a -> a
<> ButtonCfg s e -> [Path -> WidgetRequest s e]
forall s e. ButtonCfg s e -> [Path -> WidgetRequest s e]
_btnOnFocusReq ButtonCfg s e
t2,
    _btnOnBlurReq :: [Path -> WidgetRequest s e]
_btnOnBlurReq = ButtonCfg s e -> [Path -> WidgetRequest s e]
forall s e. ButtonCfg s e -> [Path -> WidgetRequest s e]
_btnOnBlurReq ButtonCfg s e
t1 [Path -> WidgetRequest s e]
-> [Path -> WidgetRequest s e] -> [Path -> WidgetRequest s e]
forall a. Semigroup a => a -> a -> a
<> ButtonCfg s e -> [Path -> WidgetRequest s e]
forall s e. ButtonCfg s e -> [Path -> WidgetRequest s e]
_btnOnBlurReq ButtonCfg s e
t2,
    _btnOnClickReq :: [WidgetRequest s e]
_btnOnClickReq = ButtonCfg s e -> [WidgetRequest s e]
forall s e. ButtonCfg s e -> [WidgetRequest s e]
_btnOnClickReq ButtonCfg s e
t1 [WidgetRequest s e] -> [WidgetRequest s e] -> [WidgetRequest s e]
forall a. Semigroup a => a -> a -> a
<> ButtonCfg s e -> [WidgetRequest s e]
forall s e. ButtonCfg s e -> [WidgetRequest s e]
_btnOnClickReq ButtonCfg s e
t2
  }

instance Monoid (ButtonCfg s e) where
  mempty :: ButtonCfg s e
mempty = ButtonCfg s e
forall a. Default a => a
def

instance CmbIgnoreTheme (ButtonCfg s e) where
  ignoreTheme_ :: Bool -> ButtonCfg s e
ignoreTheme_ Bool
ignore = ButtonCfg s e
forall a. Default a => a
def {
    _btnIgnoreTheme :: Maybe Bool
_btnIgnoreTheme = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
ignore
  }

instance CmbTrimSpaces (ButtonCfg s e) where
  trimSpaces_ :: Bool -> ButtonCfg s e
trimSpaces_ Bool
trim = ButtonCfg s e
forall a. Default a => a
def {
    _btnLabelCfg :: LabelCfg s e
_btnLabelCfg = Bool -> LabelCfg s e
forall t. CmbTrimSpaces t => Bool -> t
trimSpaces_ Bool
trim
  }

instance CmbEllipsis (ButtonCfg s e) where
  ellipsis_ :: Bool -> ButtonCfg s e
ellipsis_ Bool
ellipsis = ButtonCfg s e
forall a. Default a => a
def {
    _btnLabelCfg :: LabelCfg s e
_btnLabelCfg = Bool -> LabelCfg s e
forall t. CmbEllipsis t => Bool -> t
ellipsis_ Bool
ellipsis
  }

instance CmbMultiline (ButtonCfg s e) where
  multiline_ :: Bool -> ButtonCfg s e
multiline_ Bool
multi = ButtonCfg s e
forall a. Default a => a
def {
    _btnLabelCfg :: LabelCfg s e
_btnLabelCfg = Bool -> LabelCfg s e
forall t. CmbMultiline t => Bool -> t
multiline_ Bool
multi
  }

instance CmbMaxLines (ButtonCfg s e) where
  maxLines :: Int -> ButtonCfg s e
maxLines Int
count = ButtonCfg s e
forall a. Default a => a
def {
    _btnLabelCfg :: LabelCfg s e
_btnLabelCfg = Int -> LabelCfg s e
forall t. CmbMaxLines t => Int -> t
maxLines Int
count
  }

instance CmbResizeFactor (ButtonCfg s e) where
  resizeFactor :: Double -> ButtonCfg s e
resizeFactor Double
s = ButtonCfg s e
forall a. Default a => a
def {
    _btnLabelCfg :: LabelCfg s e
_btnLabelCfg = Double -> LabelCfg s e
forall t. CmbResizeFactor t => Double -> t
resizeFactor Double
s
  }

instance CmbResizeFactorDim (ButtonCfg s e) where
  resizeFactorW :: Double -> ButtonCfg s e
resizeFactorW Double
w = ButtonCfg s e
forall a. Default a => a
def {
    _btnLabelCfg :: LabelCfg s e
_btnLabelCfg = Double -> LabelCfg s e
forall t. CmbResizeFactorDim t => Double -> t
resizeFactorW Double
w
  }
  resizeFactorH :: Double -> ButtonCfg s e
resizeFactorH Double
h = ButtonCfg s e
forall a. Default a => a
def {
    _btnLabelCfg :: LabelCfg s e
_btnLabelCfg = Double -> LabelCfg s e
forall t. CmbResizeFactorDim t => Double -> t
resizeFactorH Double
h
  }

instance WidgetEvent e => CmbOnFocus (ButtonCfg s e) e Path where
  onFocus :: (Path -> e) -> ButtonCfg s e
onFocus Path -> e
fn = ButtonCfg s e
forall a. Default a => a
def {
    _btnOnFocusReq :: [Path -> WidgetRequest s e]
_btnOnFocusReq = [e -> WidgetRequest s e
forall s e. WidgetEvent e => e -> WidgetRequest s e
RaiseEvent (e -> WidgetRequest s e)
-> (Path -> e) -> Path -> WidgetRequest s e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> e
fn]
  }

instance CmbOnFocusReq (ButtonCfg s e) s e Path where
  onFocusReq :: (Path -> WidgetRequest s e) -> ButtonCfg s e
onFocusReq Path -> WidgetRequest s e
req = ButtonCfg s e
forall a. Default a => a
def {
    _btnOnFocusReq :: [Path -> WidgetRequest s e]
_btnOnFocusReq = [Path -> WidgetRequest s e
req]
  }

instance WidgetEvent e => CmbOnBlur (ButtonCfg s e) e Path where
  onBlur :: (Path -> e) -> ButtonCfg s e
onBlur Path -> e
fn = ButtonCfg s e
forall a. Default a => a
def {
    _btnOnBlurReq :: [Path -> WidgetRequest s e]
_btnOnBlurReq = [e -> WidgetRequest s e
forall s e. WidgetEvent e => e -> WidgetRequest s e
RaiseEvent (e -> WidgetRequest s e)
-> (Path -> e) -> Path -> WidgetRequest s e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> e
fn]
  }

instance CmbOnBlurReq (ButtonCfg s e) s e Path where
  onBlurReq :: (Path -> WidgetRequest s e) -> ButtonCfg s e
onBlurReq Path -> WidgetRequest s e
req = ButtonCfg s e
forall a. Default a => a
def {
    _btnOnBlurReq :: [Path -> WidgetRequest s e]
_btnOnBlurReq = [Path -> WidgetRequest s e
req]
  }

instance WidgetEvent e => CmbOnClick (ButtonCfg s e) e where
  onClick :: e -> ButtonCfg s e
onClick e
handler = ButtonCfg s e
forall a. Default a => a
def {
    _btnOnClickReq :: [WidgetRequest s e]
_btnOnClickReq = [e -> WidgetRequest s e
forall s e. WidgetEvent e => e -> WidgetRequest s e
RaiseEvent e
handler]
  }

instance CmbOnClickReq (ButtonCfg s e) s e where
  onClickReq :: WidgetRequest s e -> ButtonCfg s e
onClickReq WidgetRequest s e
req = ButtonCfg s e
forall a. Default a => a
def {
    _btnOnClickReq :: [WidgetRequest s e]
_btnOnClickReq = [WidgetRequest s e
req]
  }

mainConfig :: ButtonCfg s e
mainConfig :: ButtonCfg s e
mainConfig = ButtonCfg s e
forall a. Default a => a
def {
  _btnButtonType :: Maybe ButtonType
_btnButtonType = ButtonType -> Maybe ButtonType
forall a. a -> Maybe a
Just ButtonType
ButtonMain
}

-- | Creates a button with main styling. Useful for dialogs.
mainButton :: WidgetEvent e => Text -> e -> WidgetNode s e
mainButton :: Text -> e -> WidgetNode s e
mainButton Text
caption e
handler = Text -> e -> [ButtonCfg s e] -> WidgetNode s e
forall e s.
WidgetEvent e =>
Text -> e -> [ButtonCfg s e] -> WidgetNode s e
button_ Text
caption e
handler [ButtonCfg s e
forall s e. ButtonCfg s e
mainConfig]

-- | Creates a button with main styling. Useful for dialogs. Accepts config.
mainButton_ :: WidgetEvent e => Text -> e -> [ButtonCfg s e] -> WidgetNode s e
mainButton_ :: Text -> e -> [ButtonCfg s e] -> WidgetNode s e
mainButton_ Text
caption e
handler [ButtonCfg s e]
configs = Text -> e -> [ButtonCfg s e] -> WidgetNode s e
forall e s.
WidgetEvent e =>
Text -> e -> [ButtonCfg s e] -> WidgetNode s e
button_ Text
caption e
handler [ButtonCfg s e]
newConfigs where
  newConfigs :: [ButtonCfg s e]
newConfigs = ButtonCfg s e
forall s e. ButtonCfg s e
mainConfig ButtonCfg s e -> [ButtonCfg s e] -> [ButtonCfg s e]
forall a. a -> [a] -> [a]
: [ButtonCfg s e]
configs

-- | Creates a button with normal styling.
button :: WidgetEvent e => Text -> e -> WidgetNode s e
button :: Text -> e -> WidgetNode s e
button Text
caption e
handler = Text -> e -> [ButtonCfg s e] -> WidgetNode s e
forall e s.
WidgetEvent e =>
Text -> e -> [ButtonCfg s e] -> WidgetNode s e
button_ Text
caption e
handler [ButtonCfg s e]
forall a. Default a => a
def

-- | Creates a button with normal styling. Accepts config.
button_ :: WidgetEvent e => Text -> e -> [ButtonCfg s e] -> WidgetNode s e
button_ :: Text -> e -> [ButtonCfg s e] -> WidgetNode s e
button_ Text
caption e
handler [ButtonCfg s e]
configs = WidgetNode s e
buttonNode where
  config :: ButtonCfg s e
config = e -> ButtonCfg s e
forall t e. CmbOnClick t e => e -> t
onClick e
handler ButtonCfg s e -> ButtonCfg s e -> ButtonCfg s e
forall a. Semigroup a => a -> a -> a
<> [ButtonCfg s e] -> ButtonCfg s e
forall a. Monoid a => [a] -> a
mconcat [ButtonCfg s e]
configs
  widget :: Widget s e
widget = Text -> ButtonCfg s e -> Widget s e
forall e s. WidgetEvent e => Text -> ButtonCfg s e -> Widget s e
makeButton Text
caption ButtonCfg s e
config
  buttonNode :: WidgetNode s e
buttonNode = WidgetType -> Widget s e -> WidgetNode s e
forall s e. WidgetType -> Widget s e -> WidgetNode s e
defaultWidgetNode WidgetType
"button" 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
True

makeButton :: WidgetEvent e => Text -> ButtonCfg s e -> Widget s e
makeButton :: Text -> ButtonCfg s e -> Widget s e
makeButton Text
caption ButtonCfg s e
config = Widget s e
widget where
  widget :: Widget s e
widget = () -> Container s e () -> Widget s e
forall a s e. WidgetModel a => a -> Container s e a -> Widget s e
createContainer () Container s e ()
forall a. Default a => a
def {
    containerAddStyleReq :: Bool
containerAddStyleReq = Bool
False,
    containerUseScissor :: Bool
containerUseScissor = Bool
True,
    containerGetBaseStyle :: ContainerGetBaseStyle s e
containerGetBaseStyle = ContainerGetBaseStyle s e
forall s e p. WidgetEnv s e -> p -> Maybe Style
getBaseStyle,
    containerGetCurrentStyle :: ContainerGetCurrentStyle s e
containerGetCurrentStyle = ContainerGetCurrentStyle s e
forall s e. WidgetEnv s e -> WidgetNode s e -> StyleState
getCurrentStyle,
    containerInit :: ContainerInitHandler s e
containerInit = ContainerInitHandler s e
forall p. p -> WidgetNode s e -> WidgetResult s e
init,
    containerMerge :: ContainerMergeHandler s e ()
containerMerge = ContainerMergeHandler s e ()
forall p p p. p -> WidgetNode s e -> p -> p -> WidgetResult s e
merge,
    containerHandleEvent :: ContainerEventHandler s e
containerHandleEvent = ContainerEventHandler s e
forall p.
WidgetEnv s e
-> WidgetNode s e -> p -> SystemEvent -> Maybe (WidgetResult s e)
handleEvent,
    containerGetSizeReq :: ContainerGetSizeReqHandler s e
containerGetSizeReq = ContainerGetSizeReqHandler s e
forall s e. ContainerGetSizeReqHandler s e
getSizeReq,
    containerResize :: ContainerResizeHandler s e
containerResize = ContainerResizeHandler s e
forall p s e a p.
p -> WidgetNode s e -> a -> p -> (WidgetResult s e, Seq a)
resize
  }

  buttonType :: ButtonType
buttonType = ButtonType -> Maybe ButtonType -> ButtonType
forall a. a -> Maybe a -> a
fromMaybe ButtonType
ButtonNormal (ButtonCfg s e -> Maybe ButtonType
forall s e. ButtonCfg s e -> Maybe ButtonType
_btnButtonType ButtonCfg s e
config)

  getBaseStyle :: WidgetEnv s e -> p -> Maybe Style
getBaseStyle WidgetEnv s e
wenv p
node
    | Bool
ignoreTheme = Maybe Style
forall a. Maybe a
Nothing
    | Bool
otherwise = case ButtonType
buttonType of
        ButtonType
ButtonNormal -> Style -> Maybe Style
forall a. a -> Maybe a
Just (WidgetEnv s e -> Lens' ThemeState StyleState -> Style
forall s e. WidgetEnv s e -> Lens' ThemeState StyleState -> Style
collectTheme WidgetEnv s e
wenv forall s a. HasBtnStyle s a => Lens' s a
Lens' ThemeState StyleState
L.btnStyle)
        ButtonType
ButtonMain -> Style -> Maybe Style
forall a. a -> Maybe a
Just (WidgetEnv s e -> Lens' ThemeState StyleState -> Style
forall s e. WidgetEnv s e -> Lens' ThemeState StyleState -> Style
collectTheme WidgetEnv s e
wenv forall s a. HasBtnMainStyle s a => Lens' s a
Lens' ThemeState StyleState
L.btnMainStyle)
    where
      ignoreTheme :: Bool
ignoreTheme = ButtonCfg s e -> Maybe Bool
forall s e. ButtonCfg s e -> Maybe Bool
_btnIgnoreTheme ButtonCfg s e
config Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True

  getCurrentStyle :: WidgetEnv s e -> WidgetNode s e -> StyleState
getCurrentStyle WidgetEnv s e
wenv WidgetNode s e
node = StyleState
styleState where
    style :: Style
style = WidgetNode s e
node WidgetNode s e -> Getting Style (WidgetNode s e) Style -> Style
forall s a. s -> Getting a s a -> a
^. (WidgetNodeInfo -> Const Style WidgetNodeInfo)
-> WidgetNode s e -> Const Style (WidgetNode s e)
forall s a. HasInfo s a => Lens' s a
L.info ((WidgetNodeInfo -> Const Style WidgetNodeInfo)
 -> WidgetNode s e -> Const Style (WidgetNode s e))
-> ((Style -> Const Style Style)
    -> WidgetNodeInfo -> Const Style WidgetNodeInfo)
-> Getting Style (WidgetNode s e) Style
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Style -> Const Style Style)
-> WidgetNodeInfo -> Const Style WidgetNodeInfo
forall s a. HasStyle s a => Lens' s a
L.style
    isEnabled :: Bool
isEnabled = WidgetNode s e
node WidgetNode s e -> Getting Bool (WidgetNode s e) Bool -> Bool
forall s a. s -> Getting a s a -> a
^. (WidgetNodeInfo -> Const Bool WidgetNodeInfo)
-> WidgetNode s e -> Const Bool (WidgetNode s e)
forall s a. HasInfo s a => Lens' s a
L.info ((WidgetNodeInfo -> Const Bool WidgetNodeInfo)
 -> WidgetNode s e -> Const Bool (WidgetNode s e))
-> ((Bool -> Const Bool Bool)
    -> WidgetNodeInfo -> Const Bool WidgetNodeInfo)
-> Getting Bool (WidgetNode s e) Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Const Bool Bool)
-> WidgetNodeInfo -> Const Bool WidgetNodeInfo
forall s a. HasEnabled s a => Lens' s a
L.enabled
    isActive :: Bool
isActive = WidgetEnv s e -> WidgetNode s e -> Bool
forall s e. WidgetEnv s e -> WidgetNode s e -> Bool
isNodeTreeActive WidgetEnv s e
wenv WidgetNode s e
node
    styleState :: StyleState
styleState
      | Bool
isEnabled Bool -> Bool -> Bool
&& Bool
isActive = StyleState -> Maybe StyleState -> StyleState
forall a. a -> Maybe a -> a
fromMaybe StyleState
forall a. Default a => a
def (Style -> Maybe StyleState
_styleActive Style
style)
      | Bool
otherwise = WidgetEnv s e -> WidgetNode s e -> StyleState
forall s e. WidgetEnv s e -> WidgetNode s e -> StyleState
currentStyle WidgetEnv s e
wenv WidgetNode s e
node

  createChildNode :: p -> b -> b
createChildNode p
wenv b
node = b
newNode where
    nodeStyle :: Style
nodeStyle = b
node b -> Getting Style b Style -> Style
forall s a. s -> Getting a s a -> a
^. (a -> Const Style a) -> b -> Const Style b
forall s a. HasInfo s a => Lens' s a
L.info ((a -> Const Style a) -> b -> Const Style b)
-> ((Style -> Const Style Style) -> a -> Const Style a)
-> Getting Style b Style
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Style -> Const Style Style) -> a -> Const Style a
forall s a. HasStyle s a => Lens' s a
L.style
    labelCfg :: LabelCfg s e
labelCfg = ButtonCfg s e -> LabelCfg s e
forall s e. ButtonCfg s e -> LabelCfg s e
_btnLabelCfg ButtonCfg s e
config
    labelCurrStyle :: LabelCfg s e
labelCurrStyle = (WidgetEnv s e -> WidgetNode s e -> StyleState) -> LabelCfg s e
forall s e.
(WidgetEnv s e -> WidgetNode s e -> StyleState) -> LabelCfg s e
labelCurrentStyle WidgetEnv s e -> WidgetNode s e -> StyleState
forall s e. WidgetEnv s e -> WidgetNode s e -> StyleState
childOfFocusedStyle
    labelNode :: WidgetNode s e
labelNode = Text -> [LabelCfg s e] -> WidgetNode s e
forall s e. Text -> [LabelCfg s e] -> WidgetNode s e
label_ Text
caption [LabelCfg s e
forall t. CmbIgnoreTheme t => t
ignoreTheme, LabelCfg s e
labelCfg, LabelCfg s e
forall s e. LabelCfg s e
labelCurrStyle]
      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))
-> ((Style -> Identity Style)
    -> WidgetNodeInfo -> Identity WidgetNodeInfo)
-> (Style -> Identity Style)
-> WidgetNode s e
-> Identity (WidgetNode s e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Style -> Identity Style)
-> WidgetNodeInfo -> Identity WidgetNodeInfo
forall s a. HasStyle s a => Lens' s a
L.style ((Style -> Identity Style)
 -> WidgetNode s e -> Identity (WidgetNode s e))
-> Style -> WidgetNode s e -> WidgetNode s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Style
nodeStyle
    newNode :: b
newNode = b
node
      b -> (b -> b) -> b
forall a b. a -> (a -> b) -> b
& (Seq (WidgetNode s e) -> Identity (Seq (WidgetNode s e)))
-> b -> Identity b
forall s a. HasChildren s a => Lens' s a
L.children ((Seq (WidgetNode s e) -> Identity (Seq (WidgetNode s e)))
 -> b -> Identity b)
-> Seq (WidgetNode s e) -> b -> b
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
labelNode

  init :: p -> WidgetNode s e -> WidgetResult s e
init p
wenv WidgetNode s e
node = WidgetResult s e
result where
    result :: WidgetResult s e
result = WidgetNode s e -> WidgetResult s e
forall s e. WidgetNode s e -> WidgetResult s e
resultNode (p -> WidgetNode s e -> WidgetNode s e
forall b a p.
(HasInfo b a, HasStyle a Style,
 HasChildren b (Seq (WidgetNode s e))) =>
p -> b -> b
createChildNode p
wenv WidgetNode s e
node)

  merge :: p -> WidgetNode s e -> p -> p -> WidgetResult s e
merge p
wenv WidgetNode s e
node p
oldNode p
oldState = WidgetResult s e
result where
    result :: WidgetResult s e
result = WidgetNode s e -> WidgetResult s e
forall s e. WidgetNode s e -> WidgetResult s e
resultNode (p -> WidgetNode s e -> WidgetNode s e
forall b a p.
(HasInfo b a, HasStyle a Style,
 HasChildren b (Seq (WidgetNode s e))) =>
p -> b -> b
createChildNode p
wenv WidgetNode s e
node)

  handleEvent :: WidgetEnv s e
-> WidgetNode s e -> p -> SystemEvent -> Maybe (WidgetResult s e)
handleEvent WidgetEnv s e
wenv WidgetNode s e
node p
target SystemEvent
evt = case SystemEvent
evt of
    Focus Path
prev -> WidgetNode s e
-> Path -> [Path -> WidgetRequest s e] -> Maybe (WidgetResult s e)
forall s e.
WidgetNode s e
-> Path -> [Path -> WidgetRequest s e] -> Maybe (WidgetResult s e)
handleFocusChange WidgetNode s e
node Path
prev (ButtonCfg s e -> [Path -> WidgetRequest s e]
forall s e. ButtonCfg s e -> [Path -> WidgetRequest s e]
_btnOnFocusReq ButtonCfg s e
config)
    Blur Path
next -> WidgetNode s e
-> Path -> [Path -> WidgetRequest s e] -> Maybe (WidgetResult s e)
forall s e.
WidgetNode s e
-> Path -> [Path -> WidgetRequest s e] -> Maybe (WidgetResult s e)
handleFocusChange WidgetNode s e
node Path
next (ButtonCfg s e -> [Path -> WidgetRequest s e]
forall s e. ButtonCfg s e -> [Path -> WidgetRequest s e]
_btnOnBlurReq ButtonCfg s e
config)

    KeyAction KeyMod
mode KeyCode
code KeyStatus
status
      | KeyCode -> Bool
isSelectKey KeyCode
code Bool -> Bool -> Bool
&& KeyStatus
status KeyStatus -> KeyStatus -> Bool
forall a. Eq a => a -> a -> Bool
== KeyStatus
KeyPressed -> WidgetResult s e -> Maybe (WidgetResult s e)
forall a. a -> Maybe a
Just WidgetResult s e
result
      where
        isSelectKey :: KeyCode -> Bool
isSelectKey KeyCode
code = KeyCode -> Bool
isKeyReturn KeyCode
code Bool -> Bool -> Bool
|| KeyCode -> Bool
isKeySpace KeyCode
code

    Click Point
p Button
_ Int
_
      | WidgetNode s e -> Point -> Bool
forall s e. WidgetNode s e -> Point -> Bool
isPointInNodeVp WidgetNode s e
node Point
p -> WidgetResult s e -> Maybe (WidgetResult s e)
forall a. a -> Maybe a
Just WidgetResult s e
result

    ButtonAction Point
p Button
btn ButtonState
BtnPressed Int
1 -- Set focus on click
      | Button -> Bool
forall a. (Eq a, HasMainButton (WidgetEnv s e) a) => a -> Bool
mainBtn Button
btn Bool -> Bool -> Bool
&& Point -> Bool
pointInVp Point
p Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
focused -> WidgetResult s e -> Maybe (WidgetResult s e)
forall a. a -> Maybe a
Just WidgetResult s e
resultFocus

    SystemEvent
_ -> Maybe (WidgetResult s e)
forall a. Maybe a
Nothing
    where
      mainBtn :: a -> Bool
mainBtn a
btn = a
btn a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== WidgetEnv s e
wenv WidgetEnv s e -> Getting a (WidgetEnv s e) a -> a
forall s a. s -> Getting a s a -> a
^. Getting a (WidgetEnv s e) a
forall s a. HasMainButton s a => Lens' s a
L.mainButton
      focused :: Bool
focused = WidgetEnv s e -> WidgetNode s e -> Bool
forall s e. WidgetEnv s e -> WidgetNode s e -> Bool
isNodeFocused WidgetEnv s e
wenv WidgetNode s e
node
      pointInVp :: Point -> Bool
pointInVp Point
p = WidgetNode s e -> Point -> Bool
forall s e. WidgetNode s e -> Point -> Bool
isPointInNodeVp WidgetNode s e
node Point
p
      reqs :: [WidgetRequest s e]
reqs = ButtonCfg s e -> [WidgetRequest s e]
forall s e. ButtonCfg s e -> [WidgetRequest s e]
_btnOnClickReq ButtonCfg s e
config
      result :: WidgetResult s e
result = WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
forall s e.
WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
resultReqs WidgetNode s e
node [WidgetRequest s e]
reqs
      resultFocus :: WidgetResult s e
resultFocus = WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
forall s e.
WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
resultReqs WidgetNode s e
node [WidgetId -> WidgetRequest s e
forall s e. WidgetId -> WidgetRequest s e
SetFocus (WidgetNode s e
node WidgetNode s e
-> Getting WidgetId (WidgetNode s e) WidgetId -> WidgetId
forall s a. s -> Getting a s a -> a
^. (WidgetNodeInfo -> Const WidgetId WidgetNodeInfo)
-> WidgetNode s e -> Const WidgetId (WidgetNode s e)
forall s a. HasInfo s a => Lens' s a
L.info ((WidgetNodeInfo -> Const WidgetId WidgetNodeInfo)
 -> WidgetNode s e -> Const WidgetId (WidgetNode s e))
-> ((WidgetId -> Const WidgetId WidgetId)
    -> WidgetNodeInfo -> Const WidgetId WidgetNodeInfo)
-> Getting WidgetId (WidgetNode s e) WidgetId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WidgetId -> Const WidgetId WidgetId)
-> WidgetNodeInfo -> Const WidgetId WidgetNodeInfo
forall s a. HasWidgetId s a => Lens' s a
L.widgetId)]

  getSizeReq :: ContainerGetSizeReqHandler s e
  getSizeReq :: ContainerGetSizeReqHandler s e
getSizeReq WidgetEnv s e
wenv WidgetNode s e
node Seq (WidgetNode s e)
children = (SizeReq
newReqW, SizeReq
newReqH) where
    -- Main section reqs
    child :: WidgetNode s e
child = Seq (WidgetNode s e) -> Int -> WidgetNode s e
forall a. Seq a -> Int -> a
Seq.index Seq (WidgetNode s e)
children Int
0
    newReqW :: SizeReq
newReqW = WidgetNode s e
child WidgetNode s e
-> Getting SizeReq (WidgetNode s e) SizeReq -> SizeReq
forall s a. s -> Getting a s a -> a
^. (WidgetNodeInfo -> Const SizeReq WidgetNodeInfo)
-> WidgetNode s e -> Const SizeReq (WidgetNode s e)
forall s a. HasInfo s a => Lens' s a
L.info ((WidgetNodeInfo -> Const SizeReq WidgetNodeInfo)
 -> WidgetNode s e -> Const SizeReq (WidgetNode s e))
-> ((SizeReq -> Const SizeReq SizeReq)
    -> WidgetNodeInfo -> Const SizeReq WidgetNodeInfo)
-> Getting SizeReq (WidgetNode s e) SizeReq
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SizeReq -> Const SizeReq SizeReq)
-> WidgetNodeInfo -> Const SizeReq WidgetNodeInfo
forall s a. HasSizeReqW s a => Lens' s a
L.sizeReqW
    newReqH :: SizeReq
newReqH = WidgetNode s e
child WidgetNode s e
-> Getting SizeReq (WidgetNode s e) SizeReq -> SizeReq
forall s a. s -> Getting a s a -> a
^. (WidgetNodeInfo -> Const SizeReq WidgetNodeInfo)
-> WidgetNode s e -> Const SizeReq (WidgetNode s e)
forall s a. HasInfo s a => Lens' s a
L.info ((WidgetNodeInfo -> Const SizeReq WidgetNodeInfo)
 -> WidgetNode s e -> Const SizeReq (WidgetNode s e))
-> ((SizeReq -> Const SizeReq SizeReq)
    -> WidgetNodeInfo -> Const SizeReq WidgetNodeInfo)
-> Getting SizeReq (WidgetNode s e) SizeReq
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SizeReq -> Const SizeReq SizeReq)
-> WidgetNodeInfo -> Const SizeReq WidgetNodeInfo
forall s a. HasSizeReqH s a => Lens' s a
L.sizeReqH

  resize :: p -> WidgetNode s e -> a -> p -> (WidgetResult s e, Seq a)
resize p
wenv WidgetNode s e
node a
viewport p
children = (WidgetResult s e, Seq a)
resized where
    assignedAreas :: Seq a
assignedAreas = [a] -> Seq a
forall a. [a] -> Seq a
Seq.fromList [a
viewport]
    resized :: (WidgetResult s e, Seq a)
resized = (WidgetNode s e -> WidgetResult s e
forall s e. WidgetNode s e -> WidgetResult s e
resultNode WidgetNode s e
node, Seq a
assignedAreas)