    {-# LANGUAGE ScopedTypeVariables #-}
    -----------------------------------------------------------------------------
    -- |
    -- Module      :  XMonadContrib.UpdatePointer
    -- Description :  Causes the pointer to follow whichever window focus changes to.
    -- Copyright   :  (c) Robert Marlow <robreim@bobturf.org>, 2015 Evgeny Kurnevsky
    -- License     :  BSD3-style (see LICENSE)
    --
    -- Maintainer  :  Robert Marlow <robreim@bobturf.org>
    -- Stability   :  stable
    -- Portability :  portable
    --
    -- Causes the pointer to follow whichever window focus changes to. Compliments
    -- the idea of switching focus as the mouse crosses window boundaries to
    -- keep the mouse near the currently focused window
    --
    -----------------------------------------------------------------------------

    module XMonad.Actions.UpdatePointer
        (
         -- * Usage
         -- $usage
         updatePointer
        )
        where

    import XMonad
    import XMonad.Prelude
    import XMonad.StackSet (member, peek, screenDetail, current)

    import Control.Arrow ((&&&), (***))

    -- $usage
    -- You can use this module with the following in your @xmonad.hs@:
    --
    -- > import XMonad
    -- > import XMonad.Actions.UpdatePointer
    --
    -- Enable it by including it in your logHook definition, e.g.:
    --
    -- > logHook = updatePointer (0.5, 0.5) (1, 1)
    --
    -- which will move the pointer to the nearest point of a newly focused
    -- window. The first argument establishes a reference point within the
    -- newly-focused window, while the second argument linearly interpolates
    -- between said reference point and the edges of the newly-focused window to
    -- obtain a bounding box for the pointer.
    --
    -- > logHook = updatePointer (0.5, 0.5) (0, 0) -- exact centre of window
    -- > logHook = updatePointer (0.25, 0.25) (0.25, 0.25) -- near the top-left
    -- > logHook = updatePointer (0.5, 0.5) (1.1, 1.1) -- within 110% of the edge
    --
    -- To use this with an existing logHook, use >> :
    --
    -- > logHook = dynamicLog
    -- >           >> updatePointer (1, 1) (0, 0)
    --
    -- which moves the pointer to the bottom-right corner of the focused window.

    -- | Update the pointer's location to the currently focused
    -- window or empty screen unless it's already there, or unless the user was changing
    -- focus with the mouse
    --
    -- See also 'XMonad.Actions.UpdateFocus.focusUnderPointer' for an inverse
    -- operation that updates the focus instead. The two can be combined in a
    -- single config if neither goes into 'logHook' but are invoked explicitly in
    -- individual key bindings.
    updatePointer :: (Rational, Rational) -> (Rational, Rational) -> X ()
    updatePointer :: (Rational, Rational) -> (Rational, Rational) -> X ()
    updatePointer (Rational, Rational)
    refPos (Rational, Rational)
    ratio = do
      ws <- (XState -> WindowSet) -> X WindowSet
    forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
    gets XState -> WindowSet
    windowset
      dpy <- asks display
      let defaultRect = ScreenDetail -> Rectangle
    screenRect (ScreenDetail -> Rectangle) -> ScreenDetail -> Rectangle
    forall a b. (a -> b) -> a -> b
    $ Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
    -> ScreenDetail
    forall i l a sid sd. Screen i l a sid sd -> sd
    screenDetail (Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
     -> ScreenDetail)
    -> Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
    -> ScreenDetail
    forall a b. (a -> b) -> a -> b
    $ WindowSet
    -> Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
    forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
    current WindowSet
    ws
      rect <- case peek ws of
            Maybe Window
    Nothing -> Rectangle -> X Rectangle
    forall a. a -> X a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Rectangle
    defaultRect
            Just Window
    w  -> Rectangle
    -> (WindowAttributes -> Rectangle)
    -> Maybe WindowAttributes
    -> Rectangle
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe Rectangle
    defaultRect WindowAttributes -> Rectangle
    windowAttributesToRectangle
                   (Maybe WindowAttributes -> Rectangle)
    -> X (Maybe WindowAttributes) -> X Rectangle
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Window -> X (Maybe WindowAttributes)
    safeGetWindowAttributes Window
    w

      root <- asks theRoot
      mouseIsMoving <- asks mouseFocused
      (_sameRoot,_,currentWindow,rootX,rootY,_,_,_) <- io $ queryPointer dpy root
      drag <- gets dragging
      unless (pointWithin (fi rootX) (fi rootY) rect
              || mouseIsMoving
              || isJust drag
              || not (currentWindow `member` ws || currentWindow == none)) $ let
        -- focused rectangle
        (rectX, rectY) = (rect_x &&& rect_y) rect
        (rectW, rectH) = (fi . rect_width &&& fi . rect_height) rect
        -- reference position, with (0,0) and (1,1) being top-left and bottom-right
        refX = Rational -> Position -> Position -> Rational
    forall r a b. (RealFrac r, Real a, Real b) => r -> a -> b -> r
    lerp ((Rational, Rational) -> Rational
    forall a b. (a, b) -> a
    fst (Rational, Rational)
    refPos) Position
    rectX (Position
    rectX Position -> Position -> Position
    forall a. Num a => a -> a -> a
    + Position
    rectW)
        refY = Rational -> Position -> Position -> Rational
    forall r a b. (RealFrac r, Real a, Real b) => r -> a -> b -> r
    lerp ((Rational, Rational) -> Rational
    forall a b. (a, b) -> b
    snd (Rational, Rational)
    refPos) Position
    rectY (Position
    rectY Position -> Position -> Position
    forall a. Num a => a -> a -> a
    + Position
    rectH)
        -- final pointer bounds, lerped *outwards* from reference position
        boundsX = ((Position -> Rational)
     -> (Position -> Rational)
     -> (Position, Position)
     -> (Rational, Rational))
    -> (Position -> Rational)
    -> (Position, Position)
    -> (Rational, Rational)
    forall (m :: * -> *) a. Monad m => m (m a) -> m a
    join (Position -> Rational)
    -> (Position -> Rational)
    -> (Position, Position)
    -> (Rational, Rational)
    forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
    forall (a :: * -> * -> *) b c b' c'.
    Arrow a =>
    a b c -> a b' c' -> a (b, b') (c, c')
    (***) (Rational -> Rational -> Position -> Rational
    forall r a b. (RealFrac r, Real a, Real b) => r -> a -> b -> r
    lerp ((Rational, Rational) -> Rational
    forall a b. (a, b) -> a
    fst (Rational, Rational)
    ratio) Rational
    refX) (Position
    rectX, Position
    rectX Position -> Position -> Position
    forall a. Num a => a -> a -> a
    + Position
    rectW)
        boundsY = ((Position -> Rational)
     -> (Position -> Rational)
     -> (Position, Position)
     -> (Rational, Rational))
    -> (Position -> Rational)
    -> (Position, Position)
    -> (Rational, Rational)
    forall (m :: * -> *) a. Monad m => m (m a) -> m a
    join (Position -> Rational)
    -> (Position -> Rational)
    -> (Position, Position)
    -> (Rational, Rational)
    forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
    forall (a :: * -> * -> *) b c b' c'.
    Arrow a =>
    a b c -> a b' c' -> a (b, b') (c, c')
    (***) (Rational -> Rational -> Position -> Rational
    forall r a b. (RealFrac r, Real a, Real b) => r -> a -> b -> r
    lerp ((Rational, Rational) -> Rational
    forall a b. (a, b) -> b
    snd (Rational, Rational)
    ratio) Rational
    refY) (Position
    rectY, Position
    rectY Position -> Position -> Position
    forall a. Num a => a -> a -> a
    + Position
    rectH)
        -- ideally we ought to move the pointer in a straight line towards the
        -- reference point until it is within the above bounds, but…
        in io $ warpPointer dpy none root 0 0 0 0
            (round . clip boundsX $ fi rootX)
            (round . clip boundsY $ fi rootY)

    windowAttributesToRectangle :: WindowAttributes -> Rectangle
    windowAttributesToRectangle :: WindowAttributes -> Rectangle
    windowAttributesToRectangle WindowAttributes
    wa = Position -> Position -> Dimension -> Dimension -> Rectangle
    Rectangle (CInt -> Position
    forall a b. (Integral a, Num b) => a -> b
    fi (WindowAttributes -> CInt
    wa_x WindowAttributes
    wa))
                                               (CInt -> Position
    forall a b. (Integral a, Num b) => a -> b
    fi (WindowAttributes -> CInt
    wa_y WindowAttributes
    wa))
                                               (CInt -> Dimension
    forall a b. (Integral a, Num b) => a -> b
    fi (WindowAttributes -> CInt
    wa_width WindowAttributes
    wa CInt -> CInt -> CInt
    forall a. Num a => a -> a -> a
    + CInt
    2 CInt -> CInt -> CInt
    forall a. Num a => a -> a -> a
    * WindowAttributes -> CInt
    wa_border_width WindowAttributes
    wa))
                                               (CInt -> Dimension
    forall a b. (Integral a, Num b) => a -> b
    fi (WindowAttributes -> CInt
    wa_height WindowAttributes
    wa CInt -> CInt -> CInt
    forall a. Num a => a -> a -> a
    + CInt
    2 CInt -> CInt -> CInt
    forall a. Num a => a -> a -> a
    * WindowAttributes -> CInt
    wa_border_width WindowAttributes
    wa))

    lerp :: (RealFrac r, Real a, Real b) => r -> a -> b -> r
    lerp :: forall r a b. (RealFrac r, Real a, Real b) => r -> a -> b -> r
    lerp r
    r a
    a b
    b = (r
    1 r -> r -> r
    forall a. Num a => a -> a -> a
    - r
    r) r -> r -> r
    forall a. Num a => a -> a -> a
    * a -> r
    forall a b. (Real a, Fractional b) => a -> b
    realToFrac a
    a r -> r -> r
    forall a. Num a => a -> a -> a
    + r
    r r -> r -> r
    forall a. Num a => a -> a -> a
    * b -> r
    forall a b. (Real a, Fractional b) => a -> b
    realToFrac b
    b

    clip :: Ord a => (a, a) -> a -> a
    clip :: forall a. Ord a => (a, a) -> a -> a
    clip (a
    lower, a
    upper) a
    x
      | a
    x a -> a -> Bool
    forall a. Ord a => a -> a -> Bool
    < a
    lower = a
    lower
      | a
    x a -> a -> Bool
    forall a. Ord a => a -> a -> Bool
    > a
    upper = a
    upper
      | Bool
    otherwise = a
    x