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

Container for items with an associated clickable label. Mainly used with radio
and checkbox.

For usage examples, see:

- "Monomer.Widgets.Singles.LabeledCheckbox"
- "Monomer.Widgets.Singles.LabeledRadio"
-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}

module Monomer.Widgets.Containers.Base.LabeledItem (
  labeledItem
) where

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

import qualified Data.Sequence as Seq

import Monomer.Core
import Monomer.Core.Combinators as Cmb

import Monomer.Widgets.Container
import Monomer.Widgets.Containers.Stack
import Monomer.Widgets.Singles.Label
import Monomer.Widgets.Singles.Spacer

import qualified Monomer.Lens as L

{-|
Creates a stack with a label and the provided widget, passing to this widget all
the click events received. Positioning is configurable.
-}
labeledItem
  :: WidgetEvent e
  => WidgetType
  -> RectSide
  -> Maybe Double
  -> Text
  -> LabelCfg s e
  -> WidgetNode s e
  -> WidgetNode s e
labeledItem :: WidgetType
-> RectSide
-> Maybe Double
-> Text
-> LabelCfg s e
-> WidgetNode s e
-> WidgetNode s e
labeledItem WidgetType
wtype RectSide
textSide Maybe Double
childSpacing Text
caption LabelCfg s e
labelCfg WidgetNode s e
itemNode = WidgetNode s e
labeledNode where
  widget :: Widget s e
widget = RectSide
-> Maybe Double
-> Text
-> LabelCfg s e
-> WidgetNode s e
-> Widget s e
forall e s.
WidgetEvent e =>
RectSide
-> Maybe Double
-> Text
-> LabelCfg s e
-> WidgetNode s e
-> Widget s e
makeLabeledItem RectSide
textSide Maybe Double
childSpacing Text
caption LabelCfg s e
labelCfg WidgetNode s e
itemNode
  labeledNode :: WidgetNode s e
labeledNode = WidgetType -> Widget s e -> WidgetNode s e
forall s e. WidgetType -> Widget s e -> WidgetNode s e
defaultWidgetNode WidgetType
wtype Widget s e
widget

makeLabeledItem
  :: WidgetEvent e
  => RectSide
  -> Maybe Double
  -> Text
  -> LabelCfg s e
  -> WidgetNode s e
  -> Widget s e
makeLabeledItem :: RectSide
-> Maybe Double
-> Text
-> LabelCfg s e
-> WidgetNode s e
-> Widget s e
makeLabeledItem RectSide
textSide Maybe Double
childSpacing Text
caption LabelCfg s e
labelCfg WidgetNode s e
itemNode = 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 {
    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,
    containerFilterEvent :: ContainerFilterHandler s e
containerFilterEvent = ContainerFilterHandler s e
forall s e. ContainerFilterHandler s e
filterEvent
  }

  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
    labelStyle :: Style
labelStyle = Style
forall a. Default a => a
def
      Style -> (Style -> Style) -> Style
forall a b. a -> (a -> b) -> b
& Lens' StyleState (Maybe TextStyle) -> Style -> Style -> Style
forall t. Lens' StyleState (Maybe t) -> Style -> Style -> Style
collectStyleField_ forall s a. HasText s a => Lens' s a
Lens' StyleState (Maybe TextStyle)
L.text Style
nodeStyle
      Style -> (Style -> Style) -> Style
forall a b. a -> (a -> b) -> b
& Lens' StyleState (Maybe CursorIcon) -> Style -> Style -> Style
forall t. Lens' StyleState (Maybe t) -> Style -> Style -> Style
collectStyleField_ forall s a. HasCursorIcon s a => Lens' s a
Lens' StyleState (Maybe CursorIcon)
L.cursorIcon Style
nodeStyle
    itemStyle :: Style
itemStyle = Style
forall a. Default a => a
def
      Style -> (Style -> Style) -> Style
forall a b. a -> (a -> b) -> b
& Lens' StyleState (Maybe Color) -> Style -> Style -> Style
forall t. Lens' StyleState (Maybe t) -> Style -> Style -> Style
collectStyleField_ forall s a. HasFgColor s a => Lens' s a
Lens' StyleState (Maybe Color)
L.fgColor Style
nodeStyle
      Style -> (Style -> Style) -> Style
