{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE StrictData #-}
module Monomer.Widgets.Containers.ZStack (
ZStackCfg,
onlyTopActive,
onlyTopActive_,
zstack,
zstack_
) where
import Control.Applicative ((<|>))
import Control.Lens ((&), (^.), (^?), (.~), (%~), at, ix)
import Control.Monad (void, when)
import Data.Default
import Data.Maybe
import Data.List (foldl')
import Data.Sequence (Seq(..), (|>))
import GHC.Generics
import qualified Data.Map.Strict as M
import qualified Data.Sequence as Seq
import Monomer.Widgets.Container
import qualified Monomer.Lens as L
newtype ZStackCfg = ZStackCfg {
ZStackCfg -> Maybe Bool
_zscOnlyTopActive :: Maybe Bool
}
instance Default ZStackCfg where
def :: ZStackCfg
def = Maybe Bool -> ZStackCfg
ZStackCfg Maybe Bool
forall a. Maybe a
Nothing
instance Semigroup ZStackCfg where
<> :: ZStackCfg -> ZStackCfg -> ZStackCfg
(<>) ZStackCfg
z1 ZStackCfg
z2 = ZStackCfg {
_zscOnlyTopActive :: Maybe Bool
_zscOnlyTopActive = ZStackCfg -> Maybe Bool
_zscOnlyTopActive ZStackCfg
z2 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
<|> ZStackCfg -> Maybe Bool
_zscOnlyTopActive ZStackCfg
z1
}
instance Monoid ZStackCfg where
mempty :: ZStackCfg
mempty = ZStackCfg
forall a. Default a => a
def
onlyTopActive :: ZStackCfg
onlyTopActive :: ZStackCfg
onlyTopActive = Bool -> ZStackCfg
onlyTopActive_ Bool
True
onlyTopActive_ :: Bool -> ZStackCfg
onlyTopActive_ :: Bool -> ZStackCfg
onlyTopActive_ Bool
active = ZStackCfg
forall a. Default a => a
def {
_zscOnlyTopActive = Just active
}
data ZStackState = ZStackState {
ZStackState -> Map PathStep WidgetId
_zssFocusMap :: M.Map PathStep WidgetId,
ZStackState -> PathStep
_zssTopIdx :: Int
} deriving (ZStackState -> ZStackState -> Bool
(ZStackState -> ZStackState -> Bool)
-> (ZStackState -> ZStackState -> Bool) -> Eq ZStackState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ZStackState -> ZStackState -> Bool
== :: ZStackState -> ZStackState -> Bool
$c/= :: ZStackState -> ZStackState -> Bool
/= :: ZStackState -> ZStackState -> Bool
Eq, PathStep -> ZStackState -> ShowS
[ZStackState] -> ShowS
ZStackState -> String
(PathStep -> ZStackState -> ShowS)
-> (ZStackState -> String)
-> ([ZStackState] -> ShowS)
-> Show ZStackState
forall a.
(PathStep -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: PathStep -> ZStackState -> ShowS
showsPrec :: PathStep -> ZStackState -> ShowS
$cshow :: ZStackState -> String
show :: ZStackState -> String
$cshowList :: [ZStackState] -> ShowS
showList :: [ZStackState] -> ShowS
Show, (forall x. ZStackState -> Rep ZStackState x)
-> (forall x. Rep ZStackState x -> ZStackState)
-> Generic ZStackState
forall x. Rep ZStackState x -> ZStackState
forall x. ZStackState -> Rep ZStackState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ZStackState -> Rep ZStackState x
from :: forall x. ZStackState -> Rep ZStackState x
$cto :: forall x. Rep ZStackState x -> ZStackState
to :: forall x. Rep ZStackState x -> ZStackState
Generic)
zstack
:: (Traversable t)
=> t (WidgetNode s e)
-> WidgetNode s e
zstack :: forall (t :: * -> *) s e.
Traversable t =>
t (WidgetNode s e) -> WidgetNode s e
zstack t (WidgetNode s e)
children = [ZStackCfg] -> t (WidgetNode s e) -> WidgetNode s e
forall (t :: * -> *) s e.
Traversable t =>
[ZStackCfg] -> t (WidgetNode s e) -> WidgetNode s e
zstack_ [ZStackCfg]
forall a. Default a => a
def t (WidgetNode s e)
children
zstack_
:: (Traversable t)
=> [ZStackCfg]
-> t (WidgetNode s e)
-> WidgetNode s e
zstack_ :: forall (t :: * -> *) s e.
Traversable t =>
[ZStackCfg] -> t (WidgetNode s e) -> WidgetNode s e
zstack_ [ZStackCfg]
configs t (WidgetNode s e)
children = WidgetNode s e
newNode where
config :: ZStackCfg
config = [ZStackCfg] -> ZStackCfg
forall a. Monoid a => [a] -> a
mconcat [ZStackCfg]
configs
state :: ZStackState
state = Map PathStep WidgetId -> PathStep -> ZStackState
ZStackState Map PathStep WidgetId
forall k a. Map k a
M.empty PathStep
0
newNode :: WidgetNode s e
newNode = WidgetType -> Widget s e -> WidgetNode s e
forall s e. WidgetType -> Widget s e -> WidgetNode s e
defaultWidgetNode WidgetType
"zstack" (ZStackCfg -> ZStackState -> Widget s e
forall s e. ZStackCfg -> ZStackState -> Widget s e
makeZStack ZStackCfg
config ZStackState
state)
WidgetNode s e
-> (WidgetNode s e -> WidgetNode s e) -> WidgetNode s e
forall a b. a -> (a -> b) -> b
& (Seq (WidgetNode s e) -> Identity (Seq (WidgetNode s e)))
-> WidgetNode s e -> Identity (WidgetNode s e)
forall s a. HasChildren s a => Lens' s a
Lens' (WidgetNode s e) (Seq (WidgetNode s e))
L.children ((Seq (WidgetNode s e) -> Identity (Seq (WidgetNode s e)))
-> WidgetNode s e -> Identity (WidgetNode s e))
-> Seq (WidgetNode s e) -> WidgetNode s e -> WidgetNode s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Seq (WidgetNode s e) -> Seq (WidgetNode s e)
forall a. Seq a -> Seq a
Seq.reverse ((Seq (WidgetNode s e) -> WidgetNode s e -> Seq (WidgetNode s e))
-> Seq (WidgetNode s e)
-> t (WidgetNode s e)
-> Seq (WidgetNode s e)
forall b a. (b -> a -> b) -> b -> t a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Seq (WidgetNode s e) -> WidgetNode s e -> Seq (WidgetNode s e)
forall a. Seq a -> a -> Seq a
(|>) Seq (WidgetNode s e)
forall a. Seq a
Empty t (WidgetNode s e)
children)
makeZStack :: ZStackCfg -> ZStackState -> Widget s e
makeZStack :: forall s e. ZStackCfg -> ZStackState -> Widget s e
makeZStack ZStackCfg
config ZStackState
state = Widget s e
forall {s} {e}. Widget s e
widget where
baseWidget :: Widget s e
baseWidget = ZStackState -> Container s e ZStackState -> Widget s e
forall a s e. WidgetModel a => a -> Container s e a -> Widget s e
createContainer ZStackState
state Container s e ZStackState
forall a. Default a => a
def {
containerUseChildrenSizes = True,
containerInit = init,
containerMergePost = mergePost,
containerFindNextFocus = findNextFocus,
containerGetSizeReq = getSizeReq,
containerResize = resize
}
widget :: Widget s e
widget = Widget s e
forall {s} {e}. Widget s e
baseWidget {
widgetFindByPoint = findByPoint,
widgetRender = render
}
onlyTopActive :: Bool
onlyTopActive = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
True (ZStackCfg -> Maybe Bool
_zscOnlyTopActive ZStackCfg
config)
init :: p -> WidgetNode s e -> WidgetResult s e
init p
wenv WidgetNode s e
node = WidgetNode s e -> WidgetResult s e
forall s e. WidgetNode s e -> WidgetResult s e
resultNode WidgetNode s e
newNode where
children :: Seq (WidgetNode s e)
children = 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
Lens' (WidgetNode s e) (Seq (WidgetNode s e))
L.children
focusedPath :: a
focusedPath = p
wenv p -> Getting a p a -> a
forall s a. s -> Getting a s a -> a
^. Getting a p a
forall s a. HasFocusedPath s a => Lens' s a
Lens' p a
L.focusedPath
newState :: ZStackState
newState = ZStackState
state {
_zssTopIdx = fromMaybe 0 (Seq.findIndexL (^.L.info . L.visible) children)
}
newNode :: WidgetNode s e
newNode = WidgetNode s e
node
WidgetNode s e
-> (WidgetNode s e -> WidgetNode s e) -> WidgetNode s e
forall a b. a -> (a -> b) -> b
& (Widget s e -> Identity (Widget s e))
-> WidgetNode s e -> Identity (WidgetNode s e)
forall s a. HasWidget s a => Lens' s a
Lens' (WidgetNode s e) (Widget s e)
L.widget ((Widget s e -> Identity (Widget s e))
-> WidgetNode s e -> Identity (WidgetNode s e))
-> Widget s e -> WidgetNode s e -> WidgetNode s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ZStackCfg -> ZStackState -> Widget s e
forall s e. ZStackCfg -> ZStackState -> Widget s e
makeZStack ZStackCfg
config ZStackState
newState
mergePost :: WidgetEnv s e
-> WidgetNode s e -> WidgetNode s e -> ZStackState -> p -> p -> p
mergePost WidgetEnv s e
wenv WidgetNode s e
node WidgetNode s e
oldNode ZStackState
oldState p
newState p
result = p
newResult where
ZStackState Map PathStep WidgetId
oldFocusMap PathStep
oldTopIdx = ZStackState
oldState
children :: Seq (WidgetNode s e)
children = 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
Lens' (WidgetNode s e) (Seq (WidgetNode s e))
L.children
focusedPath :: Path
focusedPath = WidgetEnv s e
wenv WidgetEnv s e -> Getting Path (WidgetEnv s e) Path -> Path
forall s a. s -> Getting a s a -> a
^. Getting Path (WidgetEnv s e) Path
forall s a. HasFocusedPath s a => Lens' s a
Lens' (WidgetEnv s e) Path
L.focusedPath
focusedWid :: Maybe WidgetId
focusedWid = WidgetEnv s e -> Path -> Maybe WidgetId
forall s e. WidgetEnv s e -> Path -> Maybe WidgetId
widgetIdFromPath WidgetEnv s e
wenv Path
focusedPath
isFocusParent :: Bool
isFocusParent = WidgetNode s e -> Path -> Bool
forall s e. WidgetNode s e -> Path -> Bool
isNodeParentOfPath WidgetNode s e
node Path
focusedPath
topLevel :: Bool
topLevel = WidgetEnv s e -> WidgetNode s e -> Bool
forall s e. WidgetEnv s e -> WidgetNode s e -> Bool
isNodeTopLevel WidgetEnv s e
wenv WidgetNode s e
node
flagsChanged :: Bool
flagsChanged = WidgetNode s e -> WidgetNode s e -> Bool
forall s e. WidgetNode s e -> WidgetNode s e -> Bool
childrenFlagsChanged WidgetNode s e
oldNode WidgetNode s e
node
newTopIdx :: PathStep
newTopIdx = PathStep -> Maybe PathStep -> PathStep
forall a. a -> Maybe a -> a
fromMaybe PathStep
0 ((WidgetNode s e -> Bool) -> Seq (WidgetNode s e) -> Maybe PathStep
forall a. (a -> Bool) -> Seq a -> Maybe PathStep
Seq.findIndexL (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
Lens' (WidgetNode s e) WidgetNodeInfo
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. HasVisible s a => Lens' s a
Lens' WidgetNodeInfo Bool
L.visible) Seq (WidgetNode s e)
children)
focusReq :: Bool
focusReq = Maybe PathStep -> Bool
forall a. Maybe a -> Bool
isJust (Maybe PathStep -> Bool) -> Maybe PathStep -> Bool
forall a b. (a -> b) -> a -> b
$ (WidgetRequest s e -> Bool)
-> Seq (WidgetRequest s e) -> Maybe PathStep
forall a. (a -> Bool) -> Seq a -> Maybe PathStep
Seq.findIndexL WidgetRequest s e -> Bool
forall s e. WidgetRequest s e -> Bool
isFocusRequest (p
result p
-> Getting (Seq (WidgetRequest s e)) p (Seq (WidgetRequest s e))
-> Seq (WidgetRequest s e)
forall s a. s -> Getting a s a -> a
^. Getting (Seq (WidgetRequest s e)) p (Seq (WidgetRequest s e))
forall s a. HasRequests s a => Lens' s a
Lens' p (Seq (WidgetRequest s e))
L.requests)
needsFocus :: Bool
needsFocus = Bool
isFocusParent Bool -> Bool -> Bool
&& Bool
topLevel Bool -> Bool -> Bool
&& Bool
flagsChanged Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
focusReq
oldTopWid :: Maybe WidgetId
oldTopWid = PathStep -> Map PathStep WidgetId -> Maybe WidgetId
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PathStep
newTopIdx Map PathStep WidgetId
oldFocusMap
fstTopWid :: Maybe WidgetId
fstTopWid = WidgetNode s e
node WidgetNode s e
-> Getting (First WidgetId) (WidgetNode s e) WidgetId
-> Maybe WidgetId
forall s a. s -> Getting (First a) s a -> Maybe a
^? (Seq (WidgetNode s e)
-> Const (First WidgetId) (Seq (WidgetNode s e)))
-> WidgetNode s e -> Const (First WidgetId) (WidgetNode s e)
forall s a. HasChildren s a => Lens' s a
Lens' (WidgetNode s e) (Seq (WidgetNode s e))
L.children ((Seq (WidgetNode s e)
-> Const (First WidgetId) (Seq (WidgetNode s e)))
-> WidgetNode s e -> Const (First WidgetId) (WidgetNode s e))
-> ((WidgetId -> Const (First WidgetId) WidgetId)
-> Seq (WidgetNode s e)
-> Const (First WidgetId) (Seq (WidgetNode s e)))
-> Getting (First WidgetId) (WidgetNode s e) WidgetId
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 PathStep
Index (Seq (WidgetNode s e))
newTopIdx ((IxValue (Seq (WidgetNode s e))
-> Const (First WidgetId) (IxValue (Seq (WidgetNode s e))))
-> Seq (WidgetNode s e)
-> Const (First WidgetId) (Seq (WidgetNode s e)))
-> ((WidgetId -> Const (First WidgetId) WidgetId)
-> IxValue (Seq (WidgetNode s e))
-> Const (First WidgetId) (IxValue (Seq (WidgetNode s e))))
-> (WidgetId -> Const (First WidgetId) WidgetId)
-> Seq (WidgetNode s e)
-> Const (First WidgetId) (Seq (WidgetNode s e))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WidgetNodeInfo -> Const (First WidgetId) WidgetNodeInfo)
-> IxValue (Seq (WidgetNode s e))
-> Const (First WidgetId) (IxValue (Seq (WidgetNode s e)))
forall s a. HasInfo s a => Lens' s a
Lens' (IxValue (Seq (WidgetNode s e))) WidgetNodeInfo
L.info ((WidgetNodeInfo -> Const (First WidgetId) WidgetNodeInfo)
-> IxValue (Seq (WidgetNode s e))
-> Const (First WidgetId) (IxValue (Seq (WidgetNode s e))))
-> ((WidgetId -> Const (First WidgetId) WidgetId)
-> WidgetNodeInfo -> Const (First WidgetId) WidgetNodeInfo)
-> (WidgetId -> Const (First WidgetId) WidgetId)
-> IxValue (Seq (WidgetNode s e))
-> Const (First WidgetId) (IxValue (Seq (WidgetNode s e)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WidgetId -> Const (First WidgetId) WidgetId)
-> WidgetNodeInfo -> Const (First WidgetId) WidgetNodeInfo
forall s a. HasWidgetId s a => Lens' s a
Lens' WidgetNodeInfo WidgetId
L.widgetId
newState :: ZStackState
newState = ZStackState
oldState {
_zssFocusMap = oldFocusMap & at oldTopIdx .~ focusedWid,
_zssTopIdx = newTopIdx
}
tmpResult :: p
tmpResult = p
result
p -> (p -> p) -> p
forall a b. a -> (a -> b) -> b
& (a -> Identity a) -> p -> Identity p
forall s a. HasNode s a => Lens' s a
Lens' p a
L.node ((a -> Identity a) -> p -> Identity p)
-> ((Widget s e -> Identity (Widget s e)) -> a -> Identity a)
-> (Widget s e -> Identity (Widget s e))
-> p
-> Identity p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Widget s e -> Identity (Widget s e)) -> a -> Identity a
forall s a. HasWidget s a => Lens' s a
Lens' a (Widget s e)
L.widget ((Widget s e -> Identity (Widget s e)) -> p -> Identity p)
-> Widget s e -> p -> p
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ZStackCfg -> ZStackState -> Widget s e
forall s e. ZStackCfg -> ZStackState -> Widget s e
makeZStack ZStackCfg
config ZStackState
newState
newResult :: p
newResult
| Bool
needsFocus Bool -> Bool -> Bool
&& Maybe WidgetId -> Bool
forall a. Maybe a -> Bool
isJust Maybe WidgetId
oldTopWid = p
tmpResult
p -> (p -> p) -> p
forall a b. a -> (a -> b) -> b
& (Seq (WidgetRequest s e) -> Identity (Seq (WidgetRequest s e)))
-> p -> Identity p
forall s a. HasRequests s a => Lens' s a
Lens' p (Seq (WidgetRequest s e))
L.requests ((Seq (WidgetRequest s e) -> Identity (Seq (WidgetRequest s e)))
-> p -> Identity p)
-> (Seq (WidgetRequest s e) -> Seq (WidgetRequest s e)) -> p -> p
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Seq (WidgetRequest s e)
-> WidgetRequest s e -> Seq (WidgetRequest s e)
forall a. Seq a -> a -> Seq a
|> WidgetId -> WidgetRequest s e
forall s e. WidgetId -> WidgetRequest s e
SetFocus (Maybe WidgetId -> WidgetId
forall a. HasCallStack => Maybe a -> a
fromJust Maybe WidgetId
oldTopWid))
| Bool
needsFocus = p
tmpResult
p -> (p -> p) -> p
forall a b. a -> (a -> b) -> b
& (Seq (WidgetRequest s e) -> Identity (Seq (WidgetRequest s e)))
-> p -> Identity p
forall s a. HasRequests s a => Lens' s a
Lens' p (Seq (WidgetRequest s e))
L.requests ((Seq (WidgetRequest s e) -> Identity (Seq (WidgetRequest s e)))
-> p -> Identity p)
-> (Seq (WidgetRequest s e) -> Seq (WidgetRequest s e)) -> p -> p
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Seq (WidgetRequest s e)
-> WidgetRequest s e -> Seq (WidgetRequest s e)
forall a. Seq a -> a -> Seq a
|> Maybe WidgetId -> FocusDirection -> WidgetRequest s e
forall s e. Maybe WidgetId -> FocusDirection -> WidgetRequest s e
MoveFocus Maybe WidgetId
fstTopWid FocusDirection
FocusFwd)
| Bool
isFocusParent = p
tmpResult
| Bool
otherwise = p
result
findByPoint :: WidgetEnv s e
-> WidgetNode s e -> Path -> Point -> Maybe WidgetNodeInfo
findByPoint WidgetEnv s e
wenv WidgetNode s e
node Path
start Point
point = Maybe WidgetNodeInfo
result where
children :: Seq (WidgetNode s e)
children = 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
Lens' (WidgetNode s e) (Seq (WidgetNode s e))
L.children
vchildren :: Seq (WidgetNode s e)
vchildren
| Bool
onlyTopActive = PathStep -> Seq (WidgetNode s e) -> Seq (WidgetNode s e)
forall a. PathStep -> Seq a -> Seq a
Seq.take PathStep
1 (Seq (WidgetNode s e) -> Seq (WidgetNode s e))
-> Seq (WidgetNode s e) -> Seq (WidgetNode s e)
forall a b. (a -> b) -> a -> b
$ (WidgetNode s e -> Bool)
-> Seq (WidgetNode s e) -> Seq (WidgetNode s e)
forall a. (a -> Bool) -> Seq a -> Seq a
Seq.filter (WidgetNodeInfo -> Bool
_wniVisible (WidgetNodeInfo -> Bool)
-> (WidgetNode s e -> WidgetNodeInfo) -> WidgetNode s e -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WidgetNode s e -> WidgetNodeInfo
forall s e. WidgetNode s e -> WidgetNodeInfo
_wnInfo) Seq (WidgetNode s e)
children
| Bool
otherwise = (WidgetNode s e -> Bool)
-> Seq (WidgetNode s e) -> Seq (WidgetNode s e)
forall a. (a -> Bool) -> Seq a -> Seq a
Seq.filter (WidgetNodeInfo -> Bool
_wniVisible (WidgetNodeInfo -> Bool)
-> (WidgetNode s e -> WidgetNodeInfo) -> WidgetNode s e -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WidgetNode s e -> WidgetNodeInfo
forall s e. WidgetNode s e -> WidgetNodeInfo
_wnInfo) Seq (WidgetNode s e)
children
nextStep :: Maybe PathStep
nextStep = WidgetNode s e -> Path -> Maybe PathStep
forall s e. WidgetNode s e -> Path -> Maybe PathStep
nextTargetStep WidgetNode s e
node Path
start
ch :: WidgetNode s e
ch = Seq (WidgetNode s e) -> PathStep -> WidgetNode s e
forall a. Seq a -> PathStep -> a
Seq.index Seq (WidgetNode s e)
children (Maybe PathStep -> PathStep
forall a. HasCallStack => Maybe a -> a
fromJust Maybe PathStep
nextStep)
visible :: Bool
visible = 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
Lens' (WidgetNode s e) WidgetNodeInfo
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. HasVisible s a => Lens' s a
Lens' WidgetNodeInfo Bool
L.visible
childVisible :: Bool
childVisible = WidgetNode s e
ch 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
Lens' (WidgetNode s e) WidgetNodeInfo
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. HasVisible s a => Lens' s a
Lens' WidgetNodeInfo Bool
L.visible
isNextValid :: Bool
isNextValid = Maybe PathStep -> Bool
forall a. Maybe a -> Bool
isJust Maybe PathStep
nextStep Bool -> Bool -> Bool
&& Bool
visible Bool -> Bool -> Bool
&& Bool
childVisible
result :: Maybe WidgetNodeInfo
result
| Bool
isNextValid = Widget s e
-> WidgetEnv s e
-> WidgetNode s e
-> Path
-> Point
-> Maybe WidgetNodeInfo
forall s e.
Widget s e
-> WidgetEnv s e
-> WidgetNode s e
-> Path
-> Point
-> Maybe WidgetNodeInfo
widgetFindByPoint (WidgetNode s e
ch WidgetNode s e
-> Getting (Widget s e) (WidgetNode s e) (Widget s e) -> Widget s e
forall s a. s -> Getting a s a -> a
^. Getting (Widget s e) (WidgetNode s e) (Widget s e)
forall s a. HasWidget s a => Lens' s a
Lens' (WidgetNode s e) (Widget s e)
L.widget) WidgetEnv s e
wenv WidgetNode s e
ch Path
start Point
point
| Bool
visible = Seq (WidgetNode s e)
-> WidgetEnv s e -> Path -> Point -> Maybe WidgetNodeInfo
forall s e.
Seq (WidgetNode s e)
-> WidgetEnv s e -> Path -> Point -> Maybe WidgetNodeInfo
findFirstByPoint Seq (WidgetNode s e)
vchildren WidgetEnv s e
wenv Path
start Point
point
| Bool
otherwise = Maybe WidgetNodeInfo
forall a. Maybe a
Nothing
findNextFocus :: p -> p -> p -> p -> Seq (WidgetNode s e)
findNextFocus p
wenv p
node p
direction p
start = Seq (WidgetNode s e)
result where
children :: Seq (WidgetNode s e)
children = p
node p
-> Getting (Seq (WidgetNode s e)) p (Seq (WidgetNode s e))
-> Seq (WidgetNode s e)
forall s a. s -> Getting a s a -> a
^. Getting (Seq (WidgetNode s e)) p (Seq (WidgetNode s e))
forall s a. HasChildren s a => Lens' s a
Lens' p (Seq (WidgetNode s e))
L.children
vchildren :: Seq (WidgetNode s e)
vchildren = (WidgetNode s e -> Bool)
-> Seq (WidgetNode s e) -> Seq (WidgetNode s e)
forall a. (a -> Bool) -> Seq a -> Seq a
Seq.filter (WidgetNodeInfo -> Bool
_wniVisible (WidgetNodeInfo -> Bool)
-> (WidgetNode s e -> WidgetNodeInfo) -> WidgetNode s e -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WidgetNode s e -> WidgetNodeInfo
forall s e. WidgetNode s e -> WidgetNodeInfo
_wnInfo) Seq (WidgetNode s e)
children
result :: Seq (WidgetNode s e)
result
| Bool
onlyTopActive = PathStep -> Seq (WidgetNode s e) -> Seq (WidgetNode s e)
forall a. PathStep -> Seq a -> Seq a
Seq.take PathStep
1 Seq (WidgetNode s e)
vchildren
| Bool
otherwise = Seq (WidgetNode s e)
vchildren
getSizeReq :: p -> p -> Seq (WidgetNode s e) -> (SizeReq, SizeReq)
getSizeReq p
wenv p
node Seq (WidgetNode s e)
children = (SizeReq
newSizeReqW, SizeReq
newSizeReqH) where
vchildren :: Seq (WidgetNode s e)
vchildren = (WidgetNode s e -> Bool)
-> Seq (WidgetNode s e) -> Seq (WidgetNode s e)
forall a. (a -> Bool) -> Seq a -> Seq a
Seq.filter (WidgetNodeInfo -> Bool
_wniVisible (WidgetNodeInfo -> Bool)
-> (WidgetNode s e -> WidgetNodeInfo) -> WidgetNode s e -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WidgetNode s e -> WidgetNodeInfo
forall s e. WidgetNode s e -> WidgetNodeInfo
_wnInfo) Seq (WidgetNode s e)
children
newSizeReqW :: SizeReq
newSizeReqW = (WidgetNode s e -> SizeReq) -> Seq (WidgetNode s e) -> SizeReq
forall {a}. (a -> SizeReq) -> Seq a -> SizeReq
getDimSizeReq (WidgetNodeInfo -> SizeReq
_wniSizeReqW (WidgetNodeInfo -> SizeReq)
-> (WidgetNode s e -> WidgetNodeInfo) -> WidgetNode s e -> SizeReq
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WidgetNode s e -> WidgetNodeInfo
forall s e. WidgetNode s e -> WidgetNodeInfo
_wnInfo) Seq (WidgetNode s e)
vchildren
newSizeReqH :: SizeReq
newSizeReqH = (WidgetNode s e -> SizeReq) -> Seq (WidgetNode s e) -> SizeReq
forall {a}. (a -> SizeReq) -> Seq a -> SizeReq
getDimSizeReq (WidgetNodeInfo -> SizeReq
_wniSizeReqH (WidgetNodeInfo -> SizeReq)
-> (WidgetNode s e -> WidgetNodeInfo) -> WidgetNode s e -> SizeReq
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WidgetNode s e -> WidgetNodeInfo
forall s e. WidgetNode s e -> WidgetNodeInfo
_wnInfo) Seq (WidgetNode s e)
vchildren
getDimSizeReq :: (a -> SizeReq) -> Seq a -> SizeReq
getDimSizeReq a -> SizeReq
accessor Seq a
vchildren
| Seq SizeReq -> Bool
forall a. Seq a -> Bool
Seq.null Seq SizeReq
vreqs = Double -> SizeReq
fixedSize Double
0
| Bool
otherwise = (SizeReq -> SizeReq -> SizeReq) -> Seq SizeReq -> SizeReq
forall a. (a -> a -> a) -> Seq a -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 SizeReq -> SizeReq -> SizeReq
sizeReqMergeMax Seq SizeReq
vreqs
where
vreqs :: Seq SizeReq
vreqs = a -> SizeReq
accessor (a -> SizeReq) -> Seq a -> Seq SizeReq
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Seq a
vchildren
resize :: WidgetEnv s e
-> WidgetNode s e -> Rect -> f a -> (WidgetResult s e, f Rect)
resize WidgetEnv s e
wenv WidgetNode s e
node Rect
viewport f a
children = (WidgetResult s e, f Rect)
resized where
style :: StyleState
style = 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
vpChild :: Rect
vpChild = Rect -> Maybe Rect -> Rect
forall a. a -> Maybe a -> a
fromMaybe Rect
forall a. Default a => a
def (StyleState -> Rect -> Maybe Rect
removeOuterBounds StyleState
style Rect
viewport)
assignedAreas :: f Rect
assignedAreas = (a -> Rect) -> f a -> f Rect
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Rect -> a -> Rect
forall a b. a -> b -> a
const Rect
vpChild) f a
children
resized :: (WidgetResult s e, f Rect)
resized = (WidgetNode s e -> WidgetResult s e
forall s e. WidgetNode s e -> WidgetResult s e
resultNode WidgetNode s e
node, f Rect
assignedAreas)
render :: WidgetEnv s e -> WidgetNode s e -> Renderer -> IO ()
render WidgetEnv s e
wenv WidgetNode s e
node Renderer
renderer =
Renderer -> Bool -> Rect -> IO () -> IO ()
drawInScissor Renderer
renderer Bool
True Rect
viewport (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Renderer -> Rect -> StyleState -> (Rect -> IO ()) -> IO ()
drawStyledAction Renderer
renderer Rect
viewport StyleState
style ((Rect -> IO ()) -> IO ()) -> (Rect -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Rect
_ ->
IO (Seq ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Seq ()) -> IO ()) -> IO (Seq ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ (PathStep -> WidgetNode s e -> IO ())
-> Seq (WidgetNode s e) -> IO (Seq ())
forall (f :: * -> *) a b.
Applicative f =>
(PathStep -> a -> f b) -> Seq a -> f (Seq b)
Seq.traverseWithIndex PathStep -> WidgetNode s e -> IO ()
renderChild Seq (WidgetNode s e)
children
where
style :: StyleState
style = 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
children :: Seq (WidgetNode s e)
children = Seq (WidgetNode s e) -> Seq (WidgetNode s e)
forall a. Seq a -> Seq a
Seq.reverse (Seq (WidgetNode s e) -> Seq (WidgetNode s e))
-> Seq (WidgetNode s e) -> Seq (WidgetNode s e)
forall a b. (a -> b) -> a -> b
$ 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
Lens' (WidgetNode s e) (Seq (WidgetNode s e))
L.children
viewport :: Rect
viewport = WidgetNode s e
node 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
Lens' (WidgetNode s e) WidgetNodeInfo
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
Lens' WidgetNodeInfo Rect
L.viewport
isVisible :: s -> a
isVisible s
c = s
c s -> Getting a s a -> a
forall s a. s -> Getting a s a -> a
^. (a -> Const a a) -> s -> Const a s
forall s a. HasInfo s a => Lens' s a
Lens' s a
L.info ((a -> Const a a) -> s -> Const a s)
-> ((a -> Const a a) -> a -> Const a a) -> Getting a s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Const a a) -> a -> Const a a
forall s a. HasVisible s a => Lens' s a
Lens' a a
L.visible
topVisibleIdx :: PathStep
topVisibleIdx = PathStep -> Maybe PathStep -> PathStep
forall a. a -> Maybe a -> a
fromMaybe PathStep
0 ((WidgetNode s e -> Bool) -> Seq (WidgetNode s e) -> Maybe PathStep
forall a. (a -> Bool) -> Seq a -> Maybe PathStep
Seq.findIndexR (WidgetNodeInfo -> Bool
_wniVisible (WidgetNodeInfo -> Bool)
-> (WidgetNode s e -> WidgetNodeInfo) -> WidgetNode s e -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WidgetNode s e -> WidgetNodeInfo
forall s e. WidgetNode s e -> WidgetNodeInfo
_wnInfo) Seq (WidgetNode s e)
children)
isPointEmpty :: Point -> PathStep -> Bool
isPointEmpty Point
point PathStep
idx = Bool -> Bool
not Bool
covered where
prevs :: Seq (WidgetNode s e)
prevs = PathStep -> Seq (WidgetNode s e) -> Seq (WidgetNode s e)
forall a. PathStep -> Seq a -> Seq a
Seq.drop (PathStep
idx PathStep -> PathStep -> PathStep
forall a. Num a => a -> a -> a
+ PathStep
1) Seq (WidgetNode s e)
children
target :: WidgetNode s e -> Maybe WidgetNodeInfo
target WidgetNode s e
c = Widget s e
-> WidgetEnv s e
-> WidgetNode s e
-> Path
-> Point
-> Maybe WidgetNodeInfo
forall s e.
Widget s e
-> WidgetEnv s e
-> WidgetNode s e
-> Path
-> Point
-> Maybe WidgetNodeInfo
widgetFindByPoint (WidgetNode s e
c WidgetNode s e
-> Getting (Widget s e) (WidgetNode s e) (Widget s e) -> Widget s e
forall s a. s -> Getting a s a -> a
^. Getting (Widget s e) (WidgetNode s e) (Widget s e)
forall s a. HasWidget s a => Lens' s a
Lens' (WidgetNode s e) (Widget s e)
L.widget) WidgetEnv s e
wenv WidgetNode s e
c Path
emptyPath Point
point
isCovered :: WidgetNode s e -> Bool
isCovered WidgetNode s e
c = WidgetNode s e -> Bool
forall {s} {a} {a}. (HasInfo s a, HasVisible a a) => s -> a
isVisible WidgetNode s e
c Bool -> Bool -> Bool
&& Maybe WidgetNodeInfo -> Bool
forall a. Maybe a -> Bool
isJust (WidgetNode s e -> Maybe WidgetNodeInfo
target WidgetNode s e
c)
covered :: Bool
covered = (WidgetNode s e -> Bool) -> Seq (WidgetNode s e) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any WidgetNode s e -> Bool
isCovered Seq (WidgetNode s e)
prevs
isTopLayer :: PathStep -> p -> Point -> Bool
isTopLayer PathStep
idx p
child Point
point = Bool
prevTopLayer Bool -> Bool -> Bool
&& Bool
isValid where
prevTopLayer :: Bool
prevTopLayer = WidgetEnv s e -> Point -> Bool
forall s e. WidgetEnv s e -> Point -> Bool
_weInTopLayer WidgetEnv s e
wenv Point
point
isValid :: Bool
isValid
| Bool
onlyTopActive = PathStep
idx PathStep -> PathStep -> Bool
forall a. Eq a => a -> a -> Bool
== PathStep
topVisibleIdx
| Bool
otherwise = Point -> PathStep -> Bool
isPointEmpty Point
point PathStep
idx
cWenv :: PathStep -> p -> WidgetEnv s e
cWenv PathStep
idx p
child = WidgetEnv s e
wenv {
_weInTopLayer = isTopLayer idx child
}
renderChild :: PathStep -> WidgetNode s e -> IO ()
renderChild PathStep
idx WidgetNode s e
child = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (WidgetNode s e -> Bool
forall {s} {a} {a}. (HasInfo s a, HasVisible a a) => s -> a
isVisible WidgetNode s e
child) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Widget s e -> WidgetEnv s e -> WidgetNode s e -> Renderer -> IO ()
forall s e.
Widget s e -> WidgetEnv s e -> WidgetNode s e -> Renderer -> IO ()
widgetRender (WidgetNode s e
child WidgetNode s e
-> Getting (Widget s e) (WidgetNode s e) (Widget s e) -> Widget s e
forall s a. s -> Getting a s a -> a
^. Getting (Widget s e) (WidgetNode s e) (Widget s e)
forall s a. HasWidget s a => Lens' s a
Lens' (WidgetNode s e) (Widget s e)
L.widget) (PathStep -> WidgetNode s e -> WidgetEnv s e
forall {p}. PathStep -> p -> WidgetEnv s e
cWenv PathStep
idx WidgetNode s e
child) WidgetNode s e
child Renderer
renderer
findFirstByPoint
:: Seq (WidgetNode s e)
-> WidgetEnv s e
-> Seq PathStep
-> Point
-> Maybe WidgetNodeInfo
findFirstByPoint :: forall s e.
Seq (WidgetNode s e)
-> WidgetEnv s e -> Path -> Point -> Maybe WidgetNodeInfo
findFirstByPoint Seq (WidgetNode s e)
Empty WidgetEnv s e
_ Path
_ Point
_ = Maybe WidgetNodeInfo
forall a. Maybe a
Nothing
findFirstByPoint (WidgetNode s e
ch :<| Seq (WidgetNode s e)
chs) WidgetEnv s e
wenv Path
start Point
point = Maybe WidgetNodeInfo
result where
isVisible :: Bool
isVisible = WidgetNode s e
ch 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
Lens' (WidgetNode s e) WidgetNodeInfo
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. HasVisible s a => Lens' s a
Lens' WidgetNodeInfo Bool
L.visible
newPath :: Maybe WidgetNodeInfo
newPath = Widget s e
-> WidgetEnv s e
-> WidgetNode s e
-> Path
-> Point
-> Maybe WidgetNodeInfo
forall s e.
Widget s e
-> WidgetEnv s e
-> WidgetNode s e
-> Path
-> Point
-> Maybe WidgetNodeInfo
widgetFindByPoint (WidgetNode s e
ch WidgetNode s e
-> Getting (Widget s e) (WidgetNode s e) (Widget s e) -> Widget s e
forall s a. s -> Getting a s a -> a
^. Getting (Widget s e) (WidgetNode s e) (Widget s e)
forall s a. HasWidget s a => Lens' s a
Lens' (WidgetNode s e) (Widget s e)
L.widget) WidgetEnv s e
wenv WidgetNode s e
ch Path
start Point
point
result :: Maybe WidgetNodeInfo
result
| Bool
isVisible Bool -> Bool -> Bool
&& Maybe WidgetNodeInfo -> Bool
forall a. Maybe a -> Bool
isJust Maybe WidgetNodeInfo
newPath = Maybe WidgetNodeInfo
newPath
| Bool
otherwise = Seq (WidgetNode s e)
-> WidgetEnv s e -> Path -> Point -> Maybe WidgetNodeInfo
forall s e.
Seq (WidgetNode s e)
-> WidgetEnv s e -> Path -> Point -> Maybe WidgetNodeInfo
findFirstByPoint Seq (WidgetNode s e)
chs WidgetEnv s e
wenv Path
start Point
point