diff options
| -rw-r--r-- | MetaTile/Util/ExtensibleState.hs | 117 | ||||
| -rw-r--r-- | metatile.cabal | 2 |
2 files changed, 119 insertions, 0 deletions
diff --git a/MetaTile/Util/ExtensibleState.hs b/MetaTile/Util/ExtensibleState.hs new file mode 100644 index 0000000..9aa7fab --- /dev/null +++ b/MetaTile/Util/ExtensibleState.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE PatternGuards #-} +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Util.ExtensibleState +-- 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 MetaTile.Util.ExtensibleState ( + -- * Usage + -- $usage + put + , modify + , remove + , get + , gets + ) where + +import Data.Typeable (typeOf,Typeable,cast) +import qualified Data.Map as M +import MetaTile.Core +import qualified Control.Monad.State as State +import Data.Maybe (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: +-- +-- > {-# LANGUAGE DeriveDataTypeable #-} +-- > import qualified XMonad.Util.ExtensibleState as XS +-- > +-- > data ListStorage = ListStorage [Integer] deriving Typeable +-- > 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 (Typeable,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 :: (M.Map String (Either String StateExtension) + -> M.Map String (Either String StateExtension)) + -> X () +modifyStateExts f = State.modify $ \st -> 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 => (a -> a) -> X () +modify f = put . f =<< 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 => a -> X () +put v = modifyStateExts . M.insert (show . typeOf $ v) . Right . extensionType $ v + +-- | Try to retrieve a value of the requested type, return an initial value if there is no such value. +get :: ExtensionClass a => X a +get = getState' undefined -- `trick' to avoid needing -XScopedTypeVariables + where toValue val = maybe initialValue id $ cast val + getState' :: ExtensionClass a => a -> X a + getState' k = do + v <- State.gets $ M.lookup (show . typeOf $ k) . extensibleState + case v of + Just (Right (StateExtension val)) -> return $ toValue val + Just (Right (PersistentExtension val)) -> return $ toValue val + Just (Left str) | PersistentExtension x <- extensionType k -> do + let val = fromMaybe initialValue $ cast =<< safeRead str `asTypeOf` Just x + put (val `asTypeOf` k) + return val + _ -> return $ initialValue + safeRead str = case reads str of + [(x,"")] -> Just x + _ -> Nothing + +gets :: ExtensionClass a => (a -> b) -> X b +gets = flip fmap get + +-- | Remove the value from the extensible state field that has the same type as the supplied argument +remove :: ExtensionClass a => a -> X () +remove wit = modifyStateExts $ M.delete (show . typeOf $ wit) diff --git a/metatile.cabal b/metatile.cabal index 89fc04a..da71120 100644 --- a/metatile.cabal +++ b/metatile.cabal @@ -41,6 +41,7 @@ library MetaTile.ManageHook MetaTile.Operations MetaTile.StackSet + MetaTile.Util.ExtensibleState build-depends: base < 5 && >=3, containers, directory, process, filepath, extensible-exceptions, X11>=1.5 && < 1.7, mtl, unix, @@ -70,6 +71,7 @@ executable metatile MetaTile.ManageHook MetaTile.Operations MetaTile.StackSet + MetaTile.Util.ExtensibleState if true ghc-options: -funbox-strict-fields -Wall |