{-|
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 {
    _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

-- | The style to apply to the container when a dragged item is on top.
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)
}

-- | 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 :: 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

-- | 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_ :: 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
_ -> []