Pasted

-- ghc --make xmonad.hs -lXi -i -ilib -fforce-recomp -main-is main -dynamic -v0 -o /home/svon/.xmonad/xmonad-x86_64-linux
 
import XMonad
import qualified XMonad.Util.Run as UR
import qualified XMonad.StackSet as SS
import qualified XMonad.Hooks.ManageDocks as HMD
import qualified XMonad.Hooks.DynamicLog as HDL
 
import qualified Data.Map as M
 
import qualified Foreign as F
import qualified Foreign.C.Types as FCT
import qualified Foreign.Marshal.Array as FMA
import qualified Foreign.Ptr as FP
 
screensCount :: Integer
screensCount = 2
 
font :: String
font = "xos4 Terminus:style=Regular:stylelang=en,en:slant=0:weight=80:width=100:pixelsize=12:spacing=110:foundr7 218-21b 232-233 237 254 258-259 25b 272 292 2bb-2bd 2c6-2c7 2d8-2d9 2db-2dd 300-308 30a-30c 329 384-38a 38c 381e40-1e47 1e6c-1e6d 1eb8-1eb9 1ebc-1ebd 1eca-1ecd 1ee4-1ee5 1ef8-1ef9 2000-2022 2026 2030 2032-2033 2039-203a 20200 2203-2206 2208-220d 2212 2219-221a 221e-221f 2227-222a 2248 2260-2261 2264-2265 2300 2302 2310 2319 2320-232bc 25c0 25c6 25ca-25cb 25cf 25d8-25d9 263a-263c 2640 2642 2660 2663 2665-2666 266a-266b 2713-2714 2717-2718 2800e|el|en|eo|es|et|eu|fi|fj|fo|fr|fur|fy|gd|gl|gn|gv|haw|ho|hr|hu|ia|ig|id|ie|ik|io|is|it|kaa|ki|kk|kl|kum|kv|kw|ka|smj|smn|so|sq|sr|ss|st|sv|sw|tg|tk|tl|tn|to|tr|ts|tt|tw|tyv|uk|uz|vo|vot|wa|wen|wo|xh|yap|zu|ak|an|crh|csb|fatF:decorative=False:postscriptname=Terminus:color=False:symbol=False"
 
_keys :: M.Map ( KeyMask, KeySym ) ( X () )
_keys = M.fromList $
    [ ( (               mod4Mask, xK_p ), spawn $ "dmenu_run -fn '" ++ font ++ "' "                     ) 
    , ( (               mod4Mask, xK_w ), toNextScreen (  1 ) SS.view >> adjustFocus >> adjustInputArea ) 
    , ( ( shiftMask .|. mod4Mask, xK_w ), toNextScreen (  1 ) SS.shift                                  ) 
 
    , ( (               mod4Mask, xK_s ), toNextScreen ( -1 ) SS.view >> adjustFocus >> adjustInputArea ) 
    , ( ( shiftMask .|. mod4Mask, xK_s ), toNextScreen ( -1 ) SS.shift                                  ) 
 
    ] 
    
main :: IO ()
main = do 
    xmobarHandle <- UR.spawnPipe "xmobar"
 
    let 
        _logHook = do
            statusBarStr <- HDL.dynamicLogString def
            io $ UR.hPutStrLn xmobarHandle statusBarStr
 
    
    xmonad $ HMD.docks $ def
        { terminal           = "xterm"
        , modMask            = mod4Mask
        , normalBorderColor  = "#000000"
        , focusedBorderColor = "#999999"
        , borderWidth        = 1
        , focusFollowsMouse  = False
        , logHook            = _logHook
        , layoutHook         = HMD.avoidStruts $ layoutHook def
        , keys               = M.union _keys . keys def
        }
 
 
----------------------------------------------------------------------------------------------------
----------------------------------------------------------------------------------------------------
 
 
foreign import ccall "XIChangeProperty" xiChangeProperty 
    :: Display          
    -> FCT.CInt         
    -> Atom             
    -> Atom             
    -> FCT.CInt         
    -> FCT.CInt         
    -> F.Ptr FCT.CUChar 
    -> FCT.CInt         
    -> IO ()
 
 
applyMatrix :: Display -> [ Float ] -> IO ()
applyMatrix dpy matrix = 
    FMA.withArray ( FCT.CFloat <$> matrix ) fn
 
    where 
        fn matrixPtr = do
            ctmAtom   <- internAtom dpy "Coordinate Transformation Matrix" False
            floatAtom <- internAtom dpy "FLOAT" False 
 
            xiChangeProperty 
                ( dpy                 )
                ( FCT.CInt 17         )
                ( ctmAtom             ) 
                ( floatAtom           )
                ( FCT.CInt 32         )
                ( FCT.CInt 0          )
                ( F.castPtr matrixPtr )
                ( FCT.CInt 9          )
 
adjustInputArea :: X () 
adjustInputArea = do
    xconf  <- ask
    xstate <- get
    
--------------------------------------------------------------------------------
 
    let 
        currentDisplay = display xconf
        defaultScreenNumber = screenNumberOfScreen $ defaultScreenOfDisplay currentDisplay
 
        dh = fromIntegral $ displayHeight currentDisplay defaultScreenNumber
        dw = fromIntegral $ displayWidth  currentDisplay defaultScreenNumber 
 
        currentScreenRect = screenRect $ SS.screenDetail $ SS.current $ windowset xstate
 
        sh = fromIntegral $ rect_height currentScreenRect
        sw = fromIntegral $ rect_width  currentScreenRect
        sy = fromIntegral $ rect_y      currentScreenRect
        sx = fromIntegral $ rect_x      currentScreenRect
 
        matrix =
            [ sw / dw,       0, sx / dw
            ,       0, sh / dh, sy / dh
            ,       0,       0,       1
            ]
 
 
--------------------------------------------------------------------------------
    io $ applyMatrix currentDisplay matrix
 
 
adjustFocus :: X ()
adjustFocus = do
    xconf  <- ask
 
    let 
        currentDisplay = display xconf
 
        windowAttributesHandler window attributes = 
            io $ do 
                warpPointer
                    ( currentDisplay            )
                    ( 0                         )
                    ( window                    ) 
                    ( 0                         ) 
                    ( 0                         ) 
                    ( 0                         ) 
                    ( 0                         ) 
                    ( fromIntegral $ ww `div` 2 )
                    ( fromIntegral $ wh `div` 2 ) 
 
                flush currentDisplay 
            where
                wh = wa_height attributes
                ww = wa_width  attributes
 
        focusedWindowHandler window = 
            withWindowAttributes currentDisplay window $ windowAttributesHandler window
 
    withFocused focusedWindowHandler
 
 
withScreenId :: ( ScreenId -> X a ) -> X a
withScreenId f = 
    withWindowSet ( f . SS.screen . SS.current  )
 
toNextScreen :: Integer -> ( WorkspaceId -> WindowSet -> WindowSet ) -> X ()
toNextScreen step f  = do 
    mWorkspace <- withScreenId $ screenWorkspace . nextScreenId step
    whenJust mWorkspace $ windows . f
    where
        scrsCount = fromInteger screensCount
        nextScreenId :: Integer -> ScreenId -> ScreenId
        nextScreenId step csid = 
            ( scrsCount + csid + fromInteger step ) `mod` scrsCount