    {-# LANGUAGE DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses #-}
    -----------------------------------------------------------------------------
    -- |
    -- Module      :  XMonad.Hooks.ScreenCorners
    -- Copyright   :  (c) 2009 Nils Schweinsberg, 2015 Evgeny Kurnevsky
    -- License     :  BSD3-style (see LICENSE)
    --
    -- Maintainer  :  Nils Schweinsberg <mail@n-sch.de>
    -- Stability   :  unstable
    -- Portability :  unportable
    --
    -- Run @X ()@ actions by touching the edge of your screen with your mouse.
    --
    -----------------------------------------------------------------------------

    module XMonad.Hooks.ScreenCorners
        (
        -- * Usage
        -- $usage

        -- * Adding screen corners
          ScreenCorner (..)
        , addScreenCorner
        , addScreenCorners

        -- * Event hook
        , screenCornerEventHook

        -- * Layout hook
        , screenCornerLayoutHook
        ) where

    import Data.Monoid
    import Data.List (find)
    import XMonad
    import XMonad.Util.XUtils (fi)
    import XMonad.Layout.LayoutModifier

    import qualified Data.Map as M
    import qualified XMonad.Util.ExtensibleState as XS

    data ScreenCorner = SCUpperLeft
                      | SCUpperRight
                      | SCLowerLeft
                      | SCLowerRight
                      deriving (ScreenCorner -> ScreenCorner -> Bool
    (ScreenCorner -> ScreenCorner -> Bool)
    -> (ScreenCorner -> ScreenCorner -> Bool) -> Eq ScreenCorner
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    /= :: ScreenCorner -> ScreenCorner -> Bool
    $c/= :: ScreenCorner -> ScreenCorner -> Bool
    == :: ScreenCorner -> ScreenCorner -> Bool
    $c== :: ScreenCorner -> ScreenCorner -> Bool
    Eq, Eq ScreenCorner
    Eq ScreenCorner =>
    (ScreenCorner -> ScreenCorner -> Ordering)
    -> (ScreenCorner -> ScreenCorner -> Bool)
    -> (ScreenCorner -> ScreenCorner -> Bool)
    -> (ScreenCorner -> ScreenCorner -> Bool)
    -> (ScreenCorner -> ScreenCorner -> Bool)
    -> (ScreenCorner -> ScreenCorner -> ScreenCorner)
    -> (ScreenCorner -> ScreenCorner -> ScreenCorner)
    -> Ord ScreenCorner
    ScreenCorner -> ScreenCorner -> Bool
    ScreenCorner -> ScreenCorner -> Ordering
    ScreenCorner -> ScreenCorner -> ScreenCorner
    forall a.
    Eq a =>
    (a -> a -> Ordering)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> a)
    -> (a -> a -> a)
    -> Ord a
    min :: ScreenCorner -> ScreenCorner -> ScreenCorner
    $cmin :: ScreenCorner -> ScreenCorner -> ScreenCorner
    max :: ScreenCorner -> ScreenCorner -> ScreenCorner
    $cmax :: ScreenCorner -> ScreenCorner -> ScreenCorner
    >= :: ScreenCorner -> ScreenCorner -> Bool
    $c>= :: ScreenCorner -> ScreenCorner -> Bool
    > :: ScreenCorner -> ScreenCorner -> Bool
    $c> :: ScreenCorner -> ScreenCorner -> Bool
    <= :: ScreenCorner -> ScreenCorner -> Bool
    $c<= :: ScreenCorner -> ScreenCorner -> Bool
    < :: ScreenCorner -> ScreenCorner -> Bool
    $c< :: ScreenCorner -> ScreenCorner -> Bool
    compare :: ScreenCorner -> ScreenCorner -> Ordering
    $ccompare :: ScreenCorner -> ScreenCorner -> Ordering
    $cp1Ord :: Eq ScreenCorner
    Ord, Int -> ScreenCorner -> ShowS
    [ScreenCorner] -> ShowS
    ScreenCorner -> String
    (Int -> ScreenCorner -> ShowS)
    -> (ScreenCorner -> String)
    -> ([ScreenCorner] -> ShowS)
    -> Show ScreenCorner
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    showList :: [ScreenCorner] -> ShowS
    $cshowList :: [ScreenCorner] -> ShowS
    show :: ScreenCorner -> String
    $cshow :: ScreenCorner -> String
    showsPrec :: Int -> ScreenCorner -> ShowS
    $cshowsPrec :: Int -> ScreenCorner -> ShowS
    Show)

    --------------------------------------------------------------------------------
    -- ExtensibleState modifications
    --------------------------------------------------------------------------------

    newtype ScreenCornerState = ScreenCornerState (M.Map Window (ScreenCorner, X ()))
        deriving Typeable

    instance ExtensionClass ScreenCornerState where
        initialValue :: ScreenCornerState
    initialValue = Map Window (ScreenCorner, X ()) -> ScreenCornerState
    ScreenCornerState Map Window (ScreenCorner, X ())
    forall k a. Map k a
    M.empty

    -- | Add one single @X ()@ action to a screen corner
    addScreenCorner :: ScreenCorner -> X () -> X ()
    addScreenCorner :: ScreenCorner -> X () -> X ()
    addScreenCorner corner :: ScreenCorner
    corner xF :: X ()
    xF = do

        ScreenCornerState m :: Map Window (ScreenCorner, X ())
    m <- X ScreenCornerState
    forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
    XS.get
        (win :: Window
    win,xFunc :: X ()
    xFunc) <- case ((Window, (ScreenCorner, X ())) -> Bool)
    -> [(Window, (ScreenCorner, X ()))]
    -> Maybe (Window, (ScreenCorner, X ()))
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
    find (\(_,(sc :: ScreenCorner
    sc,_)) -> ScreenCorner
    sc ScreenCorner -> ScreenCorner -> Bool
    forall a. Eq a => a -> a -> Bool
    == ScreenCorner
    corner) (Map Window (ScreenCorner, X ()) -> [(Window, (ScreenCorner, X ()))]
    forall k a. Map k a -> [(k, a)]
    M.toList Map Window (ScreenCorner, X ())
    m) of

                            Just (w :: Window
    w, (_,xF' :: X ()
    xF')) -> (Window, X ()) -> X (Window, X ())
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Window
    w, X ()
    xF' X () -> X () -> X ()
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> X ()
    xF) -- chain X actions
                            Nothing           -> (Window -> X () -> (Window, X ()))
    -> X () -> Window -> (Window, X ())
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip (,) X ()
    xF (Window -> (Window, X ())) -> X Window -> X (Window, X ())
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    `fmap` ScreenCorner -> X Window
    createWindowAt ScreenCorner
    corner

        (ScreenCornerState -> ScreenCornerState) -> X ()
    forall a (m :: * -> *).
    (ExtensionClass a, XLike m) =>
    (a -> a) -> m ()
    XS.modify ((ScreenCornerState -> ScreenCornerState) -> X ())
    -> (ScreenCornerState -> ScreenCornerState) -> X ()
    forall a b. (a -> b) -> a -> b
    $ \(ScreenCornerState m' :: Map Window (ScreenCorner, X ())
    m') -> Map Window (ScreenCorner, X ()) -> ScreenCornerState
    ScreenCornerState (Map Window (ScreenCorner, X ()) -> ScreenCornerState)
    -> Map Window (ScreenCorner, X ()) -> ScreenCornerState
    forall a b. (a -> b) -> a -> b
    $ Window
    -> (ScreenCorner, X ())
    -> Map Window (ScreenCorner, X ())
    -> Map Window (ScreenCorner, X ())
    forall k a. Ord k => k -> a -> Map k a -> Map k a
    M.insert Window
    win (ScreenCorner
    corner,X ()
    xFunc) Map Window (ScreenCorner, X ())
    m'

    -- | Add a list of @(ScreenCorner, X ())@ tuples
    addScreenCorners :: [ (ScreenCorner, X ()) ] -> X ()
    addScreenCorners :: [(ScreenCorner, X ())] -> X ()
    addScreenCorners = ((ScreenCorner, X ()) -> X ()) -> [(ScreenCorner, X ())] -> X ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ (\(corner :: ScreenCorner
    corner, xF :: X ()
    xF) -> ScreenCorner -> X () -> X ()
    addScreenCorner ScreenCorner
    corner X ()
    xF)

    --------------------------------------------------------------------------------
    -- Xlib functions
    --------------------------------------------------------------------------------

    -- "Translate" a ScreenCorner to real (x,y) Positions
    createWindowAt :: ScreenCorner -> X Window
    createWindowAt :: ScreenCorner -> X Window
    createWindowAt SCUpperLeft = Position -> Position -> X Window
    createWindowAt' 0 0
    createWindowAt SCUpperRight = (Display -> X Window) -> X Window
    forall a. (Display -> X a) -> X a
    withDisplay ((Display -> X Window) -> X Window)
    -> (Display -> X Window) -> X Window
    forall a b. (a -> b) -> a -> b
    $ \dpy :: Display
    dpy ->
        let w :: CInt
    w = Display -> ScreenNumber -> CInt
    displayWidth  Display
    dpy (Display -> ScreenNumber
    defaultScreen Display
    dpy) CInt -> CInt -> CInt
    forall a. Num a => a -> a -> a
    - 1
        in Position -> Position -> X Window
    createWindowAt' (CInt -> Position
    forall a b. (Integral a, Num b) => a -> b
    fi CInt
    w) 0

    createWindowAt SCLowerLeft = (Display -> X Window) -> X Window
    forall a. (Display -> X a) -> X a
    withDisplay ((Display -> X Window) -> X Window)
    -> (Display -> X Window) -> X Window
    forall a b. (a -> b) -> a -> b
    $ \dpy :: Display
    dpy ->
        let h :: CInt
    h = Display -> ScreenNumber -> CInt
    displayHeight Display
    dpy (Display -> ScreenNumber
    defaultScreen Display
    dpy) CInt -> CInt -> CInt
    forall a. Num a => a -> a -> a
    - 1
        in Position -> Position -> X Window
    createWindowAt' 0 (CInt -> Position
    forall a b. (Integral a, Num b) => a -> b
    fi CInt
    h)

    createWindowAt SCLowerRight = (Display -> X Window) -> X Window
    forall a. (Display -> X a) -> X a
    withDisplay ((Display -> X Window) -> X Window)
    -> (Display -> X Window) -> X Window
    forall a b. (a -> b) -> a -> b
    $ \dpy :: Display
    dpy ->
        let w :: CInt
    w = Display -> ScreenNumber -> CInt
    displayWidth  Display
    dpy (Display -> ScreenNumber
    defaultScreen Display
    dpy) CInt -> CInt -> CInt
    forall a. Num a => a -> a -> a
    - 1
            h :: CInt
    h = Display -> ScreenNumber -> CInt
    displayHeight Display
    dpy (Display -> ScreenNumber
    defaultScreen Display
    dpy) CInt -> CInt -> CInt
    forall a. Num a => a -> a -> a
    - 1
        in Position -> Position -> X Window
    createWindowAt' (CInt -> Position
    forall a b. (Integral a, Num b) => a -> b
    fi CInt
    w) (CInt -> Position
    forall a b. (Integral a, Num b) => a -> b
    fi CInt
    h)

    -- Create a new X window at a (x,y) Position
    createWindowAt' :: Position -> Position -> X Window
    createWindowAt' :: Position -> Position -> X Window
    createWindowAt' x :: Position
    x y :: Position
    y = (Display -> X Window) -> X Window
    forall a. (Display -> X a) -> X a
    withDisplay ((Display -> X Window) -> X Window)
    -> (Display -> X Window) -> X Window
    forall a b. (a -> b) -> a -> b
    $ \dpy :: Display
    dpy -> IO Window -> X Window
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    io (IO Window -> X Window) -> IO Window -> X Window
    forall a b. (a -> b) -> a -> b
    $ do

        Window
    rootw <- Display -> ScreenNumber -> IO Window
    rootWindow Display
    dpy (Display -> ScreenNumber
    defaultScreen Display
    dpy)

        let
            visual :: Visual
    visual   = Screen -> Visual
    defaultVisualOfScreen (Screen -> Visual) -> Screen -> Visual
    forall a b. (a -> b) -> a -> b
    $ Display -> Screen
    defaultScreenOfDisplay Display
    dpy
            attrmask :: Window
    attrmask = Window
    cWOverrideRedirect

        Window
    w <- (Ptr SetWindowAttributes -> IO Window) -> IO Window
    forall a. (Ptr SetWindowAttributes -> IO a) -> IO a
    allocaSetWindowAttributes ((Ptr SetWindowAttributes -> IO Window) -> IO Window)
    -> (Ptr SetWindowAttributes -> IO Window) -> IO Window
    forall a b. (a -> b) -> a -> b
    $ \attributes :: Ptr SetWindowAttributes
    attributes -> do

            Ptr SetWindowAttributes -> Bool -> IO ()
    set_override_redirect Ptr SetWindowAttributes
    attributes Bool
    True
            Display
    -> Window
    -> Position
    -> Position
    -> ScreenNumber
    -> ScreenNumber
    -> CInt
    -> CInt
    -> CInt
    -> Visual
    -> Window
    -> Ptr SetWindowAttributes
    -> IO Window
    createWindow Display
    dpy        -- display
                         Window
    rootw      -- parent window
                         Position
    x          -- x
                         Position
    y          -- y
                         1          -- width
                         1          -- height
                         0          -- border width
                         0          -- depth
                         CInt
    inputOnly  -- class
                         Visual
    visual     -- visual
                         Window
    attrmask   -- valuemask
                         Ptr SetWindowAttributes
    attributes -- attributes

        -- we only need mouse entry events
        Display -> Window -> Window -> IO ()
    selectInput Display
    dpy Window
    w Window
    enterWindowMask
        Display -> Window -> IO ()
    mapWindow Display
    dpy Window
    w
        Display -> Bool -> IO ()
    sync Display
    dpy Bool
    False
        Window -> IO Window
    forall (m :: * -> *) a. Monad m => a -> m a
    return Window
    w

    --------------------------------------------------------------------------------
    -- Event hook
    --------------------------------------------------------------------------------

    -- | Handle screen corner events
    screenCornerEventHook :: Event -> X All
    screenCornerEventHook :: Event -> X All
    screenCornerEventHook CrossingEvent { ev_window :: Event -> Window
    ev_window = Window
    win } = do

        ScreenCornerState m :: Map Window (ScreenCorner, X ())
    m <- X ScreenCornerState
    forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
    XS.get

        case Window
    -> Map Window (ScreenCorner, X ()) -> Maybe (ScreenCorner, X ())
    forall k a. Ord k => k -> Map k a -> Maybe a
    M.lookup Window
    win Map Window (ScreenCorner, X ())
    m of
             Just (_, xF :: X ()
    xF) -> X ()
    xF
             Nothing      -> () -> X ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()

        All -> X All
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool -> All
    All Bool
    True)

    screenCornerEventHook _ = All -> X All
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool -> All
    All Bool
    True)

    --------------------------------------------------------------------------------
    -- Layout hook
    --------------------------------------------------------------------------------

    data ScreenCornerLayout a = ScreenCornerLayout
        deriving ( ReadPrec [ScreenCornerLayout a]
    ReadPrec (ScreenCornerLayout a)
    Int -> ReadS (ScreenCornerLayout a)
    ReadS [ScreenCornerLayout a]
    (Int -> ReadS (ScreenCornerLayout a))
    -> ReadS [ScreenCornerLayout a]
    -> ReadPrec (ScreenCornerLayout a)
    -> ReadPrec [ScreenCornerLayout a]
    -> Read (ScreenCornerLayout a)
    forall a. ReadPrec [ScreenCornerLayout a]
    forall a. ReadPrec (ScreenCornerLayout a)
    forall a. Int -> ReadS (ScreenCornerLayout a)
    forall a. ReadS [ScreenCornerLayout a]
    forall a.
    (Int -> ReadS a)
    -> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
    readListPrec :: ReadPrec [ScreenCornerLayout a]
    $creadListPrec :: forall a. ReadPrec [ScreenCornerLayout a]
    readPrec :: ReadPrec (ScreenCornerLayout a)
    $creadPrec :: forall a. ReadPrec (ScreenCornerLayout a)
    readList :: ReadS [ScreenCornerLayout a]
    $creadList :: forall a. ReadS [ScreenCornerLayout a]
    readsPrec :: Int -> ReadS (ScreenCornerLayout a)
    $creadsPrec :: forall a. Int -> ReadS (ScreenCornerLayout a)
    Read, Int -> ScreenCornerLayout a -> ShowS
    [ScreenCornerLayout a] -> ShowS
    ScreenCornerLayout a -> String
    (Int -> ScreenCornerLayout a -> ShowS)
    -> (ScreenCornerLayout a -> String)
    -> ([ScreenCornerLayout a] -> ShowS)
    -> Show (ScreenCornerLayout a)
    forall a. Int -> ScreenCornerLayout a -> ShowS
    forall a. [ScreenCornerLayout a] -> ShowS
    forall a. ScreenCornerLayout a -> String
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    showList :: [ScreenCornerLayout a] -> ShowS
    $cshowList :: forall a. [ScreenCornerLayout a] -> ShowS
    show :: ScreenCornerLayout a -> String
    $cshow :: forall a. ScreenCornerLayout a -> String
    showsPrec :: Int -> ScreenCornerLayout a -> ShowS
    $cshowsPrec :: forall a. Int -> ScreenCornerLayout a -> ShowS
    Show )

    instance LayoutModifier ScreenCornerLayout a where
        hook :: ScreenCornerLayout a -> X ()
    hook ScreenCornerLayout = (Display -> X ()) -> X ()
    forall a. (Display -> X a) -> X a
    withDisplay ((Display -> X ()) -> X ()) -> (Display -> X ()) -> X ()
    forall a b. (a -> b) -> a -> b
    $ \dpy :: Display
    dpy -> do
            ScreenCornerState m :: Map Window (ScreenCorner, X ())
    m <- X ScreenCornerState
    forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
    XS.get
            IO () -> X ()
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    io (IO () -> X ()) -> IO () -> X ()
    forall a b. (a -> b) -> a -> b
    $ (Window -> IO ()) -> [Window] -> IO ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ (Display -> Window -> IO ()
    raiseWindow Display
    dpy) ([Window] -> IO ()) -> [Window] -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Map Window (ScreenCorner, X ()) -> [Window]
    forall k a. Map k a -> [k]
    M.keys Map Window (ScreenCorner, X ())
    m
        unhook :: ScreenCornerLayout a -> X ()
    unhook = ScreenCornerLayout a -> X ()
    forall (m :: * -> *) a. LayoutModifier m a => m a -> X ()
    hook

    screenCornerLayoutHook :: l a -> ModifiedLayout ScreenCornerLayout l a
    screenCornerLayoutHook :: l a -> ModifiedLayout ScreenCornerLayout l a
    screenCornerLayoutHook = ScreenCornerLayout a
    -> l a -> ModifiedLayout ScreenCornerLayout l a
    forall (m :: * -> *) (l :: * -> *) a.
    m a -> l a -> ModifiedLayout m l a
    ModifiedLayout ScreenCornerLayout a
    forall a. ScreenCornerLayout a
    ScreenCornerLayout

    --------------------------------------------------------------------------------
    -- $usage
    --
    -- This extension adds KDE-like screen corners to XMonad. By moving your cursor
    -- into one of your screen corners you can trigger an @X ()@ action, for
    -- example @"XMonad.Actions.GridSelect".goToSelected@ or
    -- @"XMonad.Actions.CycleWS".nextWS@ etc.
    --
    -- To use it, import it on top of your @xmonad.hs@:
    --
    -- > import XMonad.Hooks.ScreenCorners
    --
    -- Then add your screen corners in our startup hook:
    --
    -- > myStartupHook = do
    -- >     ...
    -- >     addScreenCorner SCUpperRight (goToSelected defaultGSConfig { gs_cellwidth = 200})
    -- >     addScreenCorners [ (SCLowerRight, nextWS)
    -- >                      , (SCLowerLeft,  prevWS)
    -- >                      ]
    --
    -- Then add layout hook:
    --
    -- > myLayout = screenCornerLayoutHook $ tiled ||| Mirror tiled ||| Full where
    -- >     tiled   = Tall nmaster delta ratio
    -- >     nmaster = 1
    -- >     ratio   = 1 / 2
    -- >     delta   = 3 / 100
    --
    -- And finally wait for screen corner events in your event hook:
    --
    -- > myEventHook e = do
    -- >     ...
    -- >     screenCornerEventHook e