{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE Strict #-}
module Monomer.Widgets.Containers.Draggable (
DraggableRender,
DraggableCfg,
draggableMaxDim,
draggableStyle,
draggableRender,
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
type DraggableRender s e
= DraggableCfg s e
-> WidgetEnv s e
-> WidgetNode s e
-> Renderer
-> IO ()
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
}
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
}
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)
}
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
}
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
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)
(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)