{-# 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 = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify forall a b. (a -> b) -> a -> b
$ \XState
st -> XState
st { extensibleState :: Map String (Either String StateExtension)
extensibleState = Map String (Either String StateExtension)
-> Map String (Either String StateExtension)
f (XState -> Map String (Either String StateExtension)
extensibleState XState
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 = forall a (m :: * -> *).
(ExtensionClass a, XLike m) =>
(a -> m a) -> m ()
modifyM forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 = forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
put forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< a -> m a
f forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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' = forall a (m :: * -> *).
(ExtensionClass a, XLike m) =>
(a -> m a) -> m ()
modifyM' forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 = (forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
put forall a b. (a -> b) -> a -> b
$!) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< a -> m a
f forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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 = forall (m :: * -> *).
XLike m =>
(Map String (Either String StateExtension)
 -> Map String (Either String StateExtension))
-> m ()
modifyStateExts forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Typeable a => a -> TypeRep
typeOf forall a b. (a -> b) -> a -> b
$ a
v) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ExtensionClass a => a -> StateExtension
extensionType 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 = forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m a
getState' forall a. HasCallStack => a
undefined -- `trick' to avoid needing -XScopedTypeVariables
  where toValue :: a -> a
toValue a
val = forall a. a -> Maybe a -> a
fromMaybe forall a. ExtensionClass a => a
initialValue forall a b. (a -> b) -> a -> b
$ 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 <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Typeable a => a -> TypeRep
typeOf forall a b. (a -> b) -> a -> b
$ a
k) 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)) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall {a} {a}. (ExtensionClass a, Typeable a) => a -> a
toValue a
val
            Just (Right (PersistentExtension a
val)) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall {a} {a}. (ExtensionClass a, Typeable a) => a -> a
toValue a
val
            Just (Left String
str) | PersistentExtension a
x <- forall a. ExtensionClass a => a -> StateExtension
extensionType a
k -> do
                let val :: a
val = forall a. a -> Maybe a -> a
fromMaybe forall a. ExtensionClass a => a
initialValue forall a b. (a -> b) -> a -> b
$ forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall {a}. Read a => String -> Maybe a
safeRead String
str forall a. a -> a -> a
`asTypeOf` forall a. a -> Maybe a
Just a
x
                forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
put (a
val forall a. a -> a -> a
`asTypeOf` a
k)
                forall (m :: * -> *) a. Monad m => a -> m a
return a
val
            Maybe (Either String StateExtension)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. ExtensionClass a => a
initialValue
        safeRead :: String -> Maybe a
safeRead String
str = case forall a. Read a => ReadS a
reads String
str of
                         [(a
x,String
"")] -> forall a. a -> Maybe a
Just a
x
                         [(a, String)]
_ -> 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 = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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 = forall (m :: * -> *).
XLike m =>
(Map String (Either String StateExtension)
 -> Map String (Either String StateExtension))
-> m ()
modifyStateExts forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Map k a
M.delete (forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Typeable a => a -> TypeRep
typeOf 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 = forall a (m :: * -> *).
(ExtensionClass a, Eq a, XLike m) =>
(a -> m a) -> m Bool
modifiedM forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 <- forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
get
    a -> m a
f a
v forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        a
v' | a
v' forall a. Eq a => a -> a -> Bool
== a
v   -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
           | Bool
otherwise -> forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
put a
v' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True