{-# LINE 1 "XMonad/Hooks/PerWindowKbdLayout.hsc" #-}
{-# LANGUAGE ScopedTypeVariables, ForeignFunctionInterface, MultiParamTypeClasses, DeriveDataTypeable, FlexibleInstances, PatternGuards #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-} -- GHC 6.10.4 complains about Foreign.C.Types, see Ticket #3419

-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Hooks.PerWindowKbdLayout
-- Copyright   :  (c) Konstantin Sobolev <konstantin.sobolev@gmail.com>
-- License     :  BSD-style (see LICENSE)
--
-- Maintainer  :  Konstantin Sobolev <konstantin.sobolev@gmail.com>
-- Stability   :  unstable
-- Portability :  unportable
--
-- A hook that remembers per-window keyboard layouts and switches them
-- on focus changes.
--
-----------------------------------------------------------------------------

module XMonad.Hooks.PerWindowKbdLayout (
                                -- * Usage
                                -- $usage
                                perWindowKbdLayout) where

import Foreign
import Foreign.C.Types (CUChar,CUShort,CUInt(..),CInt(..))

import Control.Monad (when)
import Data.List (find)
import qualified Data.Map as M
import Data.Monoid (All(..))
import Data.Traversable (traverse)

import XMonad
import qualified XMonad.StackSet as W
import qualified XMonad.Util.ExtensibleState as XS



-- $usage
-- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:
--
-- > import XMonad.Hooks.PerWindowKbdLayout
--
-- Then edit your @eventHook@ by adding 'perWindowKbdLayout', for example
--
-- > main = xmonad defaultConfig { handleEventHook = perWindowKbdLayout }

data XkbStateRec = XkbStateRec {
    XkbStateRec -> CUChar
group :: CUChar,
    XkbStateRec -> CUChar
locked_group :: CUChar,
    XkbStateRec -> CUShort
base_group :: CUShort,
    XkbStateRec -> CUShort
latched_group :: CUShort,
    XkbStateRec -> CUChar
mods :: CUChar,
    XkbStateRec -> CUChar
base_mods :: CUChar,
    XkbStateRec -> CUChar
latched_mods :: CUChar,
    XkbStateRec -> CUChar
locked_mods :: CUChar,
    XkbStateRec -> CUChar
compat_state :: CUChar,
    XkbStateRec -> CUChar
grab_mods :: CUChar,
    XkbStateRec -> CUChar
compat_grab_mods :: CUChar,
    XkbStateRec -> CUChar
lookup_mods :: CUChar,
    XkbStateRec -> CUChar
compat_lookup_mods :: CUChar,
    XkbStateRec -> CUShort
ptr_buttons :: CUShort
}

instance Storable XkbStateRec where
    sizeOf :: XkbStateRec -> KbdLayout
sizeOf XkbStateRec
_ = ((KbdLayout
18))
{-# LINE 67 "XMonad/Hooks/PerWindowKbdLayout.hsc" #-}
    alignment _ = alignment (undefined :: CUShort)
    peek :: Ptr XkbStateRec -> IO XkbStateRec
peek Ptr XkbStateRec
ptr = do
        CUChar
r_group <- ((\Ptr XkbStateRec
hsc_ptr -> Ptr XkbStateRec -> KbdLayout -> IO CUChar
forall b. Ptr b -> KbdLayout -> IO CUChar
forall a b. Storable a => Ptr b -> KbdLayout -> IO a
peekByteOff Ptr XkbStateRec
hsc_ptr KbdLayout
0)) Ptr XkbStateRec
ptr
{-# LINE 70 "XMonad/Hooks/PerWindowKbdLayout.hsc" #-}
        CUChar
r_locked_group <- ((\Ptr XkbStateRec
hsc_ptr -> Ptr XkbStateRec -> KbdLayout -> IO CUChar
forall b. Ptr b -> KbdLayout -> IO CUChar
forall a b. Storable a => Ptr b -> KbdLayout -> IO a
peekByteOff Ptr XkbStateRec
hsc_ptr KbdLayout
1)) Ptr XkbStateRec
ptr
{-# LINE 71 "XMonad/Hooks/PerWindowKbdLayout.hsc" #-}
        CUShort
r_base_group <- ((\Ptr XkbStateRec
hsc_ptr -> Ptr XkbStateRec -> KbdLayout -> IO CUShort
forall b. Ptr b -> KbdLayout -> IO CUShort
forall a b. Storable a => Ptr b -> KbdLayout -> IO a
peekByteOff Ptr XkbStateRec
hsc_ptr KbdLayout
2)) Ptr XkbStateRec
ptr
{-# LINE 72 "XMonad/Hooks/PerWindowKbdLayout.hsc" #-}
        CUShort
r_latched_group <- ((\Ptr XkbStateRec
hsc_ptr -> Ptr XkbStateRec -> KbdLayout -> IO CUShort
forall b. Ptr b -> KbdLayout -> IO CUShort
forall a b. Storable a => Ptr b -> KbdLayout -> IO a
peekByteOff Ptr XkbStateRec
hsc_ptr KbdLayout
4)) Ptr XkbStateRec
ptr
{-# LINE 73 "XMonad/Hooks/PerWindowKbdLayout.hsc" #-}
        CUChar
r_mods <- ((\Ptr XkbStateRec
hsc_ptr -> Ptr XkbStateRec -> KbdLayout -> IO CUChar
forall b. Ptr b -> KbdLayout -> IO CUChar
forall a b. Storable a => Ptr b -> KbdLayout -> IO a
peekByteOff Ptr XkbStateRec
hsc_ptr KbdLayout
6)) Ptr XkbStateRec
ptr
{-# LINE 74 "XMonad/Hooks/PerWindowKbdLayout.hsc" #-}
        CUChar
r_base_mods <- ((\Ptr XkbStateRec
hsc_ptr -> Ptr XkbStateRec -> KbdLayout -> IO CUChar
forall b. Ptr b -> KbdLayout -> IO CUChar
forall a b. Storable a => Ptr b -> KbdLayout -> IO a
peekByteOff Ptr XkbStateRec
hsc_ptr KbdLayout
7)) Ptr XkbStateRec
ptr
{-# LINE 75 "XMonad/Hooks/PerWindowKbdLayout.hsc" #-}
        CUChar
r_latched_mods <- ((\Ptr XkbStateRec
hsc_ptr -> Ptr XkbStateRec -> KbdLayout -> IO CUChar
forall b. Ptr b -> KbdLayout -> IO CUChar
forall a b. Storable a => Ptr b -> KbdLayout -> IO a
peekByteOff Ptr XkbStateRec
hsc_ptr KbdLayout
8)) Ptr XkbStateRec
ptr
{-# LINE 76 "XMonad/Hooks/PerWindowKbdLayout.hsc" #-}
        CUChar
r_locked_mods <- ((\Ptr XkbStateRec
hsc_ptr -> Ptr XkbStateRec -> KbdLayout -> IO CUChar
forall b. Ptr b -> KbdLayout -> IO CUChar
forall a b. Storable a => Ptr b -> KbdLayout -> IO a
peekByteOff Ptr XkbStateRec
hsc_ptr KbdLayout
9)) Ptr XkbStateRec
ptr
{-# LINE 77 "XMonad/Hooks/PerWindowKbdLayout.hsc" #-}
        CUChar
r_compat_state <- ((\Ptr XkbStateRec
hsc_ptr -> Ptr XkbStateRec -> KbdLayout -> IO CUChar
forall b. Ptr b -> KbdLayout -> IO CUChar
forall a b. Storable a => Ptr b -> KbdLayout -> IO a
peekByteOff Ptr XkbStateRec
hsc_ptr KbdLayout
10)) Ptr XkbStateRec
ptr
{-# LINE 78 "XMonad/Hooks/PerWindowKbdLayout.hsc" #-}
        CUChar
r_grab_mods <- ((\Ptr XkbStateRec
hsc_ptr -> Ptr XkbStateRec -> KbdLayout -> IO CUChar
forall b. Ptr b -> KbdLayout -> IO CUChar
forall a b. Storable a => Ptr b -> KbdLayout -> IO a
peekByteOff Ptr XkbStateRec
hsc_ptr KbdLayout
11)) Ptr XkbStateRec
ptr
{-# LINE 79 "XMonad/Hooks/PerWindowKbdLayout.hsc" #-}
        CUChar
r_compat_grab_mods <- ((\Ptr XkbStateRec
hsc_ptr -> Ptr XkbStateRec -> KbdLayout -> IO CUChar
forall b. Ptr b -> KbdLayout -> IO CUChar
forall a b. Storable a => Ptr b -> KbdLayout -> IO a
peekByteOff Ptr XkbStateRec
hsc_ptr KbdLayout
12)) Ptr XkbStateRec
ptr
{-# LINE 80 "XMonad/Hooks/PerWindowKbdLayout.hsc" #-}
        CUChar
r_lookup_mods <- ((\Ptr XkbStateRec
hsc_ptr -> Ptr XkbStateRec -> KbdLayout -> IO CUChar
forall b. Ptr b -> KbdLayout -> IO CUChar
forall a b. Storable a => Ptr b -> KbdLayout -> IO a
peekByteOff Ptr XkbStateRec
hsc_ptr KbdLayout
13)) Ptr XkbStateRec
ptr
{-# LINE 81 "XMonad/Hooks/PerWindowKbdLayout.hsc" #-}
        CUChar
r_compat_lookup_mods <- ((\Ptr XkbStateRec
hsc_ptr -> Ptr XkbStateRec -> KbdLayout -> IO CUChar
forall b. Ptr b -> KbdLayout -> IO CUChar
forall a b. Storable a => Ptr b -> KbdLayout -> IO a
peekByteOff Ptr XkbStateRec
hsc_ptr KbdLayout
14)) Ptr XkbStateRec
ptr
{-# LINE 82 "XMonad/Hooks/PerWindowKbdLayout.hsc" #-}
        CUShort
r_ptr_buttons <- ((\Ptr XkbStateRec
hsc_ptr -> Ptr XkbStateRec -> KbdLayout -> IO CUShort
forall b. Ptr b -> KbdLayout -> IO CUShort
forall a b. Storable a => Ptr b -> KbdLayout -> IO a
peekByteOff Ptr XkbStateRec
hsc_ptr KbdLayout
16)) Ptr XkbStateRec
ptr
{-# LINE 83 "XMonad/Hooks/PerWindowKbdLayout.hsc" #-}
        XkbStateRec -> IO XkbStateRec
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return XkbStateRec {
            group :: CUChar
group = CUChar
r_group,
            locked_group :: CUChar
locked_group = CUChar
r_locked_group,
            base_group :: CUShort
base_group = CUShort
r_base_group,
            latched_group :: CUShort
latched_group = CUShort
r_latched_group,
            mods :: CUChar
mods = CUChar
r_mods,
            base_mods :: CUChar
base_mods = CUChar
r_base_mods,
            latched_mods :: CUChar
latched_mods = CUChar
r_latched_mods,
            locked_mods :: CUChar
locked_mods = CUChar
r_locked_mods,
            compat_state :: CUChar
compat_state = CUChar
r_compat_state,
            grab_mods :: CUChar
grab_mods = CUChar
r_grab_mods,
            compat_grab_mods :: CUChar
compat_grab_mods = CUChar
r_compat_grab_mods,
            lookup_mods :: CUChar
lookup_mods = CUChar
r_lookup_mods,
            compat_lookup_mods :: CUChar
compat_lookup_mods = CUChar
r_compat_lookup_mods,
            ptr_buttons :: CUShort
ptr_buttons = CUShort
r_ptr_buttons
        }
    poke :: Ptr XkbStateRec -> XkbStateRec -> IO ()
poke Ptr XkbStateRec
_ = [Char] -> XkbStateRec -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"poke is unimplemented and should be unused"

foreign import ccall unsafe "X11/XKBlib.h XkbGetState"
    xkbGetState :: Display -> CUInt -> Ptr XkbStateRec -> IO CInt

foreign import ccall unsafe "XkbLockGroup" xkbLockGroup :: Display -> CUInt -> CUInt -> IO ()

type KbdLayout = Int

getKbdLayout :: Display -> IO KbdLayout
getKbdLayout :: Display -> IO KbdLayout
getKbdLayout Display
d = (Ptr XkbStateRec -> IO KbdLayout) -> IO KbdLayout
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr XkbStateRec -> IO KbdLayout) -> IO KbdLayout)
-> (Ptr XkbStateRec -> IO KbdLayout) -> IO KbdLayout
forall a b. (a -> b) -> a -> b
$ \Ptr XkbStateRec
stRecPtr -> do
    Display -> CUInt -> Ptr XkbStateRec -> IO CInt
xkbGetState Display
d (CUInt
256) Ptr XkbStateRec
stRecPtr
{-# LINE 111 "XMonad/Hooks/PerWindowKbdLayout.hsc" #-}
    st <- peek stRecPtr
    KbdLayout -> IO KbdLayout
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (KbdLayout -> IO KbdLayout) -> KbdLayout -> IO KbdLayout
forall a b. (a -> b) -> a -> b
$ CUChar -> KbdLayout
forall a b. (Integral a, Num b) => a -> b
fromIntegral (XkbStateRec -> CUChar
group XkbStateRec
st)

setKbdLayout :: Display -> KbdLayout -> IO ()
setKbdLayout :: Display -> KbdLayout -> IO ()
setKbdLayout Display
d KbdLayout
l = Display -> CUInt -> CUInt -> IO ()
xkbLockGroup Display
d (CUInt
256) (CUInt -> IO ()) -> CUInt -> IO ()
forall a b. (a -> b) -> a -> b
$ KbdLayout -> CUInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral KbdLayout
l
{-# LINE 116 "XMonad/Hooks/PerWindowKbdLayout.hsc" #-}

data LayoutStorage = LayoutStorage (Maybe Window) (M.Map Window KbdLayout) deriving (Typeable,ReadPrec [LayoutStorage]
ReadPrec LayoutStorage
KbdLayout -> ReadS LayoutStorage
ReadS [LayoutStorage]
(KbdLayout -> ReadS LayoutStorage)
-> ReadS [LayoutStorage]
-> ReadPrec LayoutStorage
-> ReadPrec [LayoutStorage]
-> Read LayoutStorage
forall a.
(KbdLayout -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: KbdLayout -> ReadS LayoutStorage
readsPrec :: KbdLayout -> ReadS LayoutStorage
$creadList :: ReadS [LayoutStorage]
readList :: ReadS [LayoutStorage]
$creadPrec :: ReadPrec LayoutStorage
readPrec :: ReadPrec LayoutStorage
$creadListPrec :: ReadPrec [LayoutStorage]
readListPrec :: ReadPrec [LayoutStorage]
Read,KbdLayout -> LayoutStorage -> ShowS
[LayoutStorage] -> ShowS
LayoutStorage -> [Char]
(KbdLayout -> LayoutStorage -> ShowS)
-> (LayoutStorage -> [Char])
-> ([LayoutStorage] -> ShowS)
-> Show LayoutStorage
forall a.
(KbdLayout -> a -> ShowS)
-> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: KbdLayout -> LayoutStorage -> ShowS
showsPrec :: KbdLayout -> LayoutStorage -> ShowS
$cshow :: LayoutStorage -> [Char]
show :: LayoutStorage -> [Char]
$cshowList :: [LayoutStorage] -> ShowS
showList :: [LayoutStorage] -> ShowS
Show)
instance ExtensionClass LayoutStorage where initialValue :: LayoutStorage
initialValue = Maybe Window -> Map Window KbdLayout -> LayoutStorage
LayoutStorage Maybe Window
forall a. Maybe a
Nothing Map Window KbdLayout
forall k a. Map k a
M.empty

perWindowKbdLayout :: Event -> X All
perWindowKbdLayout :: Event -> X All
perWindowKbdLayout (DestroyWindowEvent {ev_window :: Event -> Window
ev_window = Window
w, ev_event_type :: Event -> EventType
ev_event_type = EventType
et}) = do
    Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (EventType
et EventType -> EventType -> Bool
forall a. Eq a => a -> a -> Bool
== EventType
destroyNotify) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$
        (LayoutStorage -> LayoutStorage) -> X ()
forall a (m :: * -> *).
(ExtensionClass a, XLike m) =>
(a -> a) -> m ()
XS.modify ((LayoutStorage -> LayoutStorage) -> X ())
-> (LayoutStorage -> LayoutStorage) -> X ()
forall a b. (a -> b) -> a -> b
$ \(LayoutStorage Maybe Window
mpf Map Window KbdLayout
wtl) -> (Maybe Window -> Map Window KbdLayout -> LayoutStorage
LayoutStorage Maybe Window
mpf (Window -> Map Window KbdLayout -> Map Window KbdLayout
forall k a. Ord k => k -> Map k a -> Map k a
M.delete Window
w Map Window KbdLayout
wtl))
    All -> X All
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> All
All Bool
True)
perWindowKbdLayout Event
_ = do
    Maybe (Stack Window)
mst <- (XState -> Maybe (Stack Window)) -> X (Maybe (Stack Window))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Workspace [Char] (Layout Window) Window -> Maybe (Stack Window)
forall i l a. Workspace i l a -> Maybe (Stack a)
W.stack (Workspace [Char] (Layout Window) Window -> Maybe (Stack Window))
-> (XState -> Workspace [Char] (Layout Window) Window)
-> XState
-> Maybe (Stack Window)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Screen [Char] (Layout Window) Window ScreenId ScreenDetail
-> Workspace [Char] (Layout Window) Window
forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
W.workspace (Screen [Char] (Layout Window) Window ScreenId ScreenDetail
 -> Workspace [Char] (Layout Window) Window)
-> (XState
    -> Screen [Char] (Layout Window) Window ScreenId ScreenDetail)
-> XState
-> Workspace [Char] (Layout Window) Window
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StackSet [Char] (Layout Window) Window ScreenId ScreenDetail
-> Screen [Char] (Layout Window) Window ScreenId ScreenDetail
forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current (StackSet [Char] (Layout Window) Window ScreenId ScreenDetail
 -> Screen [Char] (Layout Window) Window ScreenId ScreenDetail)
-> (XState
    -> StackSet [Char] (Layout Window) Window ScreenId ScreenDetail)
-> XState
-> Screen [Char] (Layout Window) Window ScreenId ScreenDetail
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState
-> StackSet [Char] (Layout Window) Window ScreenId ScreenDetail
windowset)
    (Window -> X ()) -> Maybe Window -> X (Maybe ())
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse Window -> X ()
update (Maybe Window -> X (Maybe ())) -> Maybe Window -> X (Maybe ())
forall a b. (a -> b) -> a -> b
$ Stack Window -> Window
forall a. Stack a -> a
W.focus (Stack Window -> Window) -> Maybe (Stack Window) -> Maybe Window
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Maybe (Stack Window)
mst
    All -> X All
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> All
All Bool
True)

update :: Window -> X()
update :: Window -> X ()
update Window
foc = (Display -> X ()) -> X ()
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X ()) -> X ()) -> (Display -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \Display
dpy -> do
    (LayoutStorage Maybe Window
mpf Map Window KbdLayout
wtl) <- X LayoutStorage
forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get
    KbdLayout
curLayout <- IO KbdLayout -> X KbdLayout
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO KbdLayout -> X KbdLayout) -> IO KbdLayout -> X KbdLayout
forall a b. (a -> b) -> a -> b
$ Display -> IO KbdLayout
getKbdLayout Display
dpy
    case Maybe Window
mpf of
        Maybe Window
Nothing ->
            LayoutStorage -> X ()
forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
XS.put (Maybe Window -> Map Window KbdLayout -> LayoutStorage
LayoutStorage (Window -> Maybe Window
forall a. a -> Maybe a
Just Window
foc) (Window -> KbdLayout -> Map Window KbdLayout -> Map Window KbdLayout
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Window
foc KbdLayout
curLayout Map Window KbdLayout
wtl))
        Just Window
pf -> Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Window
pf Window -> Window -> Bool
forall a. Eq a => a -> a -> Bool
/= Window
foc) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ do
            LayoutStorage -> X ()
forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
XS.put (Maybe Window -> Map Window KbdLayout -> LayoutStorage
LayoutStorage (Window -> Maybe Window
forall a. a -> Maybe a
Just Window
foc) (Window -> KbdLayout -> Map Window KbdLayout -> Map Window KbdLayout
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Window
pf KbdLayout
curLayout Map Window KbdLayout
wtl))
            IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ Maybe KbdLayout -> (KbdLayout -> IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust (Window -> Map Window KbdLayout -> Maybe KbdLayout
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Window
foc Map Window KbdLayout
wtl) (Display -> KbdLayout -> IO ()
setKbdLayout Display
dpy)

-- vim:ft=haskell:ts=4:shiftwidth=4:softtabstop=4:expandtab: