{-|
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'.
-}
{-# 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 {
  DraggableCfg s e -> Maybe Double
_dgcTransparency :: Maybe Double,
  DraggableCfg s e -> Maybe Double
_dgcMaxDim :: Maybe Double,
  DraggableCfg s e -> Maybe StyleState
_dgcDragStyle :: Maybe StyleState,
  DraggableCfg s e -> Maybe (DraggableRender s e)
_dgcCustomRender :: Maybe (DraggableRender s e)
}

instance Default (DraggableCfg s e) where
  def :: DraggableCfg s e
def = DraggableCfg :: forall s e.
Maybe Double
-> Maybe Double
-> Maybe StyleState
-> Maybe (DraggableRender s e)
-> DraggableCfg s e
DraggableCfg {
    _dgcTransparency :: Maybe Double
_dgcTransparency = Maybe Double
forall a. Maybe a
Nothing,
    _dgcMaxDim :: Maybe Double
_dgcMaxDim = Maybe Double
forall a. Maybe a
Nothing,
    _dgcDragStyle :: Maybe StyleState
_dgcDragStyle = Maybe StyleState
forall a. Maybe a
Nothing,
    _dgcCustomRender :: Maybe (DraggableRender s e)
_dgcCustomRender = Maybe (DraggableRender s e)
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 :: forall s e.
Maybe Double
-> Maybe Double
-> Maybe StyleState
-> Maybe (DraggableRender s e)
-> DraggableCfg s e
DraggableCfg {
    _dgcTransparency :: Maybe Double
_dgcTransparency = DraggableCfg s e -> Maybe Double
forall s e. DraggableCfg s e -> Maybe Double
_dgcTransparency DraggableCfg s e
t2 Maybe Double -> Maybe Double -> Maybe Double
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> DraggableCfg s e -> Maybe Double
forall s e. DraggableCfg s e -> Maybe Double
_dgcTransparency DraggableCfg s e
t1,
    _dgcMaxDim :: Maybe Double
_dgcMaxDim = DraggableCfg s e -> Maybe Double
forall s e. DraggableCfg s e -> Maybe Double
_dgcMaxDim DraggableCfg s e
t2 Maybe Double -> Maybe Double -> Maybe Double
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> DraggableCfg s e -> Maybe Double
forall s e. DraggableCfg s e -> Maybe Double
_dgcMaxDim DraggableCfg s e
t1,
    _dgcDragStyle :: Maybe StyleState
_dgcDragStyle = DraggableCfg s e -> Maybe StyleState
forall s e. DraggableCfg s e -> Maybe StyleState
_dgcDragStyle DraggableCfg s e
t2 Maybe StyleState -> Maybe StyleState -> Maybe StyleState
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> DraggableCfg s e -> Maybe StyleState
forall s e. DraggableCfg s e -> Maybe StyleState
_dgcDragStyle DraggableCfg s e
t1,
    _dgcCustomRender :: Maybe (DraggableRender s e)
_dgcCustomRender = DraggableCfg s e -> Maybe (DraggableRender s e)
forall s e. DraggableCfg s e -> Maybe (DraggableRender s e)
_dgcCustomRender DraggableCfg s e
t2 Maybe (DraggableRender s e)
-> Maybe (DraggableRender s e) -> Maybe (DraggableRender s e)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> DraggableCfg s e -> Maybe (DraggableRender s e)
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 = DraggableCfg s e
forall a. Default a => a
def

instance CmbTransparency (DraggableCfg s e) where
  transparency :: Double -> DraggableCfg s e
transparency Double
transp = DraggableCfg s e
forall a. Default a => a
def {
    _dgcTransparency :: Maybe Double
_dgcTransparency = Double -> Maybe Double
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 :: Double -> DraggableCfg s e
draggableMaxDim Double
dim = DraggableCfg s e
forall a. Default a => a
def {
  _dgcMaxDim :: Maybe Double
_dgcMaxDim = Double -> Maybe Double
forall a. a -> Maybe a
Just Double
dim
}

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

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

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

makeDraggable :: DragMsg a => a -> DraggableCfg s e -> Widget s e
makeDraggable :: a -> DraggableCfg s e -> Widget s e
makeDraggable a
msg DraggableCfg s e
config = 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 {
    containerHandleEvent :: ContainerEventHandler s e
containerHandleEvent = ContainerEventHandler s e
forall p s e p.
p -> WidgetNode s e -> p -> SystemEvent -> Maybe (WidgetResult s e)
handleEvent,
    containerGetSizeReq :: ContainerGetSizeReqHandler s e
containerGetSizeReq = ContainerGetSizeReqHandler s e
forall s e. ContainerGetSizeReqHandler s e
getSizeReq,
    containerResize :: ContainerResizeHandler s e
containerResize = ContainerResizeHandler s e
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 -> WidgetResult s e -> Maybe (WidgetResult s e)
forall a. a -> Maybe a
Just WidgetResult s e
result where
      result :: WidgetResult s e
result = WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
forall s e.
WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
resultReqs WidgetNode s e
node [WidgetId -> Path -> WidgetDragMsg -> WidgetRequest s e
forall s e. WidgetId -> Path -> WidgetDragMsg -> WidgetRequest s e
StartDrag WidgetId
wid Path
path WidgetDragMsg
dragMsg]

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

    SystemEvent
_ -> Maybe (WidgetResult s e)
forall a. Maybe a
Nothing
    where
      wid :: WidgetId
wid = 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
      path :: Path
path = WidgetNode s e
node WidgetNode s e -> Getting Path (WidgetNode s e) Path -> Path
forall s a. s -> Getting a s a -> a
^. (WidgetNodeInfo -> Const Path WidgetNodeInfo)
-> WidgetNode s e -> Const Path (WidgetNode s e)
forall s a. HasInfo s a => Lens' s a
L.info ((WidgetNodeInfo -> Const Path WidgetNodeInfo)
 -> WidgetNode s e -> Const Path (WidgetNode s e))
-> ((Path -> Const Path Path)
    -> WidgetNodeInfo -> Const Path WidgetNodeInfo)
-> Getting Path (WidgetNode s e) Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Path -> Const Path Path)
-> WidgetNodeInfo -> Const Path WidgetNodeInfo
forall s a. HasPath s a => Lens' s a
L.path
      dragMsg :: WidgetDragMsg
dragMsg = a -> WidgetDragMsg
forall i. DragMsg i => i -> WidgetDragMsg
WidgetDragMsg a
msg

  getSizeReq :: ContainerGetSizeReqHandler s e
  getSizeReq :: 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 = Seq (WidgetNode s e) -> Int -> WidgetNode s e
forall a. Seq a -> Int -> a
Seq.index Seq (WidgetNode s e)
children Int
0
    newReqW :: SizeReq
newReqW = WidgetNode s e
child WidgetNode s e
-> Getting SizeReq (WidgetNode s e) SizeReq -> SizeReq
forall s a. s -> Getting a s a -> a
^. (WidgetNodeInfo -> Const SizeReq WidgetNodeInfo)
-> WidgetNode s e -> Const SizeReq (WidgetNode s e)
forall s a. HasInfo s a => Lens' s a
L.info ((WidgetNodeInfo -> Const SizeReq WidgetNodeInfo)
 -> WidgetNode s e -> Const SizeReq (WidgetNode s e))
-> ((SizeReq -> Const SizeReq SizeReq)
    -> WidgetNodeInfo -> Const SizeReq WidgetNodeInfo)
-> Getting SizeReq (WidgetNode s e) SizeReq
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SizeReq -> Const SizeReq SizeReq)
-> WidgetNodeInfo -> Const SizeReq WidgetNodeInfo
forall s a. HasSizeReqW s a => Lens' s a
L.sizeReqW
    newReqH :: SizeReq
newReqH = WidgetNode s e
child WidgetNode s e
-> Getting SizeReq (WidgetNode s e) SizeReq -> SizeReq
forall s a. s -> Getting a s a -> a
^. (WidgetNodeInfo -> Const SizeReq WidgetNodeInfo)
-> WidgetNode s e -> Const SizeReq (WidgetNode s e)
forall s a. HasInfo s a => Lens' s a
L.info ((WidgetNodeInfo -> Const SizeReq WidgetNodeInfo)
 -> WidgetNode s e -> Const SizeReq (WidgetNode s e))
-> ((SizeReq -> Const SizeReq SizeReq)
    -> WidgetNodeInfo -> Const SizeReq WidgetNodeInfo)
-> Getting SizeReq (WidgetNode s e) SizeReq
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SizeReq -> Const SizeReq SizeReq)
-> WidgetNodeInfo -> Const SizeReq WidgetNodeInfo
forall s a. HasSizeReqH s a => Lens' s a
L.sizeReqH

  resize :: ContainerResizeHandler s e
  resize :: 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 = 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
    contentArea :: Rect
contentArea = Rect -> Maybe Rect -> Rect
forall a. a -> Maybe a -> a
fromMaybe Rect
forall a. Default a => a
def (StyleState -> Rect -> Maybe Rect
removeOuterBounds StyleState
style Rect
viewport)
    resized :: (WidgetResult s e, Seq Rect)
resized = (WidgetNode s e -> WidgetResult s e
forall s e. WidgetNode s e -> WidgetResult s e
resultNode WidgetNode s e
node, Rect -> Seq Rect
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 ((Rect -> IO ()) -> IO ()) -> (Rect -> IO ()) -> IO ()
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
      Widget s e -> WidgetEnv s e -> WidgetNode s e -> Renderer -> IO ()
forall s e.
Widget s e -> WidgetEnv s e -> WidgetNode s e -> Renderer -> IO ()
widgetRender (WidgetNode s e
cnode WidgetNode s e
-> Getting (Widget s e) (WidgetNode s e) (Widget s e) -> Widget s e
forall s a. s -> Getting a s a -> a
^. Getting (Widget s e) (WidgetNode s e) (Widget s e)
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 = StyleState -> Maybe StyleState -> StyleState
forall a. a -> Maybe a -> a
fromMaybe StyleState
forall a. Default a => a
def (DraggableCfg s e -> Maybe StyleState
forall s e. DraggableCfg s e -> Maybe StyleState
_dgcDragStyle DraggableCfg s e
config)
      transparency :: Double
transparency = Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
1 (DraggableCfg s e -> Maybe Double
forall s e. DraggableCfg s e -> Maybe Double
_dgcTransparency DraggableCfg s e
config)
      cnode :: WidgetNode s e
cnode = Seq (WidgetNode s e) -> Int -> WidgetNode s e
forall a. Seq a -> Int -> a
Seq.index (WidgetNode s e -> Seq (WidgetNode s e)
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 WidgetNode s e -> Getting Rect (WidgetNode s e) Rect -> Rect
forall s a. s -> Getting a s a -> a
^. (WidgetNodeInfo -> Const Rect WidgetNodeInfo)
-> WidgetNode s e -> Const Rect (WidgetNode s e)
forall s a. HasInfo s a => Lens' s a
L.info ((WidgetNodeInfo -> Const Rect WidgetNodeInfo)
 -> WidgetNode s e -> Const Rect (WidgetNode s e))
-> ((Rect -> Const Rect Rect)
    -> WidgetNodeInfo -> Const Rect WidgetNodeInfo)
-> Getting Rect (WidgetNode s e) Rect
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Rect -> Const Rect Rect)
-> WidgetNodeInfo -> Const Rect WidgetNodeInfo
forall s a. HasViewport s a => Lens' s a
L.viewport
      Point Double
mx Double
my = 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
      Point Double
px Double
py = WidgetEnv s e
wenv WidgetEnv s e
-> Getting (Endo Point) (WidgetEnv s e) Point -> Point
forall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?! (Maybe (Path, Point) -> Const (Endo Point) (Maybe (Path, Point)))
-> WidgetEnv s e -> Const (Endo Point) (WidgetEnv s e)
forall s a. HasMainBtnPress s a => Lens' s a
L.mainBtnPress ((Maybe (Path, Point) -> Const (Endo Point) (Maybe (Path, Point)))
 -> WidgetEnv s e -> Const (Endo Point) (WidgetEnv s e))
-> ((Point -> Const (Endo Point) Point)
    -> Maybe (Path, Point) -> Const (Endo Point) (Maybe (Path, Point)))
-> Getting (Endo Point) (WidgetEnv s e) Point
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Path, Point) -> Const (Endo Point) (Path, Point))
-> Maybe (Path, Point) -> Const (Endo Point) (Maybe (Path, Point))
forall a b. Prism (Maybe a) (Maybe b) a b
_Just (((Path, Point) -> Const (Endo Point) (Path, Point))
 -> Maybe (Path, Point) -> Const (Endo Point) (Maybe (Path, Point)))
-> ((Point -> Const (Endo Point) Point)
    -> (Path, Point) -> Const (Endo Point) (Path, Point))
-> (Point -> Const (Endo Point) Point)
-> Maybe (Path, Point)
-> Const (Endo Point) (Maybe (Path, Point))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Point -> Const (Endo Point) Point)
-> (Path, Point) -> Const (Endo Point) (Path, Point)
forall s t a b. Field2 s t a b => Lens s t a b
_2

      dim :: Double
