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

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

Requires a value to identify the content (used when the item is dropped) and the
content to display.

@
dragItem = draggable "item" $ label "This label is draggable"
@

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

module Monomer.Widgets.Containers.Draggable (
  -- * Configuration
  DraggableRender,
  DraggableCfg,
  draggableMaxDim,
  draggableStyle,
  draggableRender,
  -- * Constructors
  draggable,
  draggable_
) where

import Control.Applicative ((<|>))
import Control.Lens ((&), (^.), (^?!), (.~), _Just, _1, _2, at, ix)
import Control.Monad (when)
import Data.Default
import Data.Maybe

import qualified Data.Sequence as Seq

import Monomer.Widgets.Container

import qualified Monomer.Lens as L

-- | Rendering function for the dragged state.
type DraggableRender s e
  = DraggableCfg s e  -- ^ The configuration of the draggable.
  -> WidgetEnv s e    -- ^ The widget environment.
  -> WidgetNode s e   -- ^ The widget node.
  -> Renderer         -- ^ The renderer.
  -> IO ()            -- ^ The drawing actions.

{-|
Configuration options for draggable:

- 'transparency': the alpha level to apply when rendering content in drag mode.
- 'draggableMaxDim': the maximum size of the largest axis when dragging. Keeps
  proportions.
- 'draggableStyle': the style to use when the item is being dragged.
- 'draggableRender': rendering function for the dragged state. Allows
  customizing this step without implementing a custom widget all the lifecycle
  steps.

The regular styling of this component apply only when the item is not being
dragged. To style the dragged container, use draggableStyle.

The transparency config only applies to the inner content.
-}
data DraggableCfg s e = DraggableCfg {
  forall s e. DraggableCfg s e -> Maybe Double
_dgcTransparency :: Maybe Double,
  forall s e. DraggableCfg s e -> Maybe Double
_dgcMaxDim :: Maybe Double,
  forall s e. DraggableCfg s e -> Maybe StyleState
_dgcDragStyle :: Maybe StyleState,
  forall s e. DraggableCfg s e -> Maybe (DraggableRender s e)
_dgcCustomRender :: Maybe (DraggableRender s e)
}

instance Default (DraggableCfg s e) where
  def :: DraggableCfg s e
def = DraggableCfg {
    _dgcTransparency :: Maybe Double
_dgcTransparency = forall a. Maybe a
Nothing,
    _dgcMaxDim :: Maybe Double
_dgcMaxDim = forall a. Maybe a
Nothing,
    _dgcDragStyle :: Maybe StyleState
_dgcDragStyle = forall a. Maybe a
Nothing,
    _dgcCustomRender :: Maybe (DraggableRender s e)
_dgcCustomRender = forall a. Maybe a
Nothing
  }

instance Semigroup (DraggableCfg s e) where
  <> :: DraggableCfg s e -> DraggableCfg s e -> DraggableCfg s e
(<>) DraggableCfg s e
t1 DraggableCfg s e
t2 = DraggableCfg {
    _dgcTransparency :: Maybe Double
_dgcTransparency = forall s e. DraggableCfg s e -> Maybe Double
_dgcTransparency DraggableCfg s e
t2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall s e. DraggableCfg s e -> Maybe Double
_dgcTransparency DraggableCfg s e
t1,
    _dgcMaxDim :: Maybe Double
_dgcMaxDim = forall s e. DraggableCfg s e -> Maybe Double
_dgcMaxDim DraggableCfg s e
t2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall s e. DraggableCfg s e -> Maybe Double
_dgcMaxDim DraggableCfg s e
t1,
    _dgcDragStyle :: Maybe StyleState
_dgcDragStyle = forall s e. DraggableCfg s e -> Maybe StyleState
_dgcDragStyle DraggableCfg s e
t2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall s e. DraggableCfg s e -> Maybe StyleState
_dgcDragStyle DraggableCfg s e
t1,
    _dgcCustomRender :: Maybe (DraggableRender s e)
_dgcCustomRender = forall s e. DraggableCfg s e -> Maybe (DraggableRender s e)
_dgcCustomRender DraggableCfg s e
t2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall s e. DraggableCfg s e -> Maybe (DraggableRender s e)
_dgcCustomRender DraggableCfg s e
t1
  }

