{-# 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
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)