forall a b. a -> (a -> b) -> b
& Lens' StyleState (Maybe Color) -> Style -> Style -> Style
forall t. Lens' StyleState (Maybe t) -> Style -> Style -> Style
collectStyleField_ forall s a. HasHlColor s a => Lens' s a
Lens' StyleState (Maybe Color)
L.hlColor Style
nodeStyle
      Style -> (Style -> Style) -> Style
forall a b. a -> (a -> b) -> b
& Lens' StyleState (Maybe Color) -> Style -> Style -> Style
forall t. Lens' StyleState (Maybe t) -> Style -> Style -> Style
collectStyleField_ forall s a. HasSndColor s a => Lens' s a
Lens' StyleState (Maybe Color)
L.sndColor Style
nodeStyle
      Style -> (Style -> Style) -> Style
forall a b. a -> (a -> b) -> b
& Lens' StyleState (Maybe CursorIcon) -> Style -> Style -> Style
forall t. Lens' StyleState (Maybe t) -> Style -> Style -> Style
collectStyleField_ forall s a. HasCursorIcon s a => Lens' s a
Lens' StyleState (Maybe CursorIcon)
L.cursorIcon Style
nodeStyle

    baseLabel :: WidgetNode s e
baseLabel = Text -> [LabelCfg s e] -> WidgetNode s e
forall s e. Text -> [LabelCfg s e] -> WidgetNode s e
label_ Text
caption [LabelCfg s e
labelCfg] WidgetNode s e -> [StyleState] -> WidgetNode s e
forall t. CmbStyleBasic t => t -> [StyleState] -> t
`styleBasic` [StyleState
forall t. CmbCursorIcon t => t
cursorHand]
    labelNode :: WidgetNode s e
labelNode = WidgetNode s e
baseLabel
      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 a s t. Semigroup a => ASetter s t a a -> a -> s -> t
<>~ Style
labelStyle
    styledNode :: WidgetNode s e
styledNode = WidgetNode s e
itemNode
      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 a s t. Semigroup a => ASetter s t a a -> a -> s -> t
<>~ Style
itemStyle

    childNode :: WidgetNode s e
childNode
      | RectSide
textSide RectSide -> RectSide -> Bool
forall a. Eq a => a -> a -> Bool
== RectSide
SideLeft = [StackCfg] -> [WidgetNode s e] -> WidgetNode s e
forall (t :: * -> *) s e.
Traversable t =>
[StackCfg] -> t (WidgetNode s e) -> WidgetNode s e
hstack_ [StackCfg]
stackCfg [ WidgetNode s e
labelNode, WidgetNode s e
styledNode ]
      | RectSide
textSide RectSide -> RectSide -> Bool
forall a. Eq a => a -> a -> Bool
== RectSide
SideRight = [StackCfg] -> [WidgetNode s e] -> WidgetNode s e
forall (t :: * -> *) s e.
Traversable t =>
[StackCfg] -> t (WidgetNode s e) -> WidgetNode s e
hstack_ [StackCfg]
stackCfg [ WidgetNode s e
styledNode, WidgetNode s e
labelNode ]
      | RectSide
textSide RectSide -> RectSide -> Bool
forall a. Eq a => a -> a -> Bool
== RectSide
SideTop = [StackCfg] -> [WidgetNode s e] -> WidgetNode s e
forall (t :: * -> *) s e.
Traversable t =>
[StackCfg] -> t (WidgetNode s e) -> WidgetNode s e
vstack_ [StackCfg]
stackCfg [ WidgetNode s e
labelNode, WidgetNode s e
styledNode ]
      | Bool
otherwise = [StackCfg] -> [WidgetNode s e] -> WidgetNode s e
forall (t :: * -> *) s e.
Traversable t =>
[StackCfg] -> t (WidgetNode s e) -> WidgetNode s e
vstack_ [StackCfg]
stackCfg [ WidgetNode s e
styledNode, WidgetNode s e
labelNode ]
    stackCfg :: [StackCfg]