instance Monoid (DraggableCfg s e) where
  mempty :: DraggableCfg s e
mempty = forall a. Default a => a
def

instance CmbTransparency (DraggableCfg s e) where
  transparency :: Double -> DraggableCfg s e
transparency Double
transp = forall a. Default a => a
def {
    _dgcTransparency :: Maybe Double
_dgcTransparency = forall a. a -> Maybe a
Just Double
transp
  }

{-|
Maximum dimension. Useful when aspect ratio needs to be maintained while at the
same time restricting growth.
-}
draggableMaxDim :: Double -> DraggableCfg s e
draggableMaxDim :: forall s e. Double -> DraggableCfg s e
draggableMaxDim Double
dim = forall a. Default a => a
def {
  _dgcMaxDim :: Maybe Double
_dgcMaxDim = forall a. a -> Maybe a
Just Double
dim
}

-- | The style of the dragged container.
draggableStyle :: [StyleState] -> DraggableCfg s e
draggableStyle :: forall s e. [StyleState] -> DraggableCfg s e
draggableStyle [StyleState]
styles = forall a. Default a => a
def {
  _dgcDragStyle :: Maybe StyleState
_dgcDragStyle = forall a. a -> Maybe a
Just (forall a. Monoid a => [a] -> a
mconcat [StyleState]
styles)
}

-- | Rendering function for the dragged state.
draggableRender :: DraggableRender s e -> DraggableCfg s e
draggableRender :: forall s e. DraggableRender s e -> DraggableCfg s e
draggableRender DraggableRender s e
render = forall a. Default a => a
def {
  _dgcCustomRender :: Maybe (DraggableRender s e)
_dgcCustomRender = forall a. a -> Maybe a
Just DraggableRender s e
render
}

-- | Creates a draggable container with a single node as child.
draggable
  :: DragMsg a
  => a               -- ^ The identifying value.
  -> WidgetNode s e  -- ^ The child node.
  -> WidgetNode s e  -- ^ The created draggable container.
draggable :: forall a s e. DragMsg a => a -> WidgetNode s e -> WidgetNode s e
draggable a
msg WidgetNode s e
managed = forall a s e.
DragMsg a =>
a -> [DraggableCfg s e] -> WidgetNode s e -> WidgetNode s e
draggable_ a
msg forall a. Default a => a
def WidgetNode s e
managed

-- | Creates a draggable container with a single node as child. Accepts config.
draggable_
  :: DragMsg a
  => a                   -- ^ The identifying value.
  -> [DraggableCfg s e]  -- ^ The config options.
  -> WidgetNode s e      -- ^ The child node.
  -> WidgetNode s e      -- ^ The created draggable container.
draggable_ :: forall a s e.
DragMsg a =>
a -> [DraggableCfg s e] -> WidgetNode s e -> WidgetNode s e
draggable_ a
msg [DraggableCfg s e]
configs WidgetNode s e
managed = forall s e. Widget s e -> WidgetNode s e -> WidgetNode s e
makeNode Widget s e
widget WidgetNode s e
managed where
  config :: DraggableCfg s e
config = forall a. Monoid a => [a] -> a
mconcat [DraggableCfg s e]
configs
  widget :: Widget s e
widget = forall a s e. DragMsg a => a -> DraggableCfg s e -> Widget s e
makeDraggable a
msg DraggableCfg s e
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
"draggable" 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

makeDraggable :: DragMsg a => a -> DraggableCfg s e -> Widget s e
makeDraggable :: forall a s e. DragMsg a => a -> DraggableCfg s e -> Widget s e
makeDraggable a
msg DraggableCfg s e
config = 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 {
    containerHandleEvent :: ContainerEventHandler s e
containerHandleEvent = forall {p} {s} {e} {p}.
p -> WidgetNode s e -> p -> SystemEvent -> Maybe (WidgetResult s e)
handleEvent,
    containerGetSizeReq :: ContainerGetSizeReqHandler s e
containerGetSizeReq = forall s e. ContainerGetSizeReqHandler s e
getSizeReq,
    containerResize :: ContainerResizeHandler s e
containerResize = forall s e. ContainerResizeHandler s e
resize,
    containerRender :: ContainerRenderHandler s e
containerRender = ContainerRenderHandler s e
render
  }

  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
    ButtonAction Point
