Keyboard.hs

-- | Allows to switch keyboard layouts
-- Uses the command-line utility setxkbmap.
module XMonad.Util.Keyboard ( KbLayout (..)
                            , showKBLayout
                            , xmobarKbLayout
                            , parseKB
                            , setLang
                            , tibetan
                            , accented
                            , français
                            , deutsch
                            , dansk
                            , dzongkha
                            , defaultKbLayout
                            ) where

import           Control.Composition
import           System.Process
import           XMonad

-- | Datatype for a keyboard layout.
data KbLayout = Simple String | Regional String String

xmobarColor :: String -- ^ Foreground color
            -> String -- ^ Background color
            -> String -- ^ Contents of string
            -> String
xmobarColor fg bg contents = "<fc=" ++ fg ++ "," ++ bg ++ ">" ++ contents ++ "</fc>"

-- | Print a keyboard layout suitable for piping to XMobar.
xmobarKbLayout :: KbLayout -> String
xmobarKbLayout (Simple "us") = "US"
xmobarKbLayout (Simple "layout") = "US"
xmobarKbLayout (Regional "cn" "tib") = xmobarColor "yellow" "black" "Tibetan"
xmobarKbLayout (Simple "bt") = xmobarColor "yellow" "black" "Dzongkha"
xmobarKbLayout (Regional "us" "altgr-intl") = "US Extended"
xmobarKbLayout (Simple "fr") = "Fr"
xmobarKbLayout (Simple "de") = "De"
xmobarKbLayout (Simple "dk") = "Dk"
xmobarKbLayout _ = xmobarColor "red" "black" "ERROR"

-- | Default keyboard layout is vanilla "us"
defaultKbLayout :: KbLayout
defaultKbLayout = Simple "us"

-- | Pretty-print current layout
showKBLayout :: IO String
showKBLayout = xmobarKbLayout <$> parseKB

-- | Get current keyboard layout
parseKB :: IO KbLayout
parseKB = do
    out <- lines <$> readCreateProcess (shell "setxkbmap -query") ""
    let strip = dropWhile (==' ') . drop 1 . dropWhile (/=':') .* (!!)
        line = strip out
    if length out == 3
        then pure (Simple (line 2))
        else pure (Regional (line 2) (line 3))

-- | Tibetan keyboard layout
tibetan :: KbLayout
tibetan  = Regional "cn" "tib"

-- | AZERTY French keyboard
français :: KbLayout
français = Simple "fr"

-- | QWERTZ German keyboard
deutsch :: KbLayout
deutsch = Simple "de"

-- | Danish keyboard
dansk :: KbLayout
dansk = Simple "dk"

-- | Dzongkha keyboard
dzongkha :: KbLayout
dzongkha = Simple "bt"

-- | Alr-gr keyboard providing common accents on a US keyboard
accented :: KbLayout
accented = Regional "us" "altgr-intl"

-- | Set keyboard layout
setLang :: KbLayout -> X ()
setLang (Simple lc) = spawn $ "setxkbmap " ++ lc
setLang (Regional lc r) = spawn $ "setxkbmap -layout " ++ lc ++ " -variant " ++ r