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

@
button "Increase count" AppIncrease
@
-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StrictData #-}

module Monomer.Widgets.Singles.Button (
  -- * Configuration
  ButtonCfg,
  -- * Constructors
  mainButton,
  mainButton_,
  mainButtonD_,
  button,
  button_,
  buttonD_
) 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
$c== :: ButtonType -> ButtonType -> Bool
== :: ButtonType -> ButtonType -> Bool
$c/= :: ButtonType -> ButtonType -> Bool
/= :: 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
$cshowsPrec :: Int -> ButtonType -> ShowS
showsPrec :: Int -> ButtonType -> ShowS
$cshow :: ButtonType -> String
show :: ButtonType -> String
$cshowList :: [ButtonType] -> ShowS
showList :: [ButtonType] -> ShowS
Show)

{-|
Configuration options for button:

- 'ignoreParentEvts': whether to ignore all other responses to the click or
  keypress that triggered the button, and only keep this button's response.
  Useful when the button is child of a _keystroke_ widget.
- '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.
- 'ignoreTheme': whether to load default style from theme or start empty.
- 'resizeFactor': flexibility to have more or less space assigned.
- 'resizeFactorW': flexibility to have more or less horizontal space assigned.
- 'resizeFactorH': flexibility to have more or less vertical space assigned.
- '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.
-}
data ButtonCfg s e = ButtonCfg {
  forall s e. ButtonCfg s e -> Maybe ButtonType
_btnButtonType :: Maybe ButtonType,
  forall s e. ButtonCfg s e -> Maybe Bool
_btnIgnoreParent :: Maybe Bool,
  forall s e. ButtonCfg s e -> Maybe Bool
_btnIgnoreTheme :: Maybe Bool,
  forall s e. ButtonCfg s e -> LabelCfg s e
_btnLabelCfg :: LabelCfg s e,
  forall s e. ButtonCfg s e -> [Path -> WidgetRequest s e]
_btnOnFocusReq :: [Path -> WidgetRequest s e],
  forall s e. ButtonCfg s e -> [Path -> WidgetRequest s e]
_btnOnBlurReq :: [Path -> WidgetRequest s e],
  forall s e. ButtonCfg s e -> [WidgetRequest s e]
_btnOnClickReq :: [WidgetRequest s e]
}

instance Default (ButtonCfg s e) where
  def :: ButtonCfg s e
