{-|
Module      : Monomer.Widgets.Containers.DropTarget
Copyright   : (c) 2018 Francisco Vallarino
License     : BSD-3-Clause (see the LICENSE file)
Maintainer  : fjvallarino@gmail.com
Stability   : experimental
Portability : non-portable

Drop target container for a single element. Useful for adding drag support
without having to implement a custom widget. Usually works in tandem with
"Monomer.Widgets.Containers.Draggable".

Raises a user provided event when an item is dropped. The type must match with
the type of the dragged widget message, otherwise it will not be raised.

@
target = dropTarget ItemDropped $
  vstack itemsRows
    \`styleBasic\` [width 200, height 400]
@

See Tutorial 6 (Composite) for a usage example.
-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE Strict #-}

module Monomer.Widgets.Containers.DropTarget (
  -- * Configuration
  DropTargetCfg,
  dropTargetStyle,
  -- * Constructors
  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

{-|
Configuration options for dropTarget:

- 'dropTargetStyle': The style to apply to the container when a dragged item is
  on top.
-}
newtype DropTargetCfg = DropTargetCfg {
  DropTargetCfg -> Maybe StyleState
_dtcDropStyle :: Maybe StyleState
}

instance Default DropTargetCfg where
  def :: DropTargetCfg
def = DropTargetCfg :: Maybe StyleState -> DropTargetCfg
DropTargetCfg {
    _dtcDropStyle :: Maybe StyleState
_dtcDropStyle = Maybe StyleState
forall a. Maybe a
Nothing
  }

instance Semigroup DropTargetCfg where
  <> :: DropTargetCfg -> DropTargetCfg -> DropTargetCfg
(<>) DropTargetCfg
t1 DropTargetCfg
t2 = DropTargetCfg :: Maybe StyleState -> DropTargetCfg
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

-- | The style to apply to the container when a dragged item is on top.
dropTargetStyle :: [StyleState] -> DropTargetCfg
dropTargetStyle :: [StyleState] -> DropTargetCfg
dropTargetStyle [StyleState]
styles = DropTargetCfg
forall a. Default a => a
def {
  _dtcDropStyle :: Maybe StyleState
_dtcDropStyle = StyleState -> Maybe StyleState
forall a. a -> Maybe a
Just ([StyleState] -> StyleState
forall a. Monoid a => [a] -> a
mconcat [StyleState]
styles)
}

-- | Creates a drop target container with a single node as child.
dropTarget
  :: (DragMsg a, WidgetEvent e) => (a -> e) -> WidgetNode s e -> WidgetNode s e
dropTarget :: (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

-- | Creates a drop target container with a single node as child. Accepts
--   config.
dropTarget_
  :: (DragMsg a, WidgetEvent e)
  => (a -> e)
  -> [DropTargetCfg]
  -> WidgetNode s e
  -> WidgetNode s e
dropTarget_ :: (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 :: 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
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
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
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 :: (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 :: ContainerGetCurrentStyle s e
containerGetCurrentStyle = ContainerGetCurrentStyle s e
forall s e. WidgetEnv s e -> WidgetNode s e -> StyleState
getCurrentStyle,
    containerHandleEvent :: ContainerEventHandler s e
containerHandleEvent = ContainerEventHandler s e
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
    | 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
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
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
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
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
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 (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
_ -> []