{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- |
-- Module      :  XMonad.Util.ExtensibleConf
-- Description :  Extensible and composable configuration for contrib modules.
-- Copyright   :  (c) 2021 Tomáš Janoušek <tomi@nomi.cz>
-- License     :  BSD3
-- Maintainer  :  Tomáš Janoušek <tomi@nomi.cz>
--
-- Extensible and composable configuration for contrib modules.
--
-- This is the configuration counterpart of "XMonad.Util.ExtensibleState". It
-- allows contrib modules to store custom configuration values inside
-- 'XConfig'. This lets them create custom hooks, ensure they hook into xmonad
-- core only once, and possibly more.
--

module XMonad.Util.ExtensibleConf (
    -- * Usage
    -- $usage

    -- * High-level idioms based on Semigroup
    with,
    add,
    once,
    onceM,

    -- * High-level idioms based on Default
    withDef,
    modifyDef,
    modifyDefM,

    -- * Low-level primitivies
    ask,
    lookup,
    alter,
    alterF,
    ) where

import Prelude hiding (lookup)
import XMonad hiding (ask, modify, trace)
import XMonad.Prelude ((<|>), (<&>), fromMaybe)

import Data.Typeable
import qualified Data.Map as M


-- ---------------------------------------------------------------------
-- $usage
--
-- To utilize this feature in a contrib module, create a data type for the
-- configuration, then use the helper functions provided here to implement
-- a user-friendly composable interface for your contrib module.
--
-- Example:
--
-- > import qualified XMonad.Util.ExtensibleConf as XC
-- >
-- > {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-- > newtype MyConf = MyConf{ fromMyConf :: [Int] } deriving Semigroup
-- >
-- > customLogger :: Int -> XConfig l -> XConfig l
-- > customLogger i = XC.once (MyConf [i]) $ \c -> c{ logHook = logHook c <> lh }
-- >   where
-- >     lh :: X ()
-- >     lh = XC.with $ io . print . fromMyConf
--
-- The above defines an xmonad configuration combinator that can be applied
-- any number of times like so:
--
-- > main = xmonad $ … . customLogger 1 . ewmh . customLogger 2 . … $ def{…}
--
-- and will always result in just one 'print' invocation in 'logHook'.


-- ---------------------------------------------------------------------
-- Low-level primitivies

-- | Run-time: Retrieve a configuration value of the requested type.
ask :: (MonadReader XConf m, Typeable a) => m (Maybe a)
ask :: m (Maybe a)
ask = (XConf -> Maybe a) -> m (Maybe a)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((XConf -> Maybe a) -> m (Maybe a))
-> (XConf -> Maybe a) -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ XConfig Layout -> Maybe a
forall a (l :: * -> *). Typeable a => XConfig l -> Maybe a
lookup (XConfig Layout -> Maybe a)
-> (XConf -> XConfig Layout) -> XConf -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XConf -> XConfig Layout
config

-- | Config-time: Retrieve a configuration value of the requested type.
lookup :: forall a l. Typeable a => XConfig l -> Maybe a
lookup :: XConfig l -> Maybe a
lookup XConfig l
c = ConfExtension -> Maybe a
forall a. Typeable a => ConfExtension -> Maybe a
fromConfExt (ConfExtension -> Maybe a) -> Maybe ConfExtension -> Maybe a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Proxy a -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a
forall k (t :: k). Proxy t
Proxy @a) TypeRep -> Map TypeRep ConfExtension -> Maybe ConfExtension
forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` XConfig l -> Map TypeRep ConfExtension
forall (l :: * -> *). XConfig l -> Map TypeRep ConfExtension
extensibleConf XConfig l
c

-- | Config-time: Alter a configuration value, or absence thereof.
alter :: forall a l. Typeable a => (Maybe a -> Maybe a) -> XConfig l -> XConfig l
alter :: (Maybe a -> Maybe a) -> XConfig l -> XConfig l
alter Maybe a -> Maybe a
f = (Map TypeRep ConfExtension -> Map TypeRep ConfExtension)
-> XConfig l -> XConfig l
forall (l :: * -> *).
(Map TypeRep ConfExtension -> Map TypeRep ConfExtension)
-> XConfig l -> XConfig l
mapEC ((Map TypeRep ConfExtension -> Map TypeRep ConfExtension)
 -> XConfig l -> XConfig l)
-> (Map TypeRep ConfExtension -> Map TypeRep ConfExtension)
-> XConfig l
-> XConfig l
forall a b. (a -> b) -> a -> b
$ (Maybe ConfExtension -> Maybe ConfExtension)
-> TypeRep
-> Map TypeRep ConfExtension
-> Map TypeRep ConfExtension
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
M.alter ((Maybe a -> Maybe a) -> Maybe ConfExtension -> Maybe ConfExtension
forall a.
Typeable a =>
(Maybe a -> Maybe a) -> Maybe ConfExtension -> Maybe ConfExtension
mapConfExt Maybe a -> Maybe a
f) (Proxy a -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a
forall k (t :: k). Proxy t
Proxy @a))
  where
    mapEC :: (Map TypeRep ConfExtension -> Map TypeRep ConfExtension)
-> XConfig l -> XConfig l
mapEC Map TypeRep ConfExtension -> Map TypeRep ConfExtension
g XConfig l
c = XConfig l
c{ extensibleConf :: Map TypeRep ConfExtension
extensibleConf = Map TypeRep ConfExtension -> Map TypeRep ConfExtension
g (XConfig l -> Map TypeRep ConfExtension
forall (l :: * -> *). XConfig l -> Map TypeRep ConfExtension
extensibleConf XConfig l
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 :: (Maybe a -> f (Maybe a)) -> XConfig l -> f (XConfig l)
alterF Maybe a -> f (Maybe a)
f = (Map TypeRep ConfExtension -> f (Map TypeRep ConfExtension))
-> XConfig l -> f (XConfig l)
forall (f :: * -> *) (l :: * -> *).
Functor f =>
(Map TypeRep ConfExtension -> f (Map TypeRep ConfExtension))
-> XConfig l -> f (XConfig l)
mapEC ((Map TypeRep ConfExtension -> f (Map TypeRep ConfExtension))
 -> XConfig l -> f (XConfig l))
-> (Map TypeRep ConfExtension -> f (Map TypeRep ConfExtension))
-> XConfig l
-> f (XConfig l)
forall a b. (a -> b) -> a -> b
$ (Maybe ConfExtension -> f (Maybe ConfExtension))
-> TypeRep
-> Map TypeRep ConfExtension
-> f (Map TypeRep ConfExtension)
forall (f :: * -> *) k a.
(Functor f, Ord k) =>
(Maybe a -> f (Maybe a)) -> k -> Map k a -> f (Map k a)
M.alterF ((Maybe a -> f (Maybe a))
-> Maybe ConfExtension -> f (Maybe ConfExtension)
forall a (f :: * -> *).
(Typeable a, Functor f) =>
(Maybe a -> f (Maybe a))
-> Maybe ConfExtension -> f (Maybe ConfExtension)
mapConfExtF Maybe a -> f (Maybe a)
f) (Proxy a -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a
forall k (t :: k). Proxy t
Proxy @a))
  where
    mapEC :: (Map TypeRep ConfExtension -> f (Map TypeRep ConfExtension))
-> XConfig l -> f (XConfig l)
mapEC Map TypeRep ConfExtension -> f (Map TypeRep ConfExtension)
g XConfig l
c = Map TypeRep ConfExtension -> f (Map TypeRep ConfExtension)
g (XConfig l -> Map TypeRep ConfExtension
forall (l :: * -> *). XConfig l -> Map TypeRep ConfExtension
extensibleConf XConfig l
c) f (Map TypeRep ConfExtension)
-> (Map TypeRep ConfExtension -> XConfig l) -> f (XConfig l)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Map TypeRep ConfExtension
ec -> XConfig l
c{ extensibleConf :: Map TypeRep ConfExtension
extensibleConf = Map TypeRep ConfExtension
ec }


fromConfExt :: Typeable a => ConfExtension -> Maybe a
fromConfExt :: ConfExtension -> Maybe a
fromConfExt (ConfExtension a
val) = a -> Maybe a
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
val

mapConfExt :: Typeable a
           => (Maybe a -> Maybe a) -> Maybe ConfExtension -> Maybe ConfExtension
mapConfExt :: (Maybe a -> Maybe a) -> Maybe ConfExtension -> Maybe ConfExtension
mapConfExt Maybe a -> Maybe a
f = (a -> ConfExtension) -> Maybe a -> Maybe ConfExtension
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> ConfExtension
forall a. Typeable a => a -> ConfExtension
ConfExtension (Maybe a -> Maybe ConfExtension)
-> (Maybe ConfExtension -> Maybe a)
-> Maybe ConfExtension
-> Maybe ConfExtension
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe a -> Maybe a
f (Maybe a -> Maybe a)
-> (Maybe ConfExtension -> Maybe a)
-> Maybe ConfExtension
-> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe ConfExtension -> (ConfExtension -> Maybe a) -> Maybe a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ConfExtension -> Maybe a
forall a. Typeable a => ConfExtension -> Maybe a
fromConfExt)

mapConfExtF :: (Typeable a, Functor f)
            => (Maybe a -> f (Maybe a)) -> Maybe ConfExtension -> f (Maybe ConfExtension)
mapConfExtF :: (Maybe a -> f (Maybe a))
-> Maybe ConfExtension -> f (Maybe ConfExtension)
mapConfExtF Maybe a -> f (Maybe a)
f = (Maybe a -> Maybe ConfExtension)
-> f (Maybe a) -> f (Maybe ConfExtension)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> ConfExtension) -> Maybe a -> Maybe ConfExtension
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> ConfExtension
forall a. Typeable a => a -> ConfExtension
ConfExtension) (f (Maybe a) -> f (Maybe ConfExtension))
-> (Maybe ConfExtension -> f (Maybe a))
-> Maybe ConfExtension
-> f (Maybe ConfExtension)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe a -> f (Maybe a)
f (Maybe a -> f (Maybe a))
-> (Maybe ConfExtension -> Maybe a)
-> Maybe ConfExtension
-> f (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe ConfExtension -> (ConfExtension -> Maybe a) -> Maybe a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ConfExtension -> Maybe a
forall a. Typeable a => ConfExtension -> Maybe a
fromConfExt)


-- ---------------------------------------------------------------------
-- 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 -> m b) -> m b
with a -> m b
a = m (Maybe a)
forall (m :: * -> *) a.
(MonadReader XConf m, Typeable a) =>
m (Maybe a)
ask m (Maybe a) -> (Maybe a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m b -> (a -> m b) -> Maybe a -> m b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (b -> m b
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
forall a. Monoid a => a
mempty) a -> m b
a

-- | 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)
    => a -- ^ configuration to add
    -> XConfig l -> XConfig l
add :: a -> XConfig l -> XConfig l
add a
x = (Maybe a -> Maybe a) -> XConfig l -> XConfig l
forall a (l :: * -> *).
Typeable a =>
(Maybe a -> Maybe a) -> XConfig l -> XConfig l
alter (Maybe a -> Maybe a -> Maybe a
forall a. Semigroup a => a -> a -> a
<> a -> Maybe a
forall a. a -> Maybe a
Just a
x)

-- | Config-time: 'add' a piece of custom configuration, and if it's the first
-- piece of this type, also modify the 'XConfig' using the provided function.
--
-- This can be used to implement a composable interface for modules that must
-- only hook into xmonad core once.
--
-- (The piece of custom configuration is the last argument as it's expected to
-- come from the user.)
once :: forall a l. (Semigroup a, Typeable a)
     => (XConfig l -> XConfig l) -- ^ 'XConfig' modification done only once
     -> a -- ^ configuration to add
     -> XConfig l -> XConfig l
once :: (XConfig l -> XConfig l) -> a -> XConfig l -> XConfig l
once XConfig l -> XConfig l
f a
x XConfig l
c = (XConfig l -> XConfig l)
-> (a -> XConfig l -> XConfig l)
-> Maybe a
-> XConfig l
-> XConfig l
forall b a. b -> (a -> b) -> Maybe a -> b
maybe XConfig l -> XConfig l
f ((XConfig l -> XConfig l) -> a -> XConfig l -> XConfig l
forall a b. a -> b -> a
const XConfig l -> XConfig l
forall a. a -> a
id) (XConfig l -> Maybe a
forall a (l :: * -> *). Typeable a => XConfig l -> Maybe a
lookup @a XConfig l
c) (XConfig l -> XConfig l) -> XConfig l -> XConfig l
forall a b. (a -> b) -> a -> b
$ a -> XConfig l -> XConfig l
forall a (l :: * -> *).
(Semigroup a, Typeable a) =>
a -> XConfig l -> XConfig l
add a
x XConfig l
c

-- | Config-time: Applicative (monadic) variant of 'once', useful if the
-- 'XConfig' modification needs to do some 'IO' (e.g. create an
-- 'Data.IORef.IORef').
onceM :: forall a l m. (Applicative m, Semigroup a, Typeable a)
      => (XConfig l -> m (XConfig l)) -- ^ 'XConfig' modification done only once
      -> a -- ^ configuration to add
      -> XConfig l -> m (XConfig l)
onceM :: (XConfig l -> m (XConfig l)) -> a -> XConfig l -> m (XConfig l)
onceM XConfig l -> m (XConfig l)
f a
x XConfig l
c = (XConfig l -> m (XConfig l))
-> (a -> XConfig l -> m (XConfig l))
-> Maybe a
-> XConfig l
-> m (XConfig l)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe XConfig l -> m (XConfig l)
f ((XConfig l -> m (XConfig l)) -> a -> XConfig l -> m (XConfig l)
forall a b. a -> b -> a
const XConfig l -> m (XConfig l)
forall (f :: * -> *) a. Applicative f => a -> f a
pure) (XConfig l -> Maybe a
forall a (l :: * -> *). Typeable a => XConfig l -> Maybe a
lookup @a XConfig l
c) (XConfig l -> m (XConfig l)) -> XConfig l -> m (XConfig l)
forall a b. (a -> b) -> a -> b
$ a -> XConfig l -> XConfig l
forall a (l :: * -> *).
(Semigroup a, Typeable a) =>
a -> XConfig l -> XConfig l
add a
x XConfig l
c


-- ---------------------------------------------------------------------
-- 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 -> m b) -> m b
withDef a -> m b
a = m (Maybe a)
forall (m :: * -> *) a.
(MonadReader XConf m, Typeable a) =>
m (Maybe a)
ask m (Maybe a) -> (Maybe a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> m b
a (a -> m b) -> (Maybe a -> a) -> Maybe a -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe a
forall a. Default a => a
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. (Default a, Typeable a)
          => (a -> a) -- ^ modification of configuration
          -> XConfig l -> XConfig l
modifyDef :: (a -> a) -> XConfig l -> XConfig l
modifyDef a -> a
f = (Maybe a -> Maybe a) -> XConfig l -> XConfig l
forall a (l :: * -> *).
Typeable a =>
(Maybe a -> Maybe a) -> XConfig l -> XConfig l
alter ((a -> a
f (a -> a) -> Maybe a -> Maybe a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (Maybe a -> Maybe a) -> (Maybe a -> Maybe a) -> Maybe a -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> a -> Maybe a
forall a. a -> Maybe a
Just a
forall a. Default a => a
def))

-- | 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').
--
-- 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 :: (a -> m a) -> XConfig l -> m (XConfig l)
modifyDefM a -> m a
f = (Maybe a -> m (Maybe a)) -> XConfig l -> m (XConfig l)
forall a (l :: * -> *) (f :: * -> *).
(Typeable a, Functor f) =>
(Maybe a -> f (Maybe a)) -> XConfig l -> f (XConfig l)
alterF ((a -> m a) -> Maybe a -> m (Maybe a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> m a
f (Maybe a -> m (Maybe a))
-> (Maybe a -> Maybe a) -> Maybe a -> m (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> a -> Maybe a
forall a. a -> Maybe a
Just a
forall a. Default a => a
def))