Use X.U.ExtensibleState instead of IORefs

This patch changes SpawnOn, DynamicHooks and UrgencyHooks to
use X.U.ExtensibleState instead of IORefs. This simplifies the
usage of those modules thus also breaking current configs.

XMonad/Actions/SpawnOn.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveDataTypeable #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module       : XMonad.Actions.SpawnOn
@@ -18,7 +19,6 @@ module XMonad.Actions.SpawnOn (
     -- * Usage
     -- $usage
     Spawner,
-    mkSpawner,
     manageSpawn,
     spawnHere,
     spawnOn,
@@ -28,7 +28,6 @@ module XMonad.Actions.SpawnOn (
 ) where
 
 import Data.List (isInfixOf)
-import Data.IORef
 import System.Posix.Types (ProcessID)
 
 import XMonad
@@ -37,6 +36,7 @@ import qualified XMonad.StackSet as W
 import XMonad.Hooks.ManageHelpers
 import XMonad.Prompt
 import XMonad.Prompt.Shell
+import XMonad.Util.ExtensibleState
 
 -- $usage
 -- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:
@@ -44,17 +44,16 @@ import XMonad.Prompt.Shell
 -- >    import XMonad.Actions.SpawnOn
 --
 -- >    main = do
--- >      sp <- mkSpawner
 -- >      xmonad defaultConfig {
 -- >         ...
--- >         manageHook = manageSpawn sp <+> manageHook defaultConfig
+-- >         manageHook = manageSpawn <+> manageHook defaultConfig
 -- >         ...
 -- >      }
 --
 -- To ensure that application appears on a workspace it was launched at, add keybindings like:
 --
--- >  , ((mod1Mask,xK_o), spawnHere sp "urxvt")
--- >  , ((mod1Mask,xK_s), shellPromptHere sp defaultXPConfig)
+-- >  , ((mod1Mask,xK_o), spawnHere "urxvt")
+-- >  , ((mod1Mask,xK_s), shellPromptHere defaultXPConfig)
 --
 -- The module can also be used to apply other manage hooks to the window of
 -- the spawned application(e.g. float or resize it).
@@ -62,26 +61,29 @@ import XMonad.Prompt.Shell
 -- For detailed instructions on editing your key bindings, see
 -- "XMonad.Doc.Extending#Editing_key_bindings".
 
-newtype Spawner = Spawner {pidsRef :: IORef [(ProcessID, ManageHook)]}
+newtype Spawner = Spawner {pidsRef :: [(ProcessID, ManageHook)]} deriving Typeable
+
+instance ExtensionClass Spawner where
+    initialValue = Spawner []
 
 maxPids :: Int
 maxPids = 5
 
--- | Create 'Spawner' which then has to be passed to other functions.
-mkSpawner :: (Functor m, MonadIO m) => m Spawner
-mkSpawner = io . fmap Spawner $ newIORef []
+-- | Get the current Spawner or create one if it doesn't exist.
+modifySpawner :: ([(ProcessID, ManageHook)] -> [(ProcessID, ManageHook)]) -> X ()
+modifySpawner f = putState . Spawner . f . pidsRef =<< getState
 
 -- | Provides a manage hook to react on process spawned with
 -- 'spawnOn', 'spawnHere' etc.
-manageSpawn :: Spawner -> ManageHook
-manageSpawn sp = do
-    pids <- io . readIORef $ pidsRef sp
+manageSpawn :: ManageHook
+manageSpawn = do
+    Spawner pids <- liftX getState
     mp <- pid
     case flip lookup pids =<< mp of
-        Nothing -> doF id
+        Nothing -> idHook
         Just mh  -> do
             whenJust mp $ \p ->
-                io . modifyIORef (pidsRef sp) $ filter ((/= p) . fst)
+                liftX . modifySpawner $ filter ((/= p) . fst)
             mh
 
 mkPrompt :: (String -> X ()) -> XPConfig -> X ()
@@ -91,32 +93,31 @@ mkPrompt cb c = do
 
 -- | Replacement for Shell prompt ("XMonad.Prompt.Shell") which launches
 -- application on current workspace.
-shellPromptHere :: Spawner -> XPConfig -> X ()
-shellPromptHere sp = mkPrompt (spawnHere sp)
+shellPromptHere :: XPConfig -> X ()
+shellPromptHere = mkPrompt spawnHere
 
 -- | Replacement for Shell prompt ("XMonad.Prompt.Shell") which launches
 -- application on given workspace.
-shellPromptOn :: Spawner -> WorkspaceId -> XPConfig -> X ()
-shellPromptOn sp ws = mkPrompt (spawnOn sp ws)
+shellPromptOn :: WorkspaceId -> XPConfig -> X ()
+shellPromptOn ws = mkPrompt (spawnOn ws)
 
 -- | Replacement for 'spawn' which launches
 -- application on current workspace.
-spawnHere :: Spawner -> String -> X ()
-spawnHere sp cmd = withWindowSet $ \ws -> spawnOn sp (W.currentTag ws) cmd
+spawnHere :: String -> X ()
+spawnHere cmd = withWindowSet $ \ws -> spawnOn (W.currentTag ws) cmd
 
 -- | Replacement for 'spawn' which launches
 -- application on given workspace.
-spawnOn :: Spawner -> WorkspaceId -> String -> X ()
-spawnOn sp ws cmd = spawnAndDo sp (doShift ws) cmd
+spawnOn :: WorkspaceId -> String -> X ()
+spawnOn ws cmd = spawnAndDo (doShift ws) cmd
 
 -- | Spawn an application and apply the manage hook when it opens.
-spawnAndDo :: Spawner -> ManageHook -> String -> X ()
-spawnAndDo sp mh cmd = do
+spawnAndDo :: ManageHook -> String -> X ()
+spawnAndDo mh cmd = do
     p <- spawnPID $ mangle cmd
-    io $ modifyIORef (pidsRef sp) (take maxPids . ((p,mh) :))
+    modifySpawner $ (take maxPids . ((p,mh) :))
  where
     -- TODO this is silly, search for a better solution
     mangle xs | any (`elem` metaChars) xs || "exec" `isInfixOf` xs = xs
               | otherwise = "exec " ++ xs
     metaChars = "&|;"
-

XMonad/Config/Sjanssen.hs

@@ -21,7 +21,7 @@ import XMonad.Layout.TwoPane
 import qualified Data.Map as M
 
 sjanssenConfig = do
-    sp <- mkSpawner :: IO Spawner
+    sp <- mkSpawner
     return . ewmh $ defaultConfig
         { terminal = "exec urxvt"
         , workspaces = ["irc", "web"] ++ map show [3 .. 9 :: Int]
@@ -30,13 +30,12 @@ sjanssenConfig = do
                 , ((modm, button2), (\w -> focus w >> windows W.swapMaster))
                 , ((modm.|. shiftMask, button1), (\w -> focus w >> mouseResizeWindow w)) ]
         , keys = \c -> mykeys sp c `M.union` keys defaultConfig c
-        , logHook = dynamicLogString sjanssenPP >>= xmonadPropLog
         , layoutHook  = modifiers layouts
         , manageHook  = composeAll [className =? x --> doShift w
                                     | (x, w) <- [ ("Firefox", "web")
                                                 , ("Ktorrent", "7")
                                                 , ("Amarokapp", "7")]]
-                        <+> manageHook defaultConfig <+> manageDocks <+> manageSpawn sp
+                        <+> manageHook defaultConfig <+> manageDocks <+> manageSpawn
                         <+> (isFullscreen --> doFullFloat)
         }
  where
