module Montis.Standard.Drag
  ( DragConfig(..),
    startDragging,
    stopDragging,
    windowMove,
    windowResize,
    startWindowResize,
    startWindowMove,
  )
where

import Data.Data (Typeable)
import Montis.Core
import Montis.Core.Runtime
import Montis.Core.State
  ( Config (startingHooks),
    ConfigModule (..),
    Hooks (motionHook),
    StateExtension (..),
  )
import Montis.Standard.Mouse (CursorPosition (CursorPosition))
import Control.Monad.Cont (MonadIO(liftIO))

data DragConfig where
  DragConfig :: DragConfig
  deriving (Typeable)

instance ConfigModule Montis DragConfig where
  alterConfig _ c =
    let ohm = motionHook (startingHooks c)
        obtn = buttonHook (startingHooks c)
     in c
          { startingHooks =
              (startingHooks c)
                { motionHook = \ev -> onMotion ev >> ohm ev,
                  buttonHook = \ev -> onButton ev >> obtn ev
                }
          }

data DragAction where
  DragAction ::
    { onMotionAction :: MotionEvent -> Montis (),
      _onButtonReleaseAction :: ButtonEvent -> Montis ()
    } ->
    DragAction

newtype Dragging = Dragging (Maybe DragAction)
  deriving (Typeable)

instance StateExtension Dragging where
  initialValue = Dragging Nothing
  marshalExtension _ = Nothing
  demarshalExtension _ = Nothing

startWindowResize :: Montis ()
startWindowResize = do
  f <- windowResize
  startDragging f (const stopDragging)

startWindowMove :: Montis ()
startWindowMove = do
  f <- windowMove
  startDragging f (const stopDragging)

windowMove :: Montis (MotionEvent -> Montis ())
windowMove = do
  CursorPosition (x0, y0) <- xStateGet
  mtl <- toplevelAt x0 y0
  case mtl of
    Nothing -> return (const $ return ())
    Just tl -> do
      (tx, ty, _tw, _th) <- getToplevelGeometry tl
      let offsetX = x0 - tx
          offsetY = y0 - ty
      return $ \ev -> do
        let (x1, y1) = motionEvent_absolute ev
        setToplevelPosition tl (x1 - offsetX) (y1 - offsetY)

windowResize :: Montis (MotionEvent -> Montis ())
windowResize = do
  CursorPosition (startX, startY) <- xStateGet
  mtl <- toplevelAt startX startY
  case mtl of
    Nothing -> return (const $ return ())
    Just tl -> do
      (tx, ty, startW, startH) <- getToplevelGeometry tl
      let warpX = tx + startW
          warpY = ty + startH
      warpCursor warpX warpY
      xStatePut (CursorPosition (warpX, warpY))
      return $ \ev -> do
        let (x, y) = motionEvent_absolute ev
            newW = max 1 (startW + (x - warpX))
            newH = max 1 (startH + (y - warpY))
        setToplevelGeometry
          tl
          tx
          ty
          newW
          newH

startDragging :: (MotionEvent -> Montis ()) -> (ButtonEvent -> Montis ()) -> Montis ()
startDragging dragFn endFn =
  xStatePut $
    Dragging
      (Just (DragAction dragFn endFn))

stopDragging :: Montis ()
stopDragging = xStatePut (Dragging Nothing)

onButton :: ButtonEvent -> Montis ()
onButton bev = do
  case buttonEvent_state bev of
    ButtonReleased -> do
      liftIO $ putStrLn "!! Button Released."
      xStateGet
        >>= ( \case
                (Dragging (Just (DragAction _ stopFn))) -> stopFn bev
                _ -> return ()
            )
    ButtonPressed -> return ()

onMotion :: MotionEvent -> Montis ()
onMotion ev = do
  (Dragging act) <- xStateGet
  case act of
    Nothing -> return ()
    Just action -> onMotionAction action ev