stackCfg =
      [StackCfg -> (Double -> StackCfg) -> Maybe Double -> StackCfg
forall b a. b -> (a -> b) -> Maybe a -> b
maybe StackCfg
forall t. CmbChildSpacing t => t
Cmb.childSpacing Double -> StackCfg
forall t. CmbChildSpacing t => Double -> t
Cmb.childSpacing_ Maybe Double
childSpacing]
    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
childNode

  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)

  filterEvent :: ContainerFilterHandler s e
  filterEvent :: ContainerFilterHandler s e
filterEvent WidgetEnv s e
wenv WidgetNode s e
node Path
target SystemEvent
evt = case SystemEvent
evt of
    Click Point
p Button
btn Int
clicks
      | WidgetNode s e -> Point -> Bool
forall s e. WidgetNode s e -> Point -> Bool
isPointInNodeVp WidgetNode s e
labelNode Point
p -> (Path, SystemEvent) -> Maybe (Path, SystemEvent)
forall a. a -> Maybe a
Just (Path
newPath, SystemEvent
newEvt) where
        newEvt :: SystemEvent
newEvt = Point -> Button -> Int -> SystemEvent
Click Point
targetCenter Button
btn Int
clicks

    ButtonAction Point
p Button
btn ButtonState
BtnPressed Int
clicks
      | WidgetNode s e -> Point -> Bool
forall s e. WidgetNode s e -> Point -> Bool
isPointInNodeVp WidgetNode s e
labelNode Point
p -> (Path, SystemEvent) -> Maybe (Path, SystemEvent)
forall a. a -> Maybe a
Just (Path
newPath, SystemEvent
newEvt) where
        newEvt :: SystemEvent
newEvt = Point -> Button -> ButtonState -> Int -> SystemEvent
ButtonAction Point
targetCenter Button
btn ButtonState
BtnPressed Int
clicks

    SystemEvent
_ -> (Path, SystemEvent) -> Maybe (Path, SystemEvent)
forall a. a -> Maybe a
Just (Path
target, SystemEvent
evt)
    where
      labelIdx :: Int
labelIdx
        | RectSide
textSide RectSide -> [RectSide] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [RectSide
SideLeft, RectSide
SideTop] = Int
0
        | Bool
otherwise = Int
1
      targetIdx :: Int
targetIdx = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
labelIdx
      newPath :: Path
newPath = Int -> Path -> Path
forall a. Int -> Seq a -> Seq a
Seq.take (Path -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Path
target Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Path
target Path -> Int -> Path
forall a. Seq a -> a -> Seq a
|> Int
targetIdx
      labelNode :: WidgetNode s e
labelNode = WidgetNode s e
node WidgetNode s e
-> Getting
     (Seq (WidgetNode s e)) (WidgetNode s e) (Seq (WidgetNode s e))
-> Seq (WidgetNode s e)
forall s a. s -> Getting a s a -> a
^. Getting
  (Seq (WidgetNode s e)) (WidgetNode s e) (Seq (WidgetNode s e))
forall s a. HasChildren s a => Lens' s a
L.children Getting
  (Seq (WidgetNode s e)) (WidgetNode s e) (Seq (WidgetNode s e))
-> ((Seq (WidgetNode s e)
     -> Const (Seq (WidgetNode s e)) (Seq (WidgetNode s e)))
    -> Seq (WidgetNode s e)
    -> Const (Seq (WidgetNode s e)) (Seq (WidgetNode s e)))
-> Getting
     (Seq (WidgetNode s e)) (WidgetNode s e) (Seq (WidgetNode s e))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Seq (WidgetNode s e))
-> Traversal'
     (Seq (WidgetNode s e)) (IxValue (Seq (WidgetNode s e)))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Index (Seq (WidgetNode s e))
0 ((WidgetNode s e -> Const (Seq (WidgetNode s e)) (WidgetNode s e))
 -> Seq (WidgetNode s e)
 -> Const (Seq (WidgetNode s e)) (Seq (WidgetNode s e)))
-> Getting
     (Seq (WidgetNode s e)) (WidgetNode s e) (Seq (WidgetNode s e))
