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