p Button
btn ButtonState
BtnPressed Int
1 -> forall a. a -> Maybe a
Just WidgetResult s e
result where
      result :: WidgetResult s e
result = forall s e.
WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
resultReqs WidgetNode s e
node [forall s e. WidgetId -> Path -> WidgetDragMsg -> WidgetRequest s e
StartDrag WidgetId
wid Path
path WidgetDragMsg
dragMsg]

    ButtonAction Point
p Button
btn ButtonState
BtnReleased Int
_ -> forall a. a -> Maybe a
Just WidgetResult s e
result where
      result :: WidgetResult s e
result = forall s e.
WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
resultReqs WidgetNode s e
node [forall s e. WidgetId -> WidgetRequest s e
StopDrag WidgetId
wid]

    SystemEvent
_ -> forall a. Maybe a
Nothing
    where
      wid :: WidgetId
wid = 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
      path :: Path
path = 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. HasPath s a => Lens' s a
L.path
      dragMsg :: WidgetDragMsg
dragMsg = forall i. DragMsg i => i -> WidgetDragMsg
WidgetDragMsg a
msg

  getSizeReq :: ContainerGetSizeReqHandler s e
  getSizeReq :: forall s e. ContainerGetSizeReqHandler s e
getSizeReq WidgetEnv s e
wenv WidgetNode s e
node Seq (WidgetNode s e)
children = (SizeReq
newReqW, SizeReq
newReqH) where
    child :: WidgetNode s e
child = forall a. Seq a -> Int -> a
Seq.index Seq (WidgetNode s e)
children Int
0
    newReqW :: SizeReq
newReqW = WidgetNode s e
child 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. HasSizeReqW s a => Lens' s a
L.sizeReqW
    newReqH :: SizeReq
newReqH = WidgetNode s e
child 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. HasSizeReqH s a => Lens' s a
L.sizeReqH

  resize :: ContainerResizeHandler s e
  resize :: forall s e. ContainerResizeHandler s e
resize WidgetEnv s e
wenv WidgetNode s e
node Rect
viewport Seq (WidgetNode s e)
children = (WidgetResult s e, Seq Rect)
resized where
    style :: StyleState
style = forall s e. WidgetEnv s e -> WidgetNode s e -> StyleState
currentStyle WidgetEnv s e
wenv WidgetNode s e
node
    contentArea :: Rect
contentArea = forall a. a -> Maybe a -> a
fromMaybe forall a. Default a => a
def (StyleState -> Rect -> Maybe Rect
removeOuterBounds StyleState
style Rect
viewport)
    resized :: (WidgetResult s e, Seq Rect)
resized = (forall s e. WidgetNode s e -> WidgetResult s e
resultNode WidgetNode s e
node, forall a. a -> Seq a
Seq.singleton Rect
contentArea)

  defaultRender :: DraggableCfg s e
-> WidgetEnv s e -> WidgetNode s e -> Renderer -> IO ()
defaultRender DraggableCfg s e
config WidgetEnv s e
wenv WidgetNode s e
node Renderer
renderer =
    Renderer -> Rect -> StyleState -> (Rect -> IO ()) -> IO ()
drawStyledAction Renderer
renderer (Point -> Rect -> Rect
moveRect Point
scOffset Rect
draggedRect) StyleState
style forall a b. (a -> b) -> a -> b
$ \Rect
_ -> do
      Renderer -> IO ()
saveContext Renderer
renderer
      Renderer -> Point -> IO ()
setTranslation Renderer
renderer (Point -> Point -> Point
addPoint Point
scOffset Point
offset)
      Renderer -> Point -> IO ()
setScale Renderer
renderer (Double -> Double -> Point
Point Double
scale Double
scale)
      Renderer -> Double -> IO ()
setGlobalAlpha Renderer
renderer Double
transparency
      forall s e.
Widget s e -> WidgetEnv s e -> WidgetNode s e -> Renderer -> IO ()
widgetRender (WidgetNode s e
cnode forall s a. s -> Getting a s a -> a
^. forall s a. HasWidget s a => Lens' s a
L.widget) WidgetEnv s e
wenv WidgetNode s e
cnode Renderer
renderer
      Renderer -> IO ()
