amend! X.U.ExtensibleConf: Add high-level idioms for non-Semigroup types

X.U.ExtensibleConf: Add high-level idioms for non-Semigroup, but Default types

For configuration values that don't compose well using a Semigroup
instance, provide a high-level API allowing arbitrary modification of
the value, taking its Default if absent. This API is only usable for
separate configuration data and cannot be used to guard addition of hook
using `once`.

XMonad/Util/ExtensibleConf.hs

@@ -21,29 +21,29 @@ module XMonad.Util.ExtensibleConf (
     -- * Usage
     -- $usage
 
-    -- * High-level idioms
+    -- * High-level idioms based on Semigroup
     with,
-    withDef,
     add,
     once,
     onceM,
-    modify,
+
+    -- * High-level idioms based on Default
+    withDef,
     modifyDef,
-    onceIni,
-    onceIniM,
+    modifyDefM,
 
     -- * Low-level primitivies
     ask,
     lookup,
     alter,
+    alterF,
     ) where
 
 import Prelude hiding (lookup)
 import XMonad hiding (ask, modify, trace)
-import XMonad.Prelude ((<|>), fromMaybe)
+import XMonad.Prelude ((<|>), (<&>), fromMaybe)
 
 import Data.Typeable
-import Debug.Trace
 import qualified Data.Map as M
 
 
@@ -92,27 +92,35 @@ alter f = mapEC $ M.alter (mapConfExt f) (typeRep (Proxy @a))
   where
     mapEC g c = c{ extensibleConf = g (extensibleConf c) }
 
+-- | Config-time: Functor variant of 'alter', useful if the configuration
+-- modifications needs to do some 'IO'.
+alterF :: forall a l f. (Typeable a, Functor f)
+       => (Maybe a -> f (Maybe a)) -> XConfig l -> f (XConfig l)
+alterF f = mapEC $ M.alterF (mapConfExtF f) (typeRep (Proxy @a))
+  where
+    mapEC g c = g (extensibleConf c) <&> \ec -> c{ extensibleConf = ec }
+
+
 fromConfExt :: Typeable a => ConfExtension -> Maybe a
 fromConfExt (ConfExtension val) = cast val
 
 mapConfExt :: Typeable a
            => (Maybe a -> Maybe a) -> Maybe ConfExtension -> Maybe ConfExtension
 mapConfExt f = fmap ConfExtension . f . (>>= fromConfExt)
 
+mapConfExtF :: (Typeable a, Functor f)
+            => (Maybe a -> f (Maybe a)) -> Maybe ConfExtension -> f (Maybe ConfExtension)
+mapConfExtF f = fmap (fmap ConfExtension) . f . (>>= fromConfExt)
+
 
 -- ---------------------------------------------------------------------
--- High-level idioms
+-- High-level idioms based on Semigroup
 
 -- | Run-time: Run a monadic action with the value of the custom
 -- configuration, if set.
 with :: (MonadReader XConf m, Typeable a, Monoid b) => (a -> m b) -> m b
 with a = ask >>= maybe (pure mempty) a
 
--- | Run-time: Run a monadic action with the value of the custom
--- configuration, or the 'Default' value thereof, if absent.
-withDef :: (MonadReader XConf m, Typeable a, Default a) => (a -> m b) -> m b
-withDef a = ask >>= a . fromMaybe def
-
 -- | Config-time: Add (append) a piece of custom configuration to an 'XConfig'
 -- using the 'Semigroup' instance of the configuration type.
 add :: (Semigroup a, Typeable a)
@@ -143,48 +151,31 @@ onceM :: forall a l m. (Applicative m, Semigroup a, Typeable a)
       -> XConfig l -> m (XConfig l)
 onceM f x c = maybe f (const pure) (lookup @a c) $ add x c
 
