{-# 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