restoreContext Renderer
renderer
    where
      style :: StyleState
style = forall a. a -> Maybe a -> a
fromMaybe forall a. Default a => a
def (forall s e. DraggableCfg s e -> Maybe StyleState
_dgcDragStyle DraggableCfg s e
config)
      transparency :: Double
transparency = forall a. a -> Maybe a -> a
fromMaybe Double
1 (forall s e. DraggableCfg s e -> Maybe Double
_dgcTransparency DraggableCfg s e
config)
      cnode :: WidgetNode s e
cnode = forall a. Seq a -> Int -> a
Seq.index (forall s e. WidgetNode s e -> Seq (WidgetNode s e)
_wnChildren WidgetNode s e
node) Int
0

      Rect Double
cx Double
cy Double
cw Double
ch = WidgetNode s e
cnode 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. HasViewport s a => Lens' s a
L.viewport
      Point Double
mx Double
my = 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
      Point Double
px Double
py = WidgetEnv s e
wenv forall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?! forall s a. HasMainBtnPress s a => Lens' s a
L.mainBtnPress forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field2 s t a b => Lens s t a b
_2

      dim :: Double
dim = forall a. a -> Maybe a -> a
fromMaybe (forall a. Ord a => a -> a -> a
max Double
cw Double
ch) (forall s e. DraggableCfg s e -> Maybe Double
_dgcMaxDim DraggableCfg s e
config)
      scale :: Double
scale = Double
dim forall a. Fractional a => a -> a -> a
/ forall a. Ord a => a -> a -> a
max Double
cw Double
ch
      offset :: Point
offset = Double -> Double -> Point
Point (Double
mx forall a. Num a => a -> a -> a
- Double
px forall a. Num a => a -> a -> a
* Double
scale) (Double
my forall a. Num a => a -> a -> a
- Double
py forall a. Num a => a -> a -> a
* Double
scale)
      -- Background rectangle (using draggable style)
      (Double
dx, Double
dy) = (Double
cx forall a. Num a => a -> a -> a
- Double
px, Double
cy forall a. Num a => a -> a -> a
- Double
py)
      rect :: Rect
rect = Double -> Double -> Double -> Double -> Rect
Rect (Double
mx forall a. Num a => a -> a -> a
+ Double
dx forall a. Num a => a -> a -> a
* Double
scale) (Double
my forall a. Num a => a -> a -> a
+ Double
dy forall a. Num a => a -> a -> a
* Double
scale) (Double
cw forall a. Num a => a -> a -> a
* Double
scale) (Double
ch forall a. Num a => a -> a -> a
* Double
scale)
      draggedRect :: Rect
draggedRect = forall a. a -> Maybe a -> a
fromMaybe Rect
rect (StyleState -> Rect -> Maybe Rect
addOuterBounds StyleState
style Rect
rect)
      scOffset :: Point
scOffset = WidgetEnv s e
wenv forall s a. s -> Getting a s a -> a
^. forall s a. HasOffset s a => Lens' s a
L.offset

  render :: ContainerRenderHandler s e
render WidgetEnv s e
wenv WidgetNode s e
node Renderer
renderer = do
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
dragged forall a b. (a -> b) -> a -> b
$
      Renderer -> IO () -> IO ()
createOverlay Renderer
renderer forall a b. (a -> b) -> a -> b
$ do
        DraggableCfg s e -> ContainerRenderHandler s e
renderAction DraggableCfg s e
config WidgetEnv s e
wenv WidgetNode s e
node Renderer
renderer
    where
      dragged :: Bool
dragged = forall s e. WidgetEnv s e -> WidgetNode s e -> Bool
isNodeDragged WidgetEnv s e
wenv WidgetNode s e
node
      renderAction :: DraggableCfg s e -> ContainerRenderHandler s e
renderAction = forall a. a -> Maybe a -> a
fromMaybe forall {s} {e} {s} {e}.
DraggableCfg s e
-> WidgetEnv s e -> WidgetNode s e -> Renderer -> IO ()
defaultRender (forall s e. DraggableCfg s e -> Maybe (DraggableRender s e)
_dgcCustomRender DraggableCfg s e
config)