dim = Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe (Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
cw Double
ch) (DraggableCfg s e -> Maybe Double
forall s e. DraggableCfg s e -> Maybe Double
_dgcMaxDim DraggableCfg s e
config)
      scale :: Double
scale = Double
dim Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
cw Double
ch
      offset :: Point
offset = Double -> Double -> Point
Point (Double
mx Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
px Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
scale) (Double
my Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
py Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
scale)
      -- Background rectangle (using draggable style)
      (Double
dx, Double
dy) = (Double
cx Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
px, Double
cy Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
py)
      rect :: Rect
rect = Double -> Double -> Double -> Double -> Rect
Rect (Double
mx Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
dx Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
scale) (Double
my Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
dy Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
scale) (Double
cw Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
scale) (Double
ch Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
scale)
      draggedRect :: Rect
draggedRect = Rect -> Maybe Rect -> Rect
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 WidgetEnv s e -> Getting Point (WidgetEnv s e) Point -> Point
forall s a. s -> Getting a s a -> a
^. Getting Point (WidgetEnv s e) Point
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
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
dragged (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      Renderer -> IO () -> IO ()
createOverlay Renderer
renderer (IO () -> IO ()) -> IO () -> IO ()
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 = WidgetEnv s e -> WidgetNode s e -> Bool
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 = (DraggableCfg s e -> ContainerRenderHandler s e)
-> Maybe (DraggableCfg s e -> ContainerRenderHandler s e)
-> DraggableCfg s e
-> ContainerRenderHandler s e
forall a. a -> Maybe a -> a
fromMaybe DraggableCfg s e -> ContainerRenderHandler s e
forall s e s e.
DraggableCfg s e
-> WidgetEnv s e -> WidgetNode s e -> Renderer -> IO ()
defaultRender (DraggableCfg s e
-> Maybe (DraggableCfg s e -> ContainerRenderHandler s e)
forall s e. DraggableCfg s e -> Maybe (DraggableRender s e)
_dgcCustomRender DraggableCfg s e
config)