-> (Seq (WidgetNode s e)
    -> Const (Seq (WidgetNode s e)) (Seq (WidgetNode s e)))
-> Seq (WidgetNode s e)
-> Const (Seq (WidgetNode s e)) (Seq (WidgetNode s e))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting
  (Seq (WidgetNode s e)) (WidgetNode s e) (Seq (WidgetNode s e))
forall s a. HasChildren s a => Lens' s a
L.children Seq (WidgetNode s e)
-> Getting
     (Endo (WidgetNode s e)) (Seq (WidgetNode s e)) (WidgetNode s e)
-> WidgetNode s e
forall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?! Index (Seq (WidgetNode s e))
-> Traversal'
     (Seq (WidgetNode s e)) (IxValue (Seq (WidgetNode s e)))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Int
Index (Seq (WidgetNode s e))
labelIdx
      targetNode :: WidgetNode s e
targetNode = WidgetNode s e
node WidgetNode s e
-> Getting
     (Seq (WidgetNode s e)) (WidgetNode s e) (Seq (WidgetNode s e))
-> Seq (WidgetNode s e)
forall s a. s -> Getting a s a -> a
^. Getting
  (Seq (WidgetNode s e)) (WidgetNode s e) (Seq (WidgetNode s e))
forall s a. HasChildren s a => Lens' s a
L.children Getting
  (Seq (WidgetNode s e)) (WidgetNode s e) (Seq (WidgetNode s e))
-> ((Seq (WidgetNode s e)
     -> Const (Seq (WidgetNode s e)) (Seq (WidgetNode s e)))
    -> Seq (WidgetNode s e)
    -> Const (Seq (WidgetNode s e)) (Seq (WidgetNode s e)))
-> Getting
     (Seq (WidgetNode s e)) (WidgetNode s e) (Seq (WidgetNode s e))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Seq (WidgetNode s e))
-> Traversal'
     (Seq (WidgetNode s e)) (IxValue (Seq (WidgetNode s e)))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Index (Seq (WidgetNode s e))
0 ((WidgetNode s e -> Const (Seq (WidgetNode s e)) (WidgetNode s e))
 -> Seq (WidgetNode s e)
 -> Const (Seq (WidgetNode s e)) (Seq (WidgetNode s e)))
-> Getting
     (Seq (WidgetNode s e)) (WidgetNode s e) (Seq (WidgetNode s e))
-> (Seq (WidgetNode s e)
    -> Const (Seq (WidgetNode s e)) (Seq (WidgetNode s e)))
-> Seq (WidgetNode s e)
-> Const (Seq (WidgetNode s e)) (Seq (WidgetNode s e))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting
  (Seq (WidgetNode s e)) (WidgetNode s e) (Seq (WidgetNode s e))
forall s a. HasChildren s a => Lens' s a
L.children Seq (WidgetNode s e)
-> Getting
     (Endo (WidgetNode s e)) (Seq (WidgetNode s e)) (WidgetNode s e)
-> WidgetNode s e
forall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?! Index (Seq (WidgetNode s e))
-> Traversal'
     (Seq (WidgetNode s e)) (IxValue (Seq (WidgetNode s e)))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Int
Index (Seq (WidgetNode s e))
targetIdx
      targetCenter :: Point
targetCenter = Rect -> Point
rectCenter (WidgetNode s e
targetNode WidgetNode s e -> Getting Rect (WidgetNode s e) Rect -> Rect
forall s a. s -> Getting a s a -> a
^. (WidgetNodeInfo -> Const Rect WidgetNodeInfo)
-> WidgetNode s e -> Const Rect (WidgetNode s e)
forall s a. HasInfo s a => Lens' s a
L.info ((WidgetNodeInfo -> Const Rect WidgetNodeInfo)
 -> WidgetNode s e -> Const Rect (WidgetNode s e))
-> ((Rect -> Const Rect Rect)
    -> WidgetNodeInfo -> Const Rect WidgetNodeInfo)
-> Getting Rect (WidgetNode s e) Rect
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Rect -> Const Rect Rect)
-> WidgetNodeInfo -> Const Rect WidgetNodeInfo
forall s a. HasViewport s a => Lens' s a
L.viewport)