@@ -44,9 +43,9 @@ sjanssenConfig = do
     layouts   = (tiled Tall ||| (tiled Wide ||| Full)) ||| tabbed shrinkText myTheme
     modifiers = avoidStruts . smartBorders
 
-    mykeys sp (XConfig {modMask = modm}) = M.fromList $
-        [((modm,               xK_p     ), shellPromptHere sp myPromptConfig)
-        ,((modm .|. shiftMask, xK_Return), spawnHere sp =<< asks (terminal . config))
+    mykeys (XConfig {modMask = modm}) = M.fromList $
+        [((modm,               xK_p     ), shellPromptHere myPromptConfig)
+        ,((modm .|. shiftMask, xK_Return), spawnHere =<< asks (terminal . config))
         ,((modm .|. shiftMask, xK_c     ), kill1)
         ,((modm .|. shiftMask .|. controlMask, xK_c     ), kill)
         ,((modm .|. shiftMask, xK_0     ), windows $ copyToAll)

XMonad/Hooks/DynamicHooks.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveDataTypeable #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  XMonad.Hooks.DynamicHooks
@@ -15,20 +16,18 @@
 module XMonad.Hooks.DynamicHooks (
   -- * Usage
   -- $usage
-  initDynamicHooks
-  ,dynamicMasterHook
+  dynamicMasterHook
   ,addDynamicHook
   ,updateDynamicHook
   ,oneShotHook
   ) where
 
 import XMonad
-import System.IO
+import XMonad.Util.ExtensibleState
 
 import Data.List
 import Data.Maybe (listToMaybe)
 import Data.Monoid
-import Data.IORef
 
 -- $usage
 -- Provides two new kinds of 'ManageHooks' that can be defined at runtime.
@@ -40,68 +39,46 @@ import Data.IORef
 -- Note that you will lose all dynamically defined 'ManageHook's when you @mod+q@!
 -- If you want them to last, you should create them as normal in your @xmonad.hs@.
 --
--- First, you must execute 'initDynamicHooks' from 'main' in your @xmonad.hs@:
+-- To use this module, add 'dynamicMasterHook' to your 'manageHook':
 --
--- > dynHooksRef <- initDynamicHooks
+-- > xmonad { manageHook = myManageHook <+> dynamicMasterHook }
 --
--- and then pass this value to the other functions in this module.
+-- You can then use the supplied functions in your keybindings:
 --
--- You also need to add the base 'ManageHook':
---
--- > xmonad { manageHook = myManageHook <+> dynamicMasterHook dynHooksRef }
---
--- You must include this @dynHooksRef@ value when using the functions in this
--- module:
---
--- > xmonad { keys = myKeys `Data.Map.union` Data.Map.fromList
--- >                   [((modm, xK_i), oneShotHook dynHooksRef
--- >                    "FFlaunchHook" (className =? "firefox") (doShift "3")
--- >                    >> spawn "firefox")
--- >                   ,((modm, xK_u), addDynamicHook dynHooksRef
--- >                     (className =? "example" --> doFloat))
--- >                   ,((modm, xK_y), updatePermanentHook dynHooksRef
--- >                     (const idHook))) ]  -- resets the permanent hook.
+-- > ((modMask,xK_a), oneShotHook (className =? "example") doFloat)
 --
 
 data DynamicHooks = DynamicHooks
     { transients :: [(Query Bool, ManageHook)]
     , permanent  :: ManageHook }
+                    deriving Typeable
 
+instance ExtensionClass DynamicHooks where
+    initialValue = DynamicHooks [] idHook
 
--- | Creates the 'IORef' that stores the dynamically created 'ManageHook's.
-initDynamicHooks :: IO (IORef DynamicHooks)
-initDynamicHooks = newIORef (DynamicHooks { transients = [],
-                                            permanent = idHook })
-
-
--- this hook is always executed, and the IORef's contents checked.
+-- this hook is always executed, and the contents of the stored hooks checked.
 -- note that transient hooks are run second, therefore taking precedence
 -- over permanent ones on matters such as which workspace to shift to.
 -- doFloat and doIgnore are idempotent.
 -- | Master 'ManageHook' that must be in your @xmonad.hs@ 'ManageHook'.
-dynamicMasterHook :: IORef DynamicHooks -> ManageHook
-dynamicMasterHook ref = return True -->
-                  (ask >>= \w -> liftX (do
-  dh <- io $ readIORef ref
+dynamicMasterHook :: ManageHook
+dynamicMasterHook = (ask >>= \w -> liftX (do
+  dh <- getState
   (Endo f)  <- runQuery (permanent dh) w
   ts <- mapM (\(q,a) -> runQuery q w >>= \x -> return (x,(q, a))) (transients dh)
   let (ts',nts) = partition fst ts
   gs <- mapM (flip runQuery w . snd . snd) ts'
   let (Endo g) = maybe (Endo id) id $ listToMaybe gs
-  io $ writeIORef ref $ dh { transients = map snd nts }
+  putState $ dh { transients = map snd nts }
   return $ Endo $ f . g
                                        ))
-
 -- | Appends the given 'ManageHook' to the permanent dynamic 'ManageHook'.
-addDynamicHook :: IORef DynamicHooks -> ManageHook -> X ()
-addDynamicHook ref m = updateDynamicHook ref (<+> m)
-
+addDynamicHook :: ManageHook -> X ()
+addDynamicHook m = updateDynamicHook (<+> m)
 
 -- | Modifies the permanent 'ManageHook' with an arbitrary function.
-updateDynamicHook :: IORef DynamicHooks -> (ManageHook -> ManageHook) -> X ()
-updateDynamicHook ref f =
-    io $ modifyIORef ref $ \dh -> dh { permanent = f (permanent dh) }
-
+updateDynamicHook :: (ManageHook -> ManageHook) -> X ()
+updateDynamicHook f = modifyState $ \dh -> dh { permanent = f (permanent dh) }
 
 -- | Creates a one-shot 'ManageHook'. Note that you have to specify the two
 -- parts of the 'ManageHook' separately. Where you would usually write:
@@ -112,11 +89,5 @@ updateDynamicHook ref f =
 --
 -- > oneShotHook dynHooksRef (className =? "example) doFloat
 --
-oneShotHook :: IORef DynamicHooks -> Query Bool -> ManageHook -> X ()
-oneShotHook ref q a =
-  io $ modifyIORef ref
-         $ \dh -> dh { transients = (q,a):(transients dh) }
-
-
-
-
+oneShotHook :: Query Bool -> ManageHook -> X ()
+oneShotHook q a = modifyState $ \dh -> dh { transients = (q,a):(transients dh) }

XMonad/Hooks/UrgencyHook.hs

@@ -1,4 +1,5 @@
-{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, TypeSynonymInstances, PatternGuards #-}
+{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, TypeSynonymInstances, PatternGuards, DeriveDataTypeable,
+  FlexibleInstances #-}
 
 -----------------------------------------------------------------------------
 -- |
@@ -71,17 +72,16 @@ import XMonad
 import qualified XMonad.StackSet as W
 
 import XMonad.Util.Dzen (dzenWithArgs, seconds)
+import XMonad.Util.ExtensibleState
 import XMonad.Util.NamedWindows (getName)
 import XMonad.Util.Timer (TimerId, startTimer, handleTimer)
 
 import Control.Applicative ((<$>))
 import Control.Monad (when)
 import Data.Bits (testBit)
-import Data.IORef
 import Data.List (delete)
 import Data.Maybe (listToMaybe, maybeToList)
 import qualified Data.Set as S
-import Foreign (unsafePerformIO)
 
 -- $usage
 --
@@ -213,6 +213,15 @@ withUrgencyHookC hook urgConf conf = conf {
         logHook = cleanupUrgents (suppressWhen urgConf) >> logHook conf
     }
 
+data Urgents = Urgents { fromUrgents :: [Window] } deriving (Read,Show,Typeable)
+
+onUrgents :: ([Window] -> [Window]) -> Urgents -> Urgents
+onUrgents f = Urgents . f . fromUrgents
+
+instance ExtensionClass Urgents where
+    initialValue = Urgents []
+    extensionType = PersistentExtension
+
 -- | Global configuration, applied to all types of 'UrgencyHook'. See
 -- 'urgencyConfig' for the defaults.
 data UrgencyConfig = UrgencyConfig
@@ -262,25 +271,18 @@ focusUrgent = withUrgents $ flip whenJust (windows . W.focusWindow) . listToMayb
 clearUrgents :: X ()
 clearUrgents = adjustUrgents (const []) >> adjustReminders (const [])
 
--- | Stores the global set of all urgent windows, across workspaces. Not exported -- use
--- 'readUrgents' or 'withUrgents' instead.
-{-# NOINLINE urgents #-}
-urgents :: IORef [Window]
-urgents = unsafePerformIO (newIORef [])
--- (Hey, I don't like it any more than you do.)
-
 -- | X action that returns a list of currently urgent windows. You might use
 -- it, or 'withUrgents', in your custom logHook, to display the workspaces that
 -- contain urgent windows.
 readUrgents :: X [Window]
-readUrgents = io $ readIORef urgents
+readUrgents = fromUrgents <$> getState
 
 -- | An HOF version of 'readUrgents', for those who prefer that sort of thing.
 withUrgents :: ([Window] -> X a) -> X a
 withUrgents f = readUrgents >>= f
 
 adjustUrgents :: ([Window] -> [Window]) -> X ()
-adjustUrgents f = io $ modifyIORef urgents f
+adjustUrgents f = modifyState $ onUrgents f
 
 type Interval = Rational
 
@@ -290,18 +292,19 @@ data Reminder = Reminder { timer     :: TimerId
                          , window    :: Window
                          , interval  :: Interval
                          , remaining :: Maybe Int
-                         } deriving Eq
+                         } deriving (Show,Read,Eq,Typeable)
+
+instance ExtensionClass [Reminder] where
+    initialValue = []
+    extensionType = PersistentExtension
 
 -- | Stores the list of urgency reminders.
-{-# NOINLINE reminders #-}
-reminders :: IORef [Reminder]
-reminders = unsafePerformIO (newIORef [])
 
 readReminders :: X [Reminder]
-readReminders = io $ readIORef reminders
+readReminders = getState
 
 adjustReminders :: ([Reminder] -> [Reminder]) -> X ()
-adjustReminders f = io $ modifyIORef reminders f
+adjustReminders f = modifyState f
 
 clearUrgency :: Window -> X ()
 clearUrgency w = adjustUrgents (delete w) >> adjustReminders (filter $ (w /=) . window)
@@ -332,7 +335,7 @@ handleEvent wuh event =
                   callUrgencyHook wuh w
                 else
                   clearUrgency w
-              userCodeDef () =<< asks (logHook . config) -- call *after* IORef has been modified
+              userCodeDef () =<< asks (logHook . config)
       DestroyWindowEvent {ev_window = w} ->
           clearUrgency w
       _ ->