    {-# 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 (Eq, Ord, Show)

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

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

    instance ExtensionClass ScreenCornerState where
        initialValue = ScreenCornerState M.empty

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

        ScreenCornerState m <- XS.get
        (win,xFunc) <- case find (\(_,(sc,_)) -> sc == corner) (M.toList m) of

                            Just (w, (_,xF')) -> return (w, xF' >> xF) -- chain X actions
                            Nothing           -> flip (,) xF `fmap` createWindowAt corner

        XS.modify $ \(ScreenCornerState m') -> ScreenCornerState $ M.insert win (corner,xFunc) m'

    -- | Add a list of @(ScreenCorner, X ())@ tuples
    addScreenCorners :: [ (ScreenCorner, X ()) ] -> X ()
    addScreenCorners = mapM_ (\(corner, xF) -> addScreenCorner corner xF)

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

    -- "Translate" a ScreenCorner to real (x,y) Positions
    createWindowAt :: ScreenCorner -> X Window
    createWindowAt SCUpperLeft = createWindowAt' 0 0
    createWindowAt SCUpperRight = withDisplay $ \dpy ->
        let w = displayWidth  dpy (defaultScreen dpy) - 1
        in createWindowAt' (fi w) 0

    createWindowAt SCLowerLeft = withDisplay $ \dpy ->
        let h = displayHeight dpy (defaultScreen dpy) - 1
        in createWindowAt' 0 (fi h)

    createWindowAt SCLowerRight = withDisplay $ \dpy ->
        let w = displayWidth  dpy (defaultScreen dpy) - 1
            h = displayHeight dpy (defaultScreen dpy) - 1
        in createWindowAt' (fi w) (fi h)

    -- Create a new X window at a (x,y) Position
    createWindowAt' :: Position -> Position -> X Window
    createWindowAt' x y = withDisplay $ \dpy -> io $ do

        rootw <- rootWindow dpy (defaultScreen dpy)

        let
            visual   = defaultVisualOfScreen $ defaultScreenOfDisplay dpy
            attrmask = cWOverrideRedirect

        w <- allocaSetWindowAttributes $ \attributes -> do

            set_override_redirect attributes True
            createWindow dpy        -- display
                         rootw      -- parent window
                         x          -- x
                         y          -- y
                         1          -- width
                         1          -- height
                         0          -- border width
                         0          -- depth
                         inputOnly  -- class
                         visual     -- visual
                         attrmask   -- valuemask
                         attributes -- attributes

        -- we only need mouse entry events
        selectInput dpy w enterWindowMask
        mapWindow dpy w
        sync dpy False
        return w

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

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

        ScreenCornerState m <- XS.get

        case M.lookup win m of
             Just (_, xF) -> xF
             Nothing      -> return ()

        return (All True)

    screenCornerEventHook _ = return (All True)

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

    data ScreenCornerLayout a = ScreenCornerLayout
        deriving ( Read, Show )

    instance LayoutModifier ScreenCornerLayout a where
        hook ScreenCornerLayout = withDisplay $ \dpy -> do
            ScreenCornerState m <- XS.get
            io $ mapM_ (raiseWindow dpy) $ M.keys m
        unhook = hook

    screenCornerLayoutHook :: l a -> ModifiedLayout ScreenCornerLayout l a
    screenCornerLayoutHook = ModifiedLayout 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