    {-# LANGUAGE LambdaCase #-}
    {-# LANGUAGE PatternGuards #-}
    -----------------------------------------------------------------------------
    -- |
    -- Module      :  XMonad.Util.ExtensibleState
    -- Description :  Module for storing custom mutable state in xmonad.
    -- Copyright   :  (c) Daniel Schoepe 2009
    -- License     :  BSD3-style (see LICENSE)
    --
    -- Maintainer  :  daniel.schoepe@gmail.com
    -- Stability   :  unstable
    -- Portability :  not portable
    --
    -- Module for storing custom mutable state in xmonad.
    --
    -----------------------------------------------------------------------------

    module XMonad.Util.ExtensibleState (
                                  -- * Usage
                                  -- $usage
                                  put
                                  , modify
                                  , modify'
                                  , modifyM
                                  , modifyM'
                                  , remove
                                  , get
                                  , gets
                                  , modified
                                  , modifiedM
                                  ) where

    import Data.Typeable (typeOf,cast)
    import qualified Data.Map as M
    import XMonad.Core
    import XMonad.Util.PureX
    import qualified Control.Monad.State as State
    import XMonad.Prelude (fromMaybe)

    -- ---------------------------------------------------------------------
    -- $usage
    --
    -- To utilize this feature in a contrib module, create a data type
    -- and make it an instance of ExtensionClass. You can then use
    -- the functions from this module for storing and retrieving your data:
    --
    -- > import qualified XMonad.Util.ExtensibleState as XS
    -- >
    -- > data ListStorage = ListStorage [Integer]
    -- > instance ExtensionClass ListStorage where
    -- >   initialValue = ListStorage []
    -- >
    -- > .. XS.put (ListStorage [23,42])
    --
    -- To retrieve the stored value call:
    --
    -- > .. XS.get
    --
    -- If the type can't be inferred from the usage of the retrieved data, you
    -- have to add an explicit type signature:
    --
    -- > .. XS.get :: X ListStorage
    --
    -- To make your data persistent between restarts, the data type needs to be
    -- an instance of Read and Show and the instance declaration has to be changed:
    --
    -- > data ListStorage = ListStorage [Integer] deriving (Read,Show)
    -- >
    -- > instance ExtensionClass ListStorage where
    -- >   initialValue = ListStorage []
    -- >   extensionType = PersistentExtension
    --
    -- One should take care that the string representation of the chosen type
    -- is unique among the stored values, otherwise it will be overwritten.
    -- Normally these string representations contain fully qualified module names
    -- when automatically deriving Typeable, so
    -- name collisions should not be a problem in most cases.
    -- A module should not try to store common datatypes(e.g. a list of Integers)
    -- without a custom data type as a wrapper to avoid collisions with other modules
    -- trying to store the same data type without a wrapper.
    --

    -- | Modify the map of state extensions by applying the given function.
    modifyStateExts
      :: XLike m
      => (M.Map String (Either String StateExtension)
      -> M.Map String (Either String StateExtension))
      -> m ()
    modifyStateExts :: forall (m :: * -> *).
    XLike m =>
    (Map String (Either String StateExtension)
     -> Map String (Either String StateExtension))
    -> m ()
    modifyStateExts Map String (Either String StateExtension)
    -> Map String (Either String StateExtension)
    f = (XState -> XState) -> m ()
    forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
    State.modify ((XState -> XState) -> m ()) -> (XState -> XState) -> m ()
    forall a b. (a -> b) -> a -> b
    $ \XState
    st -> XState
    st { extensibleState = f (extensibleState st) }

    -- | Apply a function to a stored value of the matching type or the initial value if there
    -- is none.
    modify :: (ExtensionClass a, XLike m) => (a -> a) -> m ()
    modify :: forall a (m :: * -> *).
    (ExtensionClass a, XLike m) =>
    (a -> a) -> m ()
    modify = (a -> m a) -> m ()
    forall a (m :: * -> *).
    (ExtensionClass a, XLike m) =>
    (a -> m a) -> m ()
    modifyM ((a -> m a) -> m ()) -> ((a -> a) -> a -> m a) -> (a -> a) -> m ()
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (a -> m a
    forall a. a -> m a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (a -> m a) -> (a -> a) -> a -> m a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    .)

    -- | Apply an action to a stored value of the matching type or the initial value if there
    -- is none.
    modifyM :: (ExtensionClass a, XLike m) => (a -> m a) -> m ()
    modifyM :: forall a (m :: * -> *).
    (ExtensionClass a, XLike m) =>
    (a -> m a) -> m ()
    modifyM a -> m a
    f = a -> m ()
    forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
    put (a -> m ()) -> m a -> m ()
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< a -> m a
    f (a -> m a) -> m a -> m a
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< m a
    forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
    get

    -- | Like 'modify' but the result value is forced to WHNF before being stored.
    modify' :: (ExtensionClass a, XLike m) => (a -> a) -> m ()
    modify' :: forall a (m :: * -> *).
    (ExtensionClass a, XLike m) =>
    (a -> a) -> m ()
    modify' = (a -> m a) -> m ()
    forall a (m :: * -> *).
    (ExtensionClass a, XLike m) =>
    (a -> m a) -> m ()
    modifyM' ((a -> m a) -> m ()) -> ((a -> a) -> a -> m a) -> (a -> a) -> m ()
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (a -> m a
    forall a. a -> m a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (a -> m a) -> (a -> a) -> a -> m a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    .)

    -- | Like 'modifyM' but the result value is forced to WHNF before being stored.
    modifyM' :: (ExtensionClass a, XLike m) => (a -> m a) -> m ()
    modifyM' :: forall a (m :: * -> *).
    (ExtensionClass a, XLike m) =>
    (a -> m a) -> m ()
    modifyM' a -> m a
    f = (a -> m ()
    forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
    put (a -> m ()) -> a -> m ()
    forall a b. (a -> b) -> a -> b
    $!) (a -> m ()) -> m a -> m ()
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< a -> m a
    f (a -> m a) -> m a -> m a
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< m a
    forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
    get

    -- | Add a value to the extensible state field. A previously stored value with the same
    -- type will be overwritten. (More precisely: A value whose string representation of its type
    -- is equal to the new one's)
    put :: (ExtensionClass a, XLike m) => a -> m ()
    put :: forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
    put a
    v = (Map String (Either String StateExtension)
     -> Map String (Either String StateExtension))
    -> m ()
    forall (m :: * -> *).
    XLike m =>
    (Map String (Either String StateExtension)
     -> Map String (Either String StateExtension))
    -> m ()
    modifyStateExts ((Map String (Either String StateExtension)
      -> Map String (Either String StateExtension))
     -> m ())
    -> (a
        -> Map String (Either String StateExtension)
        -> Map String (Either String StateExtension))
    -> a
    -> m ()
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String
    -> Either String StateExtension
    -> Map String (Either String StateExtension)
    -> Map String (Either String StateExtension)
    forall k a. Ord k => k -> a -> Map k a -> Map k a
    M.insert (TypeRep -> String
    forall a. Show a => a -> String
    show (TypeRep -> String) -> (a -> TypeRep) -> a -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . a -> TypeRep
    forall a. Typeable a => a -> TypeRep
    typeOf (a -> String) -> a -> String
    forall a b. (a -> b) -> a -> b
    $ a
    v) (Either String StateExtension
     -> Map String (Either String StateExtension)
     -> Map String (Either String StateExtension))
    -> (a -> Either String StateExtension)
    -> a
    -> Map String (Either String StateExtension)
    -> Map String (Either String StateExtension)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . StateExtension -> Either String StateExtension
    forall a b. b -> Either a b
    Right (StateExtension -> Either String StateExtension)
    -> (a -> StateExtension) -> a -> Either String StateExtension
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . a -> StateExtension
    forall a. ExtensionClass a => a -> StateExtension
    extensionType (a -> m ()) -> a -> m ()
    forall a b. (a -> b) -> a -> b
    $ a
    v

    -- | Try to retrieve a value of the requested type, return an initial value if there is no such value.
    get :: (ExtensionClass a, XLike m) => m a
    get :: forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
    get = a -> m a
    forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m a
    getState' a
    forall a. HasCallStack => a
    undefined -- `trick' to avoid needing -XScopedTypeVariables
      where toValue :: a -> a
    toValue a
    val = a -> Maybe a -> a
    forall a. a -> Maybe a -> a
    fromMaybe a
    forall a. ExtensionClass a => a
    initialValue (Maybe a -> a) -> Maybe a -> a
    forall a b. (a -> b) -> a -> b
    $ a -> Maybe a
    forall a b. (Typeable a, Typeable b) => a -> Maybe b
    cast a
    val
            getState' :: (ExtensionClass a, XLike m) => a -> m a
            getState' :: forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m a
    getState' a
    k = do
              Maybe (Either String StateExtension)
    v <- (XState -> Maybe (Either String StateExtension))
    -> m (Maybe (Either String StateExtension))
    forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
    State.gets ((XState -> Maybe (Either String StateExtension))
     -> m (Maybe (Either String StateExtension)))
    -> (XState -> Maybe (Either String StateExtension))
    -> m (Maybe (Either String StateExtension))
    forall a b. (a -> b) -> a -> b
    $ String
    -> Map String (Either String StateExtension)
    -> Maybe (Either String StateExtension)
    forall k a. Ord k => k -> Map k a -> Maybe a
    M.lookup (TypeRep -> String
    forall a. Show a => a -> String
    show (TypeRep -> String) -> (a -> TypeRep) -> a -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . a -> TypeRep
    forall a. Typeable a => a -> TypeRep
    typeOf (a -> String) -> a -> String
    forall a b. (a -> b) -> a -> b
    $ a
    k) (Map String (Either String StateExtension)
     -> Maybe (Either String StateExtension))
    -> (XState -> Map String (Either String StateExtension))
    -> XState
    -> Maybe (Either String StateExtension)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . XState -> Map String (Either String StateExtension)
    extensibleState
              case Maybe (Either String StateExtension)
    v of
                Just (Right (StateExtension a
    val)) -> a -> m a
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (a -> m a) -> a -> m a
    forall a b. (a -> b) -> a -> b
    $ a -> a
    forall {a} {a}. (ExtensionClass a, Typeable a) => a -> a
    toValue a
    val
                Just (Right (PersistentExtension a
    val)) -> a -> m a
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (a -> m a) -> a -> m a
    forall a b. (a -> b) -> a -> b
    $ a -> a
    forall {a} {a}. (ExtensionClass a, Typeable a) => a -> a
    toValue a
    val
                Just (Left String
    str) | PersistentExtension a
    x <- a -> StateExtension
    forall a. ExtensionClass a => a -> StateExtension
    extensionType a
    k -> do
                    let val :: a
    val = a -> Maybe a -> a
    forall a. a -> Maybe a -> a
    fromMaybe a
    forall a. ExtensionClass a => a
    initialValue (Maybe a -> a) -> Maybe a -> a
    forall a b. (a -> b) -> a -> b
    $ a -> Maybe a
    forall a b. (Typeable a, Typeable b) => a -> Maybe b
    cast (a -> Maybe a) -> Maybe a -> Maybe a
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< String -> Maybe a
    forall {a}. Read a => String -> Maybe a
    safeRead String
    str Maybe a -> Maybe a -> Maybe a
    forall a. a -> a -> a
    `asTypeOf` a -> Maybe a
    forall a. a -> Maybe a
    Just a
    x
                    a -> m ()
    forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
    put (a
    val a -> a -> a
    forall a. a -> a -> a
    `asTypeOf` a
    k)
                    a -> m a
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return a
    val
                Maybe (Either String StateExtension)
    _ -> a -> m a
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return a
    forall a. ExtensionClass a => a
    initialValue
            safeRead :: String -> Maybe a
    safeRead String
    str = case ReadS a
    forall a. Read a => ReadS a
    reads String
    str of
                             [(a
    x,String
    "")] -> a -> Maybe a
    forall a. a -> Maybe a
    Just a
    x
                             [(a, String)]
    _ -> Maybe a
    forall a. Maybe a
    Nothing

    gets :: (ExtensionClass a, XLike m) => (a -> b) -> m b
    gets :: forall a (m :: * -> *) b.
    (ExtensionClass a, XLike m) =>
    (a -> b) -> m b
    gets = ((a -> b) -> m a -> m b) -> m a -> (a -> b) -> m b
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip (a -> b) -> m a -> m b
    forall a b. (a -> b) -> m a -> m b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap m a
    forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
    get

    -- | Remove the value from the extensible state field that has the same type as the supplied argument
    remove :: (ExtensionClass a, XLike m) => a -> m ()
    remove :: forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
    remove a
    wit = (Map String (Either String StateExtension)
     -> Map String (Either String StateExtension))
    -> m ()
    forall (m :: * -> *).
    XLike m =>
    (Map String (Either String StateExtension)
     -> Map String (Either String StateExtension))
    -> m ()
    modifyStateExts ((Map String (Either String StateExtension)
      -> Map String (Either String StateExtension))
     -> m ())
    -> (Map String (Either String StateExtension)
        -> Map String (Either String StateExtension))
    -> m ()
    forall a b. (a -> b) -> a -> b
    $ String
    -> Map String (Either String StateExtension)
    -> Map String (Either String StateExtension)
    forall k a. Ord k => k -> Map k a -> Map k a
    M.delete (TypeRep -> String
    forall a. Show a => a -> String
    show (TypeRep -> String) -> (a -> TypeRep) -> a -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . a -> TypeRep
    forall a. Typeable a => a -> TypeRep
    typeOf (a -> String) -> a -> String
    forall a b. (a -> b) -> a -> b
    $ a
    wit)

    modified :: (ExtensionClass a, Eq a, XLike m) => (a -> a) -> m Bool
    modified :: forall a (m :: * -> *).
    (ExtensionClass a, Eq a, XLike m) =>
    (a -> a) -> m Bool
    modified = (a -> m a) -> m Bool
    forall a (m :: * -> *).
    (ExtensionClass a, Eq a, XLike m) =>
    (a -> m a) -> m Bool
    modifiedM ((a -> m a) -> m Bool)
    -> ((a -> a) -> a -> m a) -> (a -> a) -> m Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (a -> m a
    forall a. a -> m a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (a -> m a) -> (a -> a) -> a -> m a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    .)

    modifiedM :: (ExtensionClass a, Eq a, XLike m) => (a -> m a) -> m Bool
    modifiedM :: forall a (m :: * -> *).
    (ExtensionClass a, Eq a, XLike m) =>
    (a -> m a) -> m Bool
    modifiedM a -> m a
    f = do
        a
    v <- m a
    forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
    get
        a -> m a
    f a
    v m a -> (a -> m Bool) -> m Bool
    forall a b. m a -> (a -> m b) -> m b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \case
            a
    v' | a
    v' a -> a -> Bool
    forall a. Eq a => a -> a -> Bool
    == a
    v   -> Bool -> m Bool
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    False
               | Bool
    otherwise -> a -> m ()
    forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
    put a
    v' m () -> m Bool -> m Bool
    forall a b. m a -> m b -> m b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> Bool -> m Bool
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    True