--- | Config-time: Modify a configuration value in 'XConfig', or print a
--- warning to stderr if there's no value to be modified. This is an
--- alternative to 'add' for when a 'Semigroup' instance is unavailable or
--- unsuitable.
---
--- Note that this must be used /after/ 'once' or any of its variants for the
--- warning to not be printed.
-modify :: forall a l. (Typeable a)
-       => (a -> a) -- ^ modification of configuration
-       -> XConfig l -> XConfig l
-modify f c = maybe (trace missing) (const (alter (f <$>))) (lookup @a c) c
-  where
-    missing = "X.U.ExtensibleConf.modify: no value of type " <> show (typeRep (Proxy @a))
-    -- TODO: xmessage in startupHook instead
+
+-- ---------------------------------------------------------------------
+-- High-level idioms based on Default
+
+-- | Run-time: Run a monadic action with the value of the custom
+-- configuration, or the 'Default' value thereof, if absent.
+withDef :: (MonadReader XConf m, Typeable a, Default a) => (a -> m b) -> m b
+withDef a = ask >>= a . fromMaybe def
 
 -- | Config-time: Modify a configuration value in 'XConfig', initializing it
 -- to its 'Default' value first if absent. This is an alternative to 'add' for
 -- when a 'Semigroup' instance is unavailable or unsuitable.
 --
 -- Note that this must /not/ be used together with any variant of 'once'!
-modifyDef :: forall a l. (Typeable a, Default a)
+modifyDef :: forall a l. (Default a, Typeable a)
           => (a -> a) -- ^ modification of configuration
           -> XConfig l -> XConfig l
 modifyDef f = alter ((f <$>) . (<|> Just def))
 
--- | Config-time: Apply a modification to 'XConfig' only once, guarded by the
--- absence of a configuration value. This is an alternative to 'once' for when
--- a 'Semigroup' instance is unavailable or unsuitable.
---
--- (The configuration value is the first argument as it's expected to be
--- supplied by the contrib module.)
-onceIni :: forall a l. (Typeable a)
-        => a -- ^ initial (default, empty, …) configuration
-        -> (XConfig l -> XConfig l) -- ^ 'XConfig' modification done only once
-        -> XConfig l -> XConfig l
-onceIni x f c = maybe f (const id) (lookup @a c) $ alter (<|> Just x) c
-
--- | Config-time: Applicative (monadic) variant of 'once'', useful if the
--- 'XConfig' modification needs to do some 'IO' (e.g. create an
+-- | Config-time: Applicative (monadic) variant of 'modifyDef', useful if the
+-- configuration value modification needs to do some 'IO' (e.g. create an
 -- 'Data.IORef.IORef').
-onceIniM :: forall a l m. (Applicative m, Typeable a)
-         => a -- ^ initial (default, empty, …) configuration
-         -> (XConfig l -> m (XConfig l)) -- ^ 'XConfig' modification done only once
-         -> XConfig l -> m (XConfig l)
-onceIniM x f c = maybe f (const pure) (lookup @a c) $ alter (<|> Just x) c
+--
+-- Note that this must /not/ be used together with any variant of 'once'!
+modifyDefM :: forall a l m. (Applicative m, Default a, Typeable a)
+           => (a -> m a) -- ^ modification of configuration
+           -> XConfig l -> m (XConfig l)
+modifyDefM f = alterF (traverse f . (<|> Just def))

tests/ExtensibleConf.hs

@@ -30,18 +30,6 @@ spec = do
         borderWidth c `shouldBe` succ (borderWidth def)
         XC.lookup c `shouldBe` Just "ab"
 
-    specify "onceIni" $ do
-        let c = XC.onceIni "a" incBorderWidth def
-        borderWidth c `shouldBe` succ (borderWidth def)
-        XC.lookup c `shouldBe` Just "a"
-    specify "onceIni . onceIni" $ do
-        let c = XC.onceIni "b" incBorderWidth (XC.onceIni "a" incBorderWidth def)
-        borderWidth c `shouldBe` succ (borderWidth def)
-        XC.lookup c `shouldBe` Just "a"
-    specify "modify . onceIni" $ do
-        let c = XC.modify (<> "b") (XC.onceIni "a" incBorderWidth def)
-        borderWidth c `shouldBe` succ (borderWidth def)
-        XC.lookup c `shouldBe` Just "ab"
     specify "modifyDef" $ do
         let c = XC.modifyDef (<> "a") def
         XC.lookup c `shouldBe` Just "a"