Back to app/src, since it seems they're the default convention for stack

6 files changed, 749 insertions, 0 deletions

diff --git a/src/Xmobar/System/DBus.hs b/src/Xmobar/System/DBus.hs
new file mode 100644
index 0000000..103a5a9
--- /dev/null
+++ b/src/Xmobar/System/DBus.hs
@@ -0,0 +1,73 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  DBus
+-- Copyright   :  (c) Jochen Keil
+-- License     :  BSD-style (see LICENSE)
+--
+-- Maintainer  :  Jochen Keil <jochen dot keil at gmail dot com>
+-- Stability   :  unstable
+-- Portability :  unportable
+--
+-- DBus IPC module for Xmobar
+--
+-----------------------------------------------------------------------------
+
+module Xmobar.System.DBus (runIPC) where
+
+import DBus
+import DBus.Client hiding (interfaceName)
+import qualified DBus.Client as DC
+import Data.Maybe (isNothing)
+import Control.Concurrent.STM
+import Control.Exception (handle)
+import System.IO (stderr, hPutStrLn)
+import Control.Monad.IO.Class (liftIO)
+
+import Xmobar.System.Signal
+
+busName :: BusName
+busName = busName_ "org.Xmobar.Control"
+
+objectPath :: ObjectPath
+objectPath = objectPath_ "/org/Xmobar/Control"
+
+interfaceName :: InterfaceName
+interfaceName = interfaceName_ "org.Xmobar.Control"
+
+runIPC :: TMVar SignalType -> IO ()
+runIPC mvst = handle printException exportConnection
+    where
+    printException :: ClientError -> IO ()
+    printException = hPutStrLn stderr . clientErrorMessage
+    exportConnection = do
+        client <- connectSession
+        requestName client busName [ nameDoNotQueue ]
+        export client objectPath defaultInterface
+          { DC.interfaceName = interfaceName
+          , DC.interfaceMethods = [ sendSignalMethod mvst ]
+          }
+
+sendSignalMethod :: TMVar SignalType -> Method
+sendSignalMethod mvst = makeMethod sendSignalName
+    (signature_ [variantType $ toVariant (undefined :: SignalType)])
+    (signature_ [])
+    sendSignalMethodCall
+    where
+    sendSignalName :: MemberName
+    sendSignalName = memberName_ "SendSignal"
+
+    sendSignalMethodCall :: MethodCall -> DBusR Reply
+    sendSignalMethodCall mc = liftIO $
+        if methodCallMember mc == sendSignalName
+          then do
+            let signals :: [Maybe SignalType]
+                signals = map fromVariant (methodCallBody mc)
+            mapM_ sendSignal signals
+            if any isNothing signals
+              then return ( ReplyError errorInvalidParameters [] )
+              else return ( ReplyReturn [] )
+          else
+            return ( ReplyError errorUnknownMethod [] )
+
+    sendSignal :: Maybe SignalType -> IO ()
+    sendSignal = maybe (return ()) (atomically . putTMVar mvst)
diff --git a/src/Xmobar/System/Environment.hs b/src/Xmobar/System/Environment.hs
new file mode 100644
index 0000000..86197db
--- /dev/null
+++ b/src/Xmobar/System/Environment.hs
@@ -0,0 +1,49 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  XMobar.Environment
+-- Copyright   :  (c) William Song
+-- License     :  BSD-style (see LICENSE)
+--
+-- Maintainer  :  Will Song <incertia@incertia.net>
+-- Stability   :  stable
+-- Portability :  portable
+--
+-- A function to expand environment variables in strings
+--
+-----------------------------------------------------------------------------
+module Xmobar.System.Environment(expandEnv) where
+
+import Control.Applicative  ((<$>))
+import Data.Maybe (fromMaybe)
+import System.Environment   (lookupEnv)
+
+expandEnv :: String -> IO String
+expandEnv "" = return ""
+expandEnv (c:s) = case c of
+  '$'       -> do
+    envVar <- fromMaybe "" <$> lookupEnv e
+    remainder <- expandEnv s'
+    return $ envVar ++ remainder
+    where (e, s') = getVar s
+          getVar "" = ("", "")
+          getVar ('{':s'') = (takeUntil "}" s'', drop 1 . dropUntil "}" $ s'')
+          getVar s'' = (takeUntil filterstr s'', dropUntil filterstr s'')
+          filterstr = ",./? \t;:\"'~`!@#$%^&*()<>-+=\\|"
+          takeUntil f = takeWhile (not . flip elem f)
+          dropUntil f = dropWhile (not . flip elem f)
+
+  '\\' -> case s == "" of
+    True  -> return "\\"
+    False -> do
+      remainder <- expandEnv $ drop 1 s
+      return $ escString s ++ remainder
+      where escString s' = let (cc:_) = s' in
+              case cc of
+                't' -> "\t"
+                'n' -> "\n"
+                '$' -> "$"
+                _   -> [cc]
+
+  _    -> do
+    remainder <- expandEnv s
+    return $ c : remainder
diff --git a/src/Xmobar/System/Kbd.hsc b/src/Xmobar/System/Kbd.hsc
new file mode 100644
index 0000000..b9e1d57
--- /dev/null
+++ b/src/Xmobar/System/Kbd.hsc
@@ -0,0 +1,321 @@
+{-# LANGUAGE ScopedTypeVariables, ForeignFunctionInterface, MultiParamTypeClasses, DeriveDataTypeable, FlexibleInstances, PatternGuards #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Plugins.Kbd
+-- Copyright   :  (c) Martin Perner
+-- License     :  BSD-style (see LICENSE)
+--
+-- Maintainer  :  Martin Perner <martin@perner.cc>
+-- Stability   :  unstable
+-- Portability :  unportable
+--
+-- A keyboard layout indicator for Xmobar
+--
+-----------------------------------------------------------------------------
+
+module Xmobar.System.Kbd where
+
+import Foreign
+import Foreign.C.Types
+import Foreign.C.String
+
+import Graphics.X11.Xlib
+
+#include <X11/XKBlib.h>
+#include <X11/extensions/XKB.h>
+#include <X11/extensions/XKBstr.h>
+
+--
+-- Definition for XkbStaceRec and getKbdLayout taken from
+-- XMonad.Layout.XKBLayout
+--
+data XkbStateRec = XkbStateRec {
+    group :: CUChar,
+    locked_group :: CUChar,
+    base_group :: CUShort,
+    latched_group :: CUShort,
+    mods :: CUChar,
+    base_mods :: CUChar,
+    latched_mods :: CUChar,
+    locked_mods :: CUChar,
+    compat_state :: CUChar,
+    grab_mods :: CUChar,
+    compat_grab_mods :: CUChar,
+    lookup_mods :: CUChar,
+    compat_lookup_mods :: CUChar,
+    ptr_buttons :: CUShort
+}
+
+instance Storable XkbStateRec where
+    sizeOf _ = (#size XkbStateRec)
+    alignment _ = alignment (undefined :: CUShort)
+    poke _ _ = undefined
+    peek ptr = do
+        r_group <- (#peek XkbStateRec, group) ptr
+        r_locked_group <- (#peek XkbStateRec, locked_group) ptr
+        r_base_group <- (#peek XkbStateRec, base_group) ptr
+        r_latched_group <- (#peek XkbStateRec, latched_group) ptr
+        r_mods <- (#peek XkbStateRec, mods) ptr
+        r_base_mods <- (#peek XkbStateRec, base_mods) ptr
+        r_latched_mods <- (#peek XkbStateRec, latched_mods) ptr
+        r_locked_mods <- (#peek XkbStateRec, locked_mods) ptr
+        r_compat_state <- (#peek XkbStateRec, compat_state) ptr
+        r_grab_mods <- (#peek XkbStateRec, grab_mods) ptr
+        r_compat_grab_mods <- (#peek XkbStateRec, compat_grab_mods) ptr
+        r_lookup_mods <- (#peek XkbStateRec, lookup_mods) ptr
+        r_compat_lookup_mods <- (#peek XkbStateRec, compat_lookup_mods) ptr
+        r_ptr_buttons <- (#peek XkbStateRec, ptr_buttons) ptr
+        return XkbStateRec {
+            group = r_group,
+            locked_group = r_locked_group,
+            base_group = r_base_group,
+            latched_group = r_latched_group,
+            mods = r_mods,
+            base_mods = r_base_mods,
+            latched_mods = r_latched_mods,
+            locked_mods = r_locked_mods,
+            compat_state = r_compat_state,
+            grab_mods = r_grab_mods,
+            compat_grab_mods = r_compat_grab_mods,
+            lookup_mods = r_lookup_mods,
+            compat_lookup_mods = r_compat_lookup_mods,
+            ptr_buttons = r_ptr_buttons
+        }
+
+foreign import ccall unsafe "X11/XKBlib.h XkbGetState"
+    xkbGetState :: Display -> CUInt -> Ptr XkbStateRec -> IO CInt
+
+
+getKbdLayout :: Display -> IO Int
+getKbdLayout d = alloca $ \stRecPtr -> do
+    xkbGetState d 0x100 stRecPtr
+    st <- peek stRecPtr
+    return $ fromIntegral (group st)
+
+data XkbKeyNameRec = XkbKeyNameRec {
+    name :: Ptr CChar -- array
+}
+
+--
+-- the t_ before alias is just because of name collisions
+--
+data XkbKeyAliasRec = XkbKeyAliasRec {
+    real  :: Ptr CChar, -- array
+    t_alias :: Ptr CChar  -- array
+}
+
+--
+-- the t_ before geometry is just because of name collisions
+--
+data XkbNamesRec = XkbNamesRec {
+    keycodes :: Atom,
+    t_geometry :: Atom,
+    symbols :: Atom,
+    types :: Atom,
+    compat :: Atom,
+    vmods :: Ptr Atom,
+    indicators :: Ptr Atom, -- array
+    groups :: Ptr Atom, -- array
+    keys :: Ptr XkbKeyNameRec,
+    key_aliases :: Ptr CChar, -- dont care XkbKeyAliasRec,
+    radio_groups :: Ptr Atom,
+    phys_symbols :: Atom,
+    num_keys :: CUChar,
+    num_key_aliases :: CUChar,
+    num_rg :: CUShort
+}
+
+--
+-- the t_ before map, indicators and compat are just because of name collisions
+--
+data XkbDescRec = XkbDescRec {
+    t_dpy :: Ptr CChar, -- struct _XDisplay* ; don't care
+    flags :: CUShort,
+    device_spec :: CUShort,
+    min_key_code :: KeyCode,
+    max_key_code :: KeyCode,
+    ctrls :: Ptr CChar, -- XkbControlsPtr ;  dont' care
+    server :: Ptr CChar, -- XkbServerMapPtr ;  dont' care
+    t_map :: Ptr CChar, --XkbClientMapPtr ;  dont' care
+    t_indicators :: Ptr CChar, -- XkbIndicatorPtr ;  dont' care
+    names :: Ptr XkbNamesRec, -- array
+    t_compat :: Ptr CChar, -- XkbCompatMap ;  dont' care
+    geom :: Ptr CChar -- XkbGeometryPtr ;  dont' care
+
+}
+
+instance Storable XkbKeyNameRec where
+    sizeOf _ = (#size XkbKeyNameRec)
+    alignment _ = alignment (undefined :: CUShort)
+    poke _ _ = undefined
+    peek ptr = do
+        r_name <- (#peek XkbKeyNameRec, name) ptr
+
+        return XkbKeyNameRec {
+            name = r_name
+        }
+
+instance Storable XkbKeyAliasRec where
+    sizeOf _ = (#size XkbKeyAliasRec)
+    alignment _ = alignment (undefined :: CUShort)
+    poke _ _ = undefined
+    peek ptr = do
+        r_real <- (#peek XkbKeyAliasRec, real) ptr
+        r_alias <- (#peek XkbKeyAliasRec, alias) ptr
+
+        return XkbKeyAliasRec {
+            real = r_real,
+            t_alias = r_alias
+        }
+
+instance Storable XkbNamesRec where
+    sizeOf _ = (#size XkbNamesRec)
+    alignment _ = alignment (undefined :: CUShort)
+    poke _ _ = undefined
+    peek ptr = do
+        r_keycodes <- (#peek XkbNamesRec, keycodes) ptr
+        r_geometry <- (#peek XkbNamesRec, geometry) ptr
+        r_symbols <- (#peek XkbNamesRec, symbols ) ptr
+        r_types <- (#peek XkbNamesRec, types ) ptr
+        r_compat <- (#peek XkbNamesRec, compat ) ptr
+        r_vmods <- (#peek XkbNamesRec,  vmods ) ptr
+        r_indicators <- (#peek XkbNamesRec, indicators ) ptr
+        r_groups <- (#peek XkbNamesRec, groups ) ptr
+        r_keys <- (#peek XkbNamesRec, keys ) ptr
+        r_key_aliases <- (#peek XkbNamesRec, key_aliases  ) ptr
+        r_radio_groups <- (#peek XkbNamesRec, radio_groups  ) ptr
+        r_phys_symbols <- (#peek XkbNamesRec, phys_symbols ) ptr
+        r_num_keys <- (#peek XkbNamesRec,num_keys  ) ptr
+        r_num_key_aliases <- (#peek XkbNamesRec, num_key_aliases  ) ptr
+        r_num_rg <- (#peek XkbNamesRec, num_rg ) ptr
+
+        return XkbNamesRec {
+            keycodes = r_keycodes,
+            t_geometry = r_geometry,
+            symbols = r_symbols,
+            types = r_types,
+            compat = r_compat,
+            vmods = r_vmods,
+            indicators = r_indicators,
+            groups = r_groups,
+            keys = r_keys,
+            key_aliases = r_key_aliases,
+            radio_groups = r_radio_groups,
+            phys_symbols = r_phys_symbols,
+            num_keys = r_num_keys,
+            num_key_aliases = r_num_key_aliases,
+            num_rg = r_num_rg
+       }
+
+instance Storable XkbDescRec where
+    sizeOf _ = (#size XkbDescRec)
+    alignment _ = alignment (undefined :: CUShort)
+    poke _ _ = undefined
+    peek ptr = do
+        r_dpy <- (#peek XkbDescRec, dpy) ptr
+        r_flags <- (#peek XkbDescRec, flags) ptr
+        r_device_spec <- (#peek XkbDescRec, device_spec) ptr
+        r_min_key_code <- (#peek XkbDescRec, min_key_code) ptr
+        r_max_key_code <- (#peek XkbDescRec, max_key_code) ptr
+        r_ctrls <- (#peek XkbDescRec, ctrls) ptr
+        r_server <- (#peek XkbDescRec, server) ptr
+        r_map <- (#peek XkbDescRec, map) ptr
+        r_indicators <- (#peek XkbDescRec, indicators) ptr
+        r_names <- (#peek XkbDescRec, names) ptr
+        r_compat <- (#peek XkbDescRec, compat) ptr
+        r_geom <- (#peek XkbDescRec, geom) ptr
+
+        return XkbDescRec {
+            t_dpy = r_dpy,
+            flags = r_flags,
+            device_spec = r_device_spec,
+            min_key_code = r_min_key_code,
+            max_key_code = r_max_key_code,
+            ctrls = r_ctrls,
+            server = r_server,
+            t_map = r_map,
+            t_indicators = r_indicators,
+            names = r_names,
+            t_compat = r_compat,
+            geom = r_geom
+        }
+
+--
+-- C bindings
+--
+
+foreign import ccall unsafe "X11/XKBlib.h XkbAllocKeyboard"
+    xkbAllocKeyboard :: IO (Ptr XkbDescRec)
+
+foreign import ccall unsafe "X11/XKBlib.h XkbGetNames"
+    xkbGetNames :: Display -> CUInt -> (Ptr XkbDescRec)  -> IO Status
+
+foreign import ccall unsafe "X11/XKBlib.h XGetAtomName"
+    xGetAtomName :: Display -> Atom -> IO CString
+
+foreign import ccall unsafe "X11/XKBlib.h XkbFreeNames"
+    xkbFreeNames :: (Ptr XkbDescRec) -> CUInt -> CInt -> IO ()
+
+foreign import ccall unsafe "X11/XKBlib.h XkbFreeKeyboard"
+    xkbFreeKeyboard :: (Ptr XkbDescRec) -> CUInt -> CInt -> IO ()
+
+foreign import ccall unsafe "X11/XKBlib.h XkbSelectEventDetails"
+    xkbSelectEventDetails :: Display -> CUInt -> CUInt -> CULong -> CULong -> IO CUInt
+
+foreign import ccall unsafe "X11/XKBlib.h XkbSelectEvents"
+    xkbSelectEvents :: Display -> CUInt -> CUInt -> CUInt -> IO CUInt
+
+
+xkbUseCoreKbd :: CUInt
+xkbUseCoreKbd = #const XkbUseCoreKbd
+
+xkbStateNotify :: CUInt
+xkbStateNotify = #const XkbStateNotify
+
+xkbIndicatorStateNotify :: CUInt
+xkbIndicatorStateNotify = #const XkbIndicatorStateNotify
+
+xkbMapNotify :: CUInt
+xkbMapNotify = #const XkbMapNotify
+
+xkbMapNotifyMask :: CUInt
+xkbMapNotifyMask = #const XkbMapNotifyMask
+
+xkbNewKeyboardNotifyMask :: CUInt
+xkbNewKeyboardNotifyMask  = #const XkbNewKeyboardNotifyMask
+
+xkbAllStateComponentsMask :: CULong
+xkbAllStateComponentsMask = #const XkbAllStateComponentsMask
+
+xkbGroupStateMask :: CULong
+xkbGroupStateMask = #const XkbGroupStateMask
+
+xkbSymbolsNameMask :: CUInt
+xkbSymbolsNameMask = #const XkbSymbolsNameMask
+
+xkbGroupNamesMask :: CUInt
+xkbGroupNamesMask = #const XkbGroupNamesMask
+
+type KbdOpts = [(String, String)]
+
+getLayoutStr :: Display -> IO String
+getLayoutStr dpy =  do
+        kbdDescPtr <- xkbAllocKeyboard
+        status <- xkbGetNames dpy xkbSymbolsNameMask kbdDescPtr
+        str <- getLayoutStr' status dpy kbdDescPtr
+        xkbFreeNames kbdDescPtr xkbGroupNamesMask 1
+        xkbFreeKeyboard kbdDescPtr 0 1
+        return str
+
+getLayoutStr' :: Status -> Display -> (Ptr XkbDescRec) -> IO String
+getLayoutStr' st dpy kbdDescPtr =
+        if st == 0 then -- Success
+            do
+            kbdDesc <- peek kbdDescPtr
+            nameArray <- peek (names kbdDesc)
+            atom <- xGetAtomName dpy (symbols nameArray)
+            str <- peekCString atom
+            return str
+        else -- Behaviour on error
+            do
+                return "Error while requesting layout!"
diff --git a/src/Xmobar/System/Localize.hsc b/src/Xmobar/System/Localize.hsc
new file mode 100644
index 0000000..eec5e3b
--- /dev/null
+++ b/src/Xmobar/System/Localize.hsc
@@ -0,0 +1,89 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Localize
+-- Copyright   :  (C) 2011, 2018 Martin Perner
+-- License     :  BSD-style (see LICENSE)
+--
+-- Maintainer  :  Martin Perner <martin@perner.cc>
+-- Stability   :  unstable
+-- Portability :  unportable
+--
+-- This module provides an interface to locale information e.g. for DateL
+--
+-----------------------------------------------------------------------------
+
+module Xmobar.System.Localize
+    ( setupTimeLocale,
+      getTimeLocale
+    ) where
+
+import Foreign.C
+#if ! MIN_VERSION_time(1,5,0)
+import qualified System.Locale as L
+#else
+import qualified Data.Time.Format as L
+#endif
+
+#ifdef UTF8
+import Codec.Binary.UTF8.String
+#endif
+
+--  get localized strings
+type NlItem = CInt
+
+#include <langinfo.h>
+foreign import ccall unsafe "langinfo.h nl_langinfo"
+  nl_langinfo :: NlItem -> IO CString
+
+#{enum NlItem,
+  , AM_STR , PM_STR \
+  , D_T_FMT , D_FMT , T_FMT , T_FMT_AMPM \
+  , ABDAY_1, ABDAY_7 \
+  , DAY_1, DAY_7 \
+  , ABMON_1, ABMON_12 \
+  , MON_1, MON_12\
+ }
+
+getLangInfo :: NlItem -> IO String
+getLangInfo item = do
+  itemStr <- nl_langinfo item
+#ifdef UTF8
+  str <- peekCString itemStr
+  return $ if isUTF8Encoded str then decodeString str else str
+#else
+  peekCString itemStr
+#endif
+
+#include <locale.h>
+foreign import ccall unsafe "locale.h setlocale"
+    setlocale :: CInt -> CString -> IO CString
+
+setupTimeLocale :: String -> IO ()
+setupTimeLocale l = withCString l (setlocale #const LC_TIME) >> return ()
+
+getTimeLocale :: IO L.TimeLocale
+getTimeLocale = do
+  -- assumes that the defined values are increasing by exactly one.
+  -- as they are defined consecutive in an enum this is reasonable
+  days   <- mapM getLangInfo [day1 .. day7]
+  abdays <- mapM getLangInfo [abday1 .. abday7]
+
+  mons   <- mapM getLangInfo [mon1 .. mon12]
+  abmons <- mapM getLangInfo [abmon1 .. abmon12]
+
+  amstr <- getLangInfo amStr
+  pmstr <- getLangInfo pmStr
+  dtfmt <- getLangInfo dTFmt
+  dfmt  <- getLangInfo dFmt
+  tfmt  <- getLangInfo tFmt
+  tfmta <- getLangInfo tFmtAmpm
+
+  let t =  L.defaultTimeLocale {L.wDays  = zip days abdays
+                               ,L.months = zip mons abmons
+                               ,L.amPm = (amstr, pmstr)
+                               ,L.dateTimeFmt = dtfmt
+                               ,L.dateFmt = dfmt
+                               ,L.timeFmt = tfmt
+                               ,L.time12Fmt = tfmta}
+  return t
diff --git a/src/Xmobar/System/Signal.hs b/src/Xmobar/System/Signal.hs
new file mode 100644
index 0000000..ce39e10
--- /dev/null
+++ b/src/Xmobar/System/Signal.hs
@@ -0,0 +1,134 @@
+{-# LANGUAGE DeriveDataTypeable, CPP #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Signal
+-- Copyright   :  (c) Andrea Rosatto
+--             :  (c) Jose A. Ortega Ruiz
+--             :  (c) Jochen Keil
+-- License     :  BSD-style (see LICENSE)
+--
+-- Maintainer  :  Jose A. Ortega Ruiz <jao@gnu.org>
+-- Stability   :  unstable
+-- Portability :  unportable
+--
+-- Signal handling, including DBUS when available
+--
+-----------------------------------------------------------------------------
+
+module Xmobar.System.Signal where
+
+import Data.Foldable (for_)
+import Data.Typeable (Typeable)
+import Control.Concurrent
+import Control.Concurrent.STM
+import Control.Exception
+import System.Posix.Signals
+import Graphics.X11.Types (Button)
+import Graphics.X11.Xlib.Types (Position)
+import System.IO
+
+#ifdef DBUS
+import DBus (IsVariant(..))
+import Control.Monad ((>=>))
+#endif
+
+safeHead :: [a] -> Maybe a
+safeHead    [] = Nothing
+safeHead (x:_) = Just x
+
+data WakeUp = WakeUp deriving (Show,Typeable)
+instance Exception WakeUp
+
+data SignalType = Wakeup
+                | Reposition
+                | ChangeScreen
+                | Hide   Int
+                | Reveal Int
+                | Toggle Int
+                | TogglePersistent
+                | Action Button Position
+    deriving (Read, Show)
+
+#ifdef DBUS
+instance IsVariant SignalType where
+    toVariant   = toVariant . show
+    fromVariant = fromVariant >=> parseSignalType
+#endif
+
+parseSignalType :: String -> Maybe SignalType
+parseSignalType = fmap fst . safeHead . reads
+
+-- | Signal handling
+setupSignalHandler :: IO (TMVar SignalType)
+setupSignalHandler = do
+   tid   <- newEmptyTMVarIO
+   installHandler sigUSR2 (Catch $ updatePosHandler tid) Nothing
+   installHandler sigUSR1 (Catch $ changeScreenHandler tid) Nothing
+   return tid
+
+updatePosHandler :: TMVar SignalType -> IO ()
+updatePosHandler sig = do
+   atomically $ putTMVar sig Reposition
+   return ()
+
+changeScreenHandler :: TMVar SignalType -> IO ()
+changeScreenHandler sig = do
+   atomically $ putTMVar sig ChangeScreen
+   return ()
+
+
+-- | Ensures that the given IO action runs its cleanup actions ('bracket' etc.),
+-- even if a signal is caught.
+--
+-- An exception will be thrown on the thread that called this function when a
+-- signal is caught.
+withDeferSignals :: IO a -> IO a
+withDeferSignals thing = do
+  threadId <- myThreadId
+  caughtSignal <- newEmptyMVar
+
+  let signals =
+        filter (not . flip inSignalSet reservedSignals)
+          [ sigQUIT
+          , sigTERM
+          --, sigINT -- Handler already installed by GHC
+          --, sigPIPE -- Handler already installed by GHC
+          --, sigUSR1 -- Handled by setupSignalHandler
+          --, sigUSR2 -- Handled by setupSignalHandler
+
+          -- One of the following appears to cause instability, see #360
+          --, sigHUP
+          --, sigILL
+          --, sigABRT
+          --, sigFPE
+          --, sigSEGV
+          --, sigALRM
+          --, sigBUS
+          --, sigPOLL
+          --, sigPROF
+          --, sigSYS
+          --, sigTRAP
+          --, sigVTALRM
+          --, sigXCPU
+          --, sigXFSZ
+          ]
+
+  for_ signals $ \s ->
+
+      installHandler s
+        (Catch $ do
+          tryPutMVar caughtSignal s
+          hPutStrLn stderr ("xmobar: Caught signal "++show s++"; exiting...")
+          throwTo threadId ThreadKilled)
+        Nothing
+
+  thing `finally` do
+        s0 <- tryReadMVar caughtSignal
+        case s0 of
+          Nothing -> pure ()
+          Just s -> do
+            -- Run the default handler for the signal
+            -- hPutStrLn stderr ("xmobar: Running default handler for signal "++show s)
+            installHandler s Default Nothing
+            raiseSignal s
diff --git a/src/Xmobar/System/StatFS.hsc b/src/Xmobar/System/StatFS.hsc
new file mode 100644
index 0000000..529b16a
--- /dev/null
+++ b/src/Xmobar/System/StatFS.hsc
@@ -0,0 +1,83 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  StatFS
+-- Copyright   :  (c) Jose A Ortega Ruiz
+-- License     :  BSD-style (see LICENSE)
+--
+-- Maintainer  :  Jose A Ortega Ruiz <jao@gnu.org>
+-- Stability   :  unstable
+-- Portability :  unportable
+--
+--  A binding to C's statvfs(2)
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE CPP, ForeignFunctionInterface, EmptyDataDecls #-}
+
+
+module Xmobar.System.StatFS ( FileSystemStats(..), getFileSystemStats ) where
+
+import Foreign
+import Foreign.C.Types
+import Foreign.C.String
+import Data.ByteString (useAsCString)
+import Data.ByteString.Char8 (pack)
+
+#if  defined (__FreeBSD__) || defined (__OpenBSD__) ||  defined (__APPLE__) || defined (__DragonFly__)
+#define IS_BSD_SYSTEM
+#endif
+
+#ifdef IS_BSD_SYSTEM
+# include <sys/param.h>
+# include <sys/mount.h>
+#else
+# include <sys/vfs.h>
+#endif
+
+data FileSystemStats = FileSystemStats {
+  fsStatBlockSize :: Integer
+  -- ^ Optimal transfer block size.
+  , fsStatBlockCount :: Integer
+  -- ^ Total data blocks in file system.
+  , fsStatByteCount :: Integer
+  -- ^ Total bytes in file system.
+  , fsStatBytesFree :: Integer
+  -- ^ Free bytes in file system.
+  , fsStatBytesAvailable :: Integer
+  -- ^ Free bytes available to non-superusers.
+  , fsStatBytesUsed :: Integer
+  -- ^ Bytes used.
+  } deriving (Show, Eq)
+
+data CStatfs
+
+#ifdef IS_BSD_SYSTEM
+foreign import ccall unsafe "sys/mount.h statfs"
+#else
+foreign import ccall unsafe "sys/vfs.h statvfs"
+#endif
+  c_statfs :: CString -> Ptr CStatfs -> IO CInt
+
+toI :: CULong -> Integer
+toI = toInteger
+
+getFileSystemStats :: String -> IO (Maybe FileSystemStats)
+getFileSystemStats path =
+  allocaBytes (#size struct statfs) $ \vfs ->
+  useAsCString (pack path) $ \cpath -> do
+    res <- c_statfs cpath vfs
+    if res /= 0 then return Nothing
+      else do
+        bsize <- (#peek struct statfs, f_bsize) vfs
+        bcount <- (#peek struct statfs, f_blocks) vfs
+        bfree <- (#peek struct statfs, f_bfree) vfs
+        bavail <- (#peek struct statfs, f_bavail) vfs
+        let bpb = toI bsize
+        return $ Just FileSystemStats
+                       { fsStatBlockSize = bpb
+                       , fsStatBlockCount = toI bcount
+                       , fsStatByteCount = toI bcount * bpb
+                       , fsStatBytesFree = toI bfree * bpb
+                       , fsStatBytesAvailable = toI bavail * bpb
+                       , fsStatBytesUsed = toI (bcount - bfree) * bpb
+                       }