summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorMatthias Schiffer <mschiffer@universe-factory.net>2013-09-16 04:56:10 +0200
committerMatthias Schiffer <mschiffer@universe-factory.net>2013-09-16 04:56:10 +0200
commit655f1d7b6143886404c9da9fb4d5c73c782e987f (patch)
tree376987f234ce5bd4fad2ad8c218ed59d23f98a4c
parent52c2c3087eb181786aa226b16443ee987b20ac96 (diff)
downloadmetatile-655f1d7b6143886404c9da9fb4d5c73c782e987f.tar
metatile-655f1d7b6143886404c9da9fb4d5c73c782e987f.zip
Add Util.ExtensibleState module from XMonadContrib
-rw-r--r--MetaTile/Util/ExtensibleState.hs117
-rw-r--r--metatile.cabal2
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