Rename Internal to Rahm.Desktop

1 files changed, 97 insertions, 0 deletions

diff --git a/src/Rahm/Desktop/MouseMotion.hs b/src/Rahm/Desktop/MouseMotion.hs
new file mode 100644
index 0000000..488f06a
--- /dev/null
+++ b/src/Rahm/Desktop/MouseMotion.hs
@@ -0,0 +1,97 @@
+{-# LANGUAGE ViewPatterns, BangPatterns #-}
+module Rahm.Desktop.MouseMotion where
+
+import XMonad
+
+import Control.Monad (void, forever)
+import Text.Printf
+import Rahm.Desktop.Submap
+import Control.Monad.Loops (iterateWhile)
+import Control.Monad.Fix (fix)
+import Rahm.Desktop.Logger
+
+import Linear.V2
+import Linear.Metric
+
+data Quadrant = NE | SE | SW | NW deriving (Enum, Show)
+data Direction = CW | CCW deriving (Enum, Show)
+
+getQuadrant :: (Num a, Ord a) => (a, a) -> Quadrant
+getQuadrant (x, y) | x >= 0 && y >= 0 = NE
+getQuadrant (x, y) | x < 0 && y >= 0 = SE
+getQuadrant (x, y) | x < 0 && y < 0 = SW
+getQuadrant (x, y) = NW
+
+
+getDirection :: Quadrant -> Quadrant -> Maybe Direction
+getDirectory a b | a == b = Nothing
+getDirection SW SE = Just CCW
+getDirection SE NE = Just CCW
+getDirection NE NW = Just CCW
+getDirection NW SW = Just CCW
+getDirection _ _ = Just CW
+
+
+liftMouseMotionM :: X a -> MouseMotionM a
+liftMouseMotionM = MouseMotionM . fmap Just
+
+motion :: MouseMotionM (V2 Int)
+motion = MouseMotionM $ do
+  ev <- nextMotionOrButton
+  case ev of
+    Right button -> do
+      logs ("Button " ++ show button)
+      return Nothing
+
+    Left motion -> return (Just $ uncurry V2 motion)
+
+motionSize :: Int -> MouseMotionM (V2 Int)
+motionSize size = do
+  let fsize = fromIntegral size
+
+  !firstmotion <- fmap fromIntegral <$> motion
+
+  let get = do
+        !next <- motion
+        if distance (fmap fromIntegral next) firstmotion >= fsize
+          then return next
+          else get
+
+  get
+
+runMouseMotionM :: MouseMotionM a -> X (Maybe a)
+runMouseMotionM (MouseMotionM a) = a
+
+execMouseMotionM :: MouseMotionM () -> X ()
+execMouseMotionM = void . runMouseMotionM
+
+-- Monad for capturing mouse motion. Terminates and holds Nothing when a
+-- button is pressed.
+newtype MouseMotionM a = MouseMotionM (X (Maybe a))
+
+instance Functor MouseMotionM where
+  fmap fn (MouseMotionM xma) = MouseMotionM (fmap (fmap fn) xma)
+
+instance Applicative MouseMotionM where
+  mf <*> ma = do
+    !f <- mf
+    !a <- ma
+    return (f a)
+
+  pure = return
+
+instance Monad MouseMotionM where
+  return a = MouseMotionM (return (Just a))
+  (MouseMotionM !xa) >>= fn = MouseMotionM $ do
+    !ma <- xa
+    case ma of
+      Just !a ->
+        let (MouseMotionM !xb) = fn a in xb
+      Nothing -> return Nothing
+
+mouseRotateMotion :: X () -> X () -> X ()
+mouseRotateMotion clockWise counterClockwise = execMouseMotionM doMouse
+  where
+    doMouse = forever $ do
+      v <- motion
+      liftMouseMotionM $ logs $ "Motion: " ++ show v