{-# 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 {
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
}
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
}
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)
}
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
}
draggable
:: DragMsg a
=> a
-> WidgetNode s e
-> WidgetNode s e
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
draggable_
:: DragMsg a
=> a
-> [DraggableCfg s e]
-> WidgetNode s e
-> WidgetNode s e
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)
(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)