From 8c05c5e0661e0c8f7d53c4bb13f095177613ccee Mon Sep 17 00:00:00 2001 From: Tomas Janousek Date: Wed, 20 Oct 2021 00:53:08 +0100 Subject: [PATCH] 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 | 85 ++++++++++++++++------------------- tests/ExtensibleConf.hs | 12 ----- 2 files changed, 38 insertions(+), 59 deletions(-) diff --git a/XMonad/Util/ExtensibleConf.hs b/XMonad/Util/ExtensibleConf.hs index e706789de6..56c57c2207 100644 --- a/XMonad/Util/ExtensibleConf.hs +++ b/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,6 +92,15 @@ 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 @@ -99,20 +108,19 @@ 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)) diff --git a/tests/ExtensibleConf.hs b/tests/ExtensibleConf.hs index 412cb9371a..e3bb906216 100644 --- a/tests/ExtensibleConf.hs +++ b/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"