{-|
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 :: forall e s.
WidgetEvent e =>
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 = 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 = 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 :: 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 = 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 () forall a. Default a => a
def {
    containerInit :: ContainerInitHandler s e
containerInit = forall {p}. p -> WidgetNode s e -> WidgetResult s e
init,
    containerMerge :: ContainerMergeHandler s e ()
containerMerge = forall {p} {p} {p}.
p -> WidgetNode s e -> p -> p -> WidgetResult s e
merge,
    containerFilterEvent :: ContainerFilterHandler s e
containerFilterEvent = forall s e. ContainerFilterHandler s e
filterEvent
  }

  createChildNode :: p -> p -> p
createChildNode p
wenv p
node = p
newNode where
    nodeStyle :: Style
nodeStyle = p
node forall s a. s -> Getting a s a -> a
^. forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasStyle s a => Lens' s a
L.style
    labelStyle :: Style
labelStyle = forall a. Default a => a
def
      forall a b. a -> (a -> b) -> b
& forall t. Lens' StyleState (Maybe t) -> Style -> Style -> Style
collectStyleField_ forall s a. HasText s a => Lens' s a
L.text Style
nodeStyle
      forall a b. a -> (a -> b) -> b
& forall t. Lens' StyleState (Maybe t) -> Style -> Style -> Style
collectStyleField_ forall s a. HasCursorIcon s a => Lens' s a
L.cursorIcon Style
nodeStyle
    itemStyle :: Style
itemStyle = forall a. Default a => a
def
      forall a b. a -> (a -> b) -> b
& forall t. Lens' StyleState (Maybe t) -> Style -> Style -> Style
collectStyleField_ forall s a. HasFgColor s a => Lens' s a
L.fgColor Style
nodeStyle
      forall a b. a -> (a -> b) -> b
& forall t. Lens' StyleState (Maybe t) -> Style -> Style -> Style
collectStyleField_ forall s a. HasHlColor s a => Lens' s a
L.hlColor Style
nodeStyle
      forall a b. a -> (a -> b) -> b
& forall t. Lens' StyleState (Maybe t) -> Style -> Style -> Style
collectStyleField_ forall s a. HasSndColor s a => Lens' s a
L.sndColor Style
nodeStyle
      forall a b. a -> (a -> b) -> b
& forall t. Lens' StyleState (Maybe t) -> Style -> Style -> Style
collectStyleField_ forall s a. HasCursorIcon s a => Lens' s a
L.cursorIcon Style
nodeStyle

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

    childNode :: WidgetNode s e
childNode
      | RectSide
textSide forall a. Eq a => a -> a -> Bool
== RectSide
SideLeft = 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 forall a. Eq a => a -> a -> Bool
== RectSide
SideRight = 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 forall a. Eq a => a -> a -> Bool
== RectSide
SideTop = 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 = 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 =
      [forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall t. CmbChildSpacing t => t
Cmb.childSpacing forall t. CmbChildSpacing t => Double -> t
Cmb.childSpacing_ Maybe Double
childSpacing]
    newNode :: p
newNode = p
node
      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
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 = forall s e. WidgetNode s e -> WidgetResult s e
resultNode (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 = forall s e. WidgetNode s e -> WidgetResult s e
resultNode (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)

  filterEvent :: ContainerFilterHandler s e
  filterEvent :: forall s e. 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
      | forall s e. WidgetNode s e -> Point -> Bool
isPointInNodeVp WidgetNode s e
labelNode Point
p -> 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
      | forall s e. WidgetNode s e -> Point -> Bool
isPointInNodeVp WidgetNode s e
labelNode Point
p -> 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
_ -> forall a. a -> Maybe a
Just (Path
target, SystemEvent
evt)
    where
      labelIdx :: Int
labelIdx
        | RectSide
textSide 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 forall a. Num a => a -> a -> a
- Int
labelIdx
      newPath :: Path
newPath = forall a. Int -> Seq a -> Seq a
Seq.take (forall (t :: * -> *) a. Foldable t => t a -> Int
length Path
target forall a. Num a => a -> a -> a
- Int
1) Path
target forall a. Seq a -> a -> Seq a
|> Int
targetIdx
      labelNode :: IxValue (Seq (WidgetNode s e))
labelNode = WidgetNode s e
node forall s a. s -> Getting a s a -> a
^. forall s a. HasChildren s a => Lens' s a
L.children forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Index (Seq (WidgetNode s e))
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasChildren s a => Lens' s a
L.children forall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?! forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Int
labelIdx
      targetNode :: IxValue (Seq (WidgetNode s e))
targetNode = WidgetNode s e
node forall s a. s -> Getting a s a -> a
^. forall s a. HasChildren s a => Lens' s a
L.children forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Index (Seq (WidgetNode s e))
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasChildren s a => Lens' s a
L.children forall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?! forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Int
targetIdx
      targetCenter :: Point
targetCenter = Rect -> Point
rectCenter (WidgetNode s e
targetNode forall s a. s -> Getting a s a -> a
^. forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasViewport s a => Lens' s a
L.viewport)