def = ButtonCfg {
    _btnButtonType :: Maybe ButtonType
_btnButtonType = Maybe ButtonType
forall a. Maybe a
Nothing,
    _btnIgnoreParent :: Maybe Bool
_btnIgnoreParent = Maybe Bool
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 {
    _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 a. Maybe a -> Maybe a -> Maybe a
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,
    _btnIgnoreParent :: Maybe Bool
_btnIgnoreParent = ButtonCfg s e -> Maybe Bool
forall s e. ButtonCfg s e -> Maybe Bool
_btnIgnoreParent ButtonCfg s e
t2 Maybe Bool -> Maybe Bool -> Maybe Bool
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ButtonCfg s e -> Maybe Bool
forall s e. ButtonCfg s e -> Maybe Bool
_btnIgnoreParent 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 a. Maybe a -> Maybe a -> Maybe a
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 CmbIgnoreParentEvts (ButtonCfg s e) where
  ignoreParentEvts_ :: Bool -> ButtonCfg s e
ignoreParentEvts_ Bool
ignore = ButtonCfg s e
forall a. Default a => a
def {
    _btnIgnoreParent = Just ignore
  }

instance CmbIgnoreTheme (ButtonCfg s e) where
  ignoreTheme_ :: Bool -> ButtonCfg s e
ignoreTheme_ Bool
ignore = ButtonCfg s e
forall a. Default a => a
def {
    _btnIgnoreTheme = Just 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 = trimSpaces_ 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 = ellipsis_ 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 = multiline_ 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 = maxLines 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 = resizeFactor 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 = resizeFactorW w
  }
  resizeFactorH :: Double -> ButtonCfg s e
resizeFactorH Double
h = ButtonCfg s e
forall a. Default a => a
def {
    _btnLabelCfg = resizeFactorH 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 = [RaiseEvent . 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 = [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 = [RaiseEvent . 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 = [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 = [RaiseEvent 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 = [req]
  }

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

{-|
Creates a button with main styling. Useful to highlight an option, such as
\"Accept\", when multiple buttons are available.
-}
mainButton
  :: WidgetEvent e
  => Text            -- ^ The caption.
  -> e               -- ^ The event to raise on click.
  -> WidgetNode s e  -- ^ The created button.
mainButton :: forall e s. WidgetEvent e => 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 to highlight an option, such as
\"Accept\", when multiple buttons are available. Accepts config.
-}
mainButton_
  :: WidgetEvent e
  => Text             -- ^ The caption.
  -> e                -- ^ The event to raise on click.
  -> [ButtonCfg s e]  -- ^ The config options.
  -> WidgetNode s e   -- ^ The created button.
mainButton_ :: forall e s.
WidgetEvent e =>
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 main styling. Useful to highlight an option, such as
\"Accept\", when multiple buttons are available. Accepts config but does not
require an event. See 'buttonD_'.
-}
mainButtonD_
  :: WidgetEvent e
  => Text             -- ^ The caption.
  -> [ButtonCfg s e]  -- ^ The config options.
  -> WidgetNode s e   -- ^ The created button.
mainButtonD_ :: forall e s.
WidgetEvent e =>
Text -> [ButtonCfg s e] -> WidgetNode s e
mainButtonD_ Text
caption [ButtonCfg s e]
configs = Text -> [ButtonCfg s e] -> WidgetNode s e
forall e s.
WidgetEvent e =>
Text -> [ButtonCfg s e] -> WidgetNode s e
buttonD_ Text
caption [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            -- ^ The caption.
  -> e               -- ^ The event to raise on click.
  -> WidgetNode s e  -- ^ The created button.
button :: forall e s. WidgetEvent e => 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             -- ^ The caption.
  -> e                -- ^ The event to raise on click.
  -> [ButtonCfg s e]  -- ^ The config options.
  -> WidgetNode s e   -- ^ The created button.
button_ :: forall e s.
WidgetEvent e =>
Text -> e -> [ButtonCfg s e] -> WidgetNode s e
button_ Text
caption e
handler [ButtonCfg s e]
configs = WidgetNode s e
buttonNode where
  buttonNode :: WidgetNode s e
buttonNode = Text -> [ButtonCfg s e] -> WidgetNode s e
forall e s.
WidgetEvent e =>
Text -> [ButtonCfg s e] -> WidgetNode s e
buttonD_ Text
caption (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. a -> [a] -> [a]
: [ButtonCfg s e]
configs)

{-|
Creates a button without forcing an event to be provided. The other constructors
use this version, adding an 'onClick' handler in configs.

Using this constructor directly can be helpful in cases where the event to be
raised belongs in a "Monomer.Widgets.Composite" above in the widget tree,
outside the scope of the Composite that contains the button. This parent
Composite can be reached by sending a message ('SendMessage') to its 'WidgetId'
using 'onClickReq'.
-}
buttonD_
  :: WidgetEvent e
  => Text             -- ^ The caption.
  -> [ButtonCfg s e]  -- ^ The config options.
  -> WidgetNode s e   -- ^ The created button.
buttonD_ :: forall e s.
WidgetEvent e =>
Text -> [ButtonCfg s e] -> WidgetNode s e
buttonD_ Text
caption [ButtonCfg s e]
configs = WidgetNode s e
buttonNode where
  config :: ButtonCfg s e
config = [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
Lens' (WidgetNode s e) WidgetNodeInfo
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
Lens' WidgetNodeInfo Bool
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 :: forall e s. WidgetEvent e => 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 = False,
    containerDrawDecorations = False,
    containerUseScissor = True,
    containerGetBaseStyle = getBaseStyle,
    containerInit = init,
    containerMerge = merge,
    containerHandleEvent = handleEvent,
    containerResize = 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 (StyleState -> f StyleState) -> ThemeState -> f ThemeState
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 (StyleState -> f StyleState) -> ThemeState -> f ThemeState
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

  createChildNode :: p -> p -> p
createChildNode p
wenv p
node = p
newNode where
    nodeStyle :: Style
nodeStyle = p
node p -> Getting Style p Style -> Style
forall s a. s -> Getting a s a -> a
^. (a -> Const Style a) -> p -> Const Style p
forall s a. HasInfo s a => Lens' s a
Lens' p a
L.info ((a -> Const Style a) -> p -> Const Style p)
-> ((Style -> Const Style Style) -> a -> Const Style a)
-> Getting Style p 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
Lens' a Style
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
Lens' (WidgetNode s e) WidgetNodeInfo
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
Lens' WidgetNodeInfo Style
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 :: p
newNode = p
node
      p -> (p -> p) -> p
forall a b. a -> (a -> b) -> b
& (Seq (WidgetNode s e) -> Identity (Seq (WidgetNode s e)))
-> p -> Identity p
forall s a. HasChildren s a => Lens' s a
Lens' p (Seq (WidgetNode s e))
L.children ((Seq (WidgetNode s e) -> Identity (Seq (WidgetNode s e)))
 -> p -> Identity p)
-> Seq (WidgetNode s e) -> p -> p
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 {p} {a} {p}.
(HasInfo p a, HasStyle a Style,
 HasChildren p (Seq (WidgetNode s e))) =>
p -> p -> p
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 {p} {a} {p}.
(HasInfo p a, HasStyle a Style,
 HasChildren p (Seq (WidgetNode s e))) =>
p -> p -> p
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
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 :: Button -> Bool
mainBtn Button
btn = Button
btn Button -> Button -> Bool
forall a. Eq a => a -> a -> Bool
== WidgetEnv s e
wenv WidgetEnv s e -> Getting Button (WidgetEnv s e) Button -> Button
forall s a. s -> Getting a s a -> a
^. Getting Button (WidgetEnv s e) Button
forall s a. HasMainButton s a => Lens' s a
Lens' (WidgetEnv s e) Button
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
      ignoreParent :: Bool
ignoreParent = ButtonCfg s e -> Maybe Bool
forall s e. ButtonCfg s e -> Maybe Bool
_btnIgnoreParent 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

      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 [WidgetRequest s e] -> [WidgetRequest s e] -> [WidgetRequest s e]
forall a. [a] -> [a] -> [a]
++ [WidgetRequest s e
forall s e. WidgetRequest s e
IgnoreParentEvents | Bool
ignoreParent]
      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
Lens' (WidgetNode s e) WidgetNodeInfo
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
Lens' WidgetNodeInfo WidgetId
L.widgetId)]

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