{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE Strict #-}
module Monomer.Widgets.Containers.DropTarget (
DropTargetCfg,
dropTargetStyle,
dropTarget,
dropTarget_
) where
import Control.Lens ((&), (^.), (.~))
import Data.Default
import Data.Maybe
import Data.Typeable (cast)
import qualified Data.Sequence as Seq
import Monomer.Widgets.Container
import qualified Monomer.Lens as L
newtype DropTargetCfg = DropTargetCfg {
DropTargetCfg -> Maybe StyleState
_dtcDropStyle :: Maybe StyleState
}
instance Default DropTargetCfg where
def :: DropTargetCfg
def = DropTargetCfg {
_dtcDropStyle :: Maybe StyleState
_dtcDropStyle = Maybe StyleState
forall a. Maybe a
Nothing
}
instance Semigroup DropTargetCfg where
<> :: DropTargetCfg -> DropTargetCfg -> DropTargetCfg
(<>) DropTargetCfg
t1 DropTargetCfg
t2 = DropTargetCfg {
_dtcDropStyle :: Maybe StyleState
_dtcDropStyle = DropTargetCfg -> Maybe StyleState
_dtcDropStyle DropTargetCfg
t1 Maybe StyleState -> Maybe StyleState -> Maybe StyleState
forall a. Semigroup a => a -> a -> a
<> DropTargetCfg -> Maybe StyleState
_dtcDropStyle DropTargetCfg
t2
}
instance Monoid DropTargetCfg where
mempty :: DropTargetCfg
mempty = DropTargetCfg
forall a. Default a => a
def
dropTargetStyle :: [StyleState] -> DropTargetCfg
dropTargetStyle :: [StyleState] -> DropTargetCfg
dropTargetStyle [StyleState]
styles = DropTargetCfg
forall a. Default a => a
def {
_dtcDropStyle = Just (mconcat styles)
}
dropTarget
:: (DragMsg a, WidgetEvent e)
=> (a -> e)
-> WidgetNode s e
-> WidgetNode s e
dropTarget :: forall a e s.
(DragMsg a, WidgetEvent e) =>
(a -> e) -> WidgetNode s e -> WidgetNode s e
dropTarget a -> e
dropEvt WidgetNode s e
managed = (a -> e) -> [DropTargetCfg] -> WidgetNode s e -> WidgetNode s e
forall a e s.
(DragMsg a, WidgetEvent e) =>
(a -> e) -> [DropTargetCfg] -> WidgetNode s e -> WidgetNode s e
dropTarget_ a -> e
dropEvt [DropTargetCfg]
forall a. Default a => a
def WidgetNode s e
managed
dropTarget_
:: (DragMsg a, WidgetEvent e)
=> (a -> e)
-> [DropTargetCfg]
-> WidgetNode s e
-> WidgetNode s e
dropTarget_ :: forall a e s.
(DragMsg a, WidgetEvent e) =>
(a -> e) -> [DropTargetCfg] -> WidgetNode s e -> WidgetNode s e
dropTarget_ a -> e
dropEvt [DropTargetCfg]
configs WidgetNode s e
managed = Widget s e -> WidgetNode s e -> WidgetNode s e
forall s e. Widget s e -> WidgetNode s e -> WidgetNode s e
makeNode Widget s e
forall {s}. Widget s e
widget WidgetNode s e
managed where
config :: DropTargetCfg
config = [DropTargetCfg] -> DropTargetCfg
forall a. Monoid a => [a] -> a
mconcat [DropTargetCfg]
configs
widget :: Widget s e
widget = (a -> e) -> DropTargetCfg -> Widget s e
forall a e s.
(DragMsg a, WidgetEvent e) =>
(a -> e) -> DropTargetCfg -> Widget s e
makeDropTarget a -> e
dropEvt DropTargetCfg
config
makeNode :: Widget s e -> WidgetNode s e -> WidgetNode s e
makeNode :: forall s e. Widget s e -> WidgetNode s e -> WidgetNode s e
makeNode Widget s e
widget WidgetNode s e
managedWidget = WidgetType -> Widget s e -> WidgetNode s e
forall s e. WidgetType -> Widget s e -> WidgetNode s e
defaultWidgetNode WidgetType
"dropTarget" 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
False
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
.~ WidgetNode s e -> Seq (WidgetNode s e)
forall a. a -> Seq a
Seq.singleton WidgetNode s e
managedWidget
makeDropTarget
:: (DragMsg a, WidgetEvent e) => (a -> e) -> DropTargetCfg -> Widget s e
makeDropTarget :: forall a e s.
(DragMsg a, WidgetEvent e) =>
(a -> e) -> DropTargetCfg -> Widget s e
makeDropTarget a -> e
dropEvt DropTargetCfg
config = Widget s e
forall {s}. 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 {
containerGetCurrentStyle = getCurrentStyle,
containerHandleEvent = handleEvent
}
getCurrentStyle :: WidgetEnv s e -> WidgetNode s e -> StyleState
getCurrentStyle WidgetEnv s e
wenv WidgetNode s e
node
| Maybe StyleState -> Bool
forall a. Maybe a -> Bool
isJust Maybe StyleState
style Bool -> Bool -> Bool
&& WidgetEnv s e -> WidgetNode s e -> Bool
forall {s} {s} {e}.
HasDragStatus s (Maybe (Path, WidgetDragMsg)) =>
s -> WidgetNode s e -> Bool
isDropTarget WidgetEnv s e
wenv WidgetNode s e
node Bool -> Bool -> Bool
&& Bool
isValid = Maybe StyleState -> StyleState
forall a. HasCallStack => Maybe a -> a
fromJust Maybe StyleState
style
| Bool
otherwise = 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
where
mousePos :: Point
mousePos = WidgetEnv s e
wenv WidgetEnv s e -> Getting Point (WidgetEnv s e) Point -> Point
forall s a. s -> Getting a s a -> a
^. (InputStatus -> Const Point InputStatus)
-> WidgetEnv s e -> Const Point (WidgetEnv s e)
forall s a. HasInputStatus s a => Lens' s a
Lens' (WidgetEnv s e) InputStatus
L.inputStatus ((InputStatus -> Const Point InputStatus)
-> WidgetEnv s e -> Const Point (WidgetEnv s e))
-> ((Point -> Const Point Point)
-> InputStatus -> Const Point InputStatus)
-> Getting Point (WidgetEnv s e) Point
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Point -> Const Point Point)
-> InputStatus -> Const Point InputStatus
forall s a. HasMousePos s a => Lens' s a
Lens' InputStatus Point
L.mousePos
isHovered :: Bool
isHovered = WidgetNode s e -> Point -> Bool
forall s e. WidgetNode s e -> Point -> Bool
isPointInNodeVp WidgetNode s e
node Point
mousePos
isTopLevel :: Bool
isTopLevel = 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
isValid :: Bool
isValid = Bool
isHovered Bool -> Bool -> Bool
&& Bool
isTopLevel
style :: Maybe StyleState
style = DropTargetCfg -> Maybe StyleState
_dtcDropStyle DropTargetCfg
config
handleEvent :: p -> WidgetNode s e -> p -> SystemEvent -> Maybe (WidgetResult s e)
handleEvent p
wenv WidgetNode s e
node p
target SystemEvent
evt = case SystemEvent
evt of
Drop Point
point Path
path WidgetDragMsg
dragMsg
| Bool -> Bool
not (WidgetNode s e -> Path -> Bool
forall s e. WidgetNode s e -> Path -> Bool
isNodeParentOfPath WidgetNode s e
node Path
path) -> WidgetResult s e -> Maybe (WidgetResult s e)
forall a. a -> Maybe a
Just WidgetResult s e
result where
widgetId :: WidgetId
widgetId = 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
evts :: [e]
evts = WidgetDragMsg -> [e]
msgToEvts WidgetDragMsg
dragMsg
result :: WidgetResult s e
result = WidgetNode s e -> [e] -> WidgetResult s e
forall e s. Typeable e => WidgetNode s e -> [e] -> WidgetResult s e
resultEvts WidgetNode s e
node [e]
evts
SystemEvent
_ -> Maybe (WidgetResult s e)
forall a. Maybe a
Nothing
isDropTarget :: s -> WidgetNode s e -> Bool
isDropTarget s
wenv WidgetNode s e
node = case s
wenv s
-> Getting
(Maybe (Path, WidgetDragMsg)) s (Maybe (Path, WidgetDragMsg))
-> Maybe (Path, WidgetDragMsg)
forall s a. s -> Getting a s a -> a
^. Getting
(Maybe (Path, WidgetDragMsg)) s (Maybe (Path, WidgetDragMsg))
forall s a. HasDragStatus s a => Lens' s a
Lens' s (Maybe (Path, WidgetDragMsg))
L.dragStatus of
Just (Path
path, WidgetDragMsg
msg) -> Bool -> Bool
not (WidgetNode s e -> Path -> Bool
forall s e. WidgetNode s e -> Path -> Bool
isNodeParentOfPath WidgetNode s e
node Path
path) Bool -> Bool -> Bool
&& WidgetDragMsg -> Bool
isValidMsg WidgetDragMsg
msg
Maybe (Path, WidgetDragMsg)
_ -> Bool
False
where
isValidMsg :: WidgetDragMsg -> Bool
isValidMsg = Bool -> Bool
not (Bool -> Bool) -> (WidgetDragMsg -> Bool) -> WidgetDragMsg -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [e] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([e] -> Bool) -> (WidgetDragMsg -> [e]) -> WidgetDragMsg -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WidgetDragMsg -> [e]
msgToEvts
msgToEvts :: WidgetDragMsg -> [e]
msgToEvts (WidgetDragMsg i
dragMsg) = case i -> Maybe a
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast i
dragMsg of
Just a
msg -> [a -> e
dropEvt a
msg]
Maybe a
_ -> []