xmonad-contrib part of "Make extensibleState primarily keyed by TypeRep instead of type names"

XMonad/Util/ExtensibleState.hs

@@ -1,5 +1,10 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeOperators #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  XMonad.Util.ExtensibleState
@@ -24,14 +29,18 @@ module XMonad.Util.ExtensibleState (
                               , gets
                               , modified
                               , modifiedM
+
+#ifdef TESTING
+                              , upgrade
+#endif
                               ) where
 
-import Data.Typeable (typeOf,cast)
+import Data.Typeable
 import qualified Data.Map as M
 import XMonad.Core
 import XMonad.Util.PureX
 import qualified Control.Monad.State as State
-import XMonad.Prelude (fromMaybe)
+import XMonad.Prelude
 
 -- ---------------------------------------------------------------------
 -- $usage
@@ -76,14 +85,44 @@ import XMonad.Prelude (fromMaybe)
 -- trying to store the same data type without a wrapper.
 --
 
+type ExtensibleState = M.Map (Either String TypeRep) (Either String StateExtension)
+
 -- | 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 :: XLike m => (ExtensibleState -> ExtensibleState) -> m ()
 modifyStateExts f = State.modify $ \st -> st { extensibleState = f (extensibleState st) }
 
+upgrade :: (ExtensionClass a) => a -> ExtensibleState -> ExtensibleState
+upgrade wit
+    | PersistentExtension wip <- extensionType wit, Just Refl <- eqT' wit wip = upgradePersistent wit
+    | otherwise = id
+  where
+    eqT' :: (Typeable a, Typeable b) => a -> b -> Maybe (a :~: b)
+    eqT' _ _ = eqT
+
+upgradePersistent :: (ExtensionClass a, Read a, Show a) => a -> ExtensibleState -> ExtensibleState
+upgradePersistent wit = \m -> fromMaybe (neitherInsertInitial m) $
+    rightNoop m <|>                   -- already upgraded/deserialized
+    leftDecode (showExtType t) m <|>  -- deserialize
+    leftDecode (show t) m             -- upgrade from old representation and deserialize
+  where
+    t = typeOf wit
+    deserialize s = PersistentExtension $ fromMaybe initialValue (safeRead s) `asTypeOf` wit
+
+    pop k m = k `M.lookup` m <&> (, k `M.delete` m)
+    rightNoop m = do
+        _ <- Right t `M.lookup` m
+        pure m
+    leftDecode k m = do
+        (Left v, m') <- Left k `pop` m
+        pure $ M.insert (Right t) (Right (deserialize v)) m'
+    neitherInsertInitial =
+        M.insert (Right t) (Right (PersistentExtension (initialValue `asTypeOf` wit)))
+
+    safeRead :: Read a => String -> Maybe a
+    safeRead str = case reads str of
+        [(x, "")] -> Just x
+        _ -> Nothing
+
 -- | 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 ()
@@ -93,33 +132,25 @@ modify f = put . f =<< get
 -- 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 v = modifyStateExts . M.insert (show . typeOf $ v) . Right . extensionType $ v
+put v = modifyStateExts $ M.insert (Right (typeOf v)) (Right (extensionType v)) . upgrade 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 = getState' undefined -- `trick' to avoid needing -XScopedTypeVariables
-  where toValue val = fromMaybe initialValue $ cast val
-        getState' :: (ExtensionClass a, XLike m) => a -> m 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
+get :: forall a m. (ExtensionClass a, XLike m) => m a
+get = do
+    modifyStateExts $ upgrade wit
+    State.gets $ unwrap . M.lookup (Right (typeOf wit)) . extensibleState
+  where
+    wit = undefined :: a
+    unwrap (Just (Right (StateExtension v))) = fromMaybe initialValue (cast v)
+    unwrap (Just (Right (PersistentExtension v))) = fromMaybe initialValue (cast v)
+    unwrap _ = initialValue
 
 gets :: (ExtensionClass a, XLike m) => (a -> b) -> m 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, XLike m) => a -> m ()
-remove wit = modifyStateExts $ M.delete (show . typeOf $ wit)
+remove wit = modifyStateExts $ M.delete (Right (typeOf wit)) . upgrade wit
 
 modified :: (ExtensionClass a, Eq a, XLike m) => (a -> a) -> m Bool
 modified = modifiedM . (pure .)

stack-master.yaml

@@ -9,8 +9,8 @@ packages:
 extra-deps:
 - github: xmonad/X11
   commit: master@{today}
-- github: xmonad/xmonad
-  commit: master@{today}
+- github: liskin/xmonad
+  commit: ext-state-unique@{today}
 
 nix:
   packages:

tests/ExtensibleState.hs

@@ -0,0 +1,57 @@
+{-# LANGUAGE ViewPatterns #-}
+{-# OPTIONS_GHC -Wall #-}
+module ExtensibleState where
+
+import Test.Hspec
+
+import XMonad
+import Data.Typeable
+import qualified XMonad.Util.ExtensibleState as XS
+import qualified Data.Map as M
+
+data TestState = TestState Int deriving (Show, Read, Eq)
+instance ExtensionClass TestState where
+    initialValue = TestState 0
+
+data TestPersistent = TestPersistent Int deriving (Show, Read, Eq)
+instance ExtensionClass TestPersistent where
+    initialValue = TestPersistent 0
+    extensionType = PersistentExtension
+
+spec :: Spec
+spec = do
+    describe "upgrade of non-persistent" $
+        it "noop" $
+            M.keys (XS.upgrade (undefined :: TestState) mempty) `shouldBe` mempty
+    describe "upgrade of persistent" $ do
+        describe "inserts initial value if not found" $ do
+            let k = Right (typeOf (undefined :: TestPersistent))
+            let m = XS.upgrade (undefined :: TestPersistent) mempty
+            specify "keys" $ M.keys m `shouldBe` [k]
+            specify "value" $ assertRightPersistent k m (TestPersistent 0)
+        describe "noop if Right found" $ do
+            let k = Right (typeOf (undefined :: TestPersistent))
+            let m0 = M.singleton k (Right (PersistentExtension (TestPersistent 1)))
+            let m = XS.upgrade (undefined :: TestPersistent) m0
+            specify "keys" $ M.keys m `shouldBe` [k]
+            specify "value" $ assertRightPersistent k m (TestPersistent 1)
+        describe "deserialize" $ do
+            let k0 = Left "ExtensibleState.TestPersistent"
+            let m0 = M.singleton k0 (Left "TestPersistent 1")
+            let k = Right (typeOf (undefined :: TestPersistent))
+            let m = XS.upgrade (undefined :: TestPersistent) m0
+            specify "keys" $ M.keys m `shouldBe` [k]
+            specify "value" $ assertRightPersistent k m (TestPersistent 1)
+        describe "upgrade from old representation and deserialize" $ do
+            let k0 = Left "TestPersistent"
+            let m0 = M.singleton k0 (Left "TestPersistent 1")
+            let k = Right (typeOf (undefined :: TestPersistent))
+            let m = XS.upgrade (undefined :: TestPersistent) m0
+            specify "keys" $ M.keys m `shouldBe` [k]
+            specify "value" $ assertRightPersistent k m (TestPersistent 1)
+
+assertRightPersistent :: (Ord k, Typeable v, Show v, Eq v)
+                      => k -> M.Map k (Either String StateExtension) -> v -> Expectation
+assertRightPersistent k m v = case k `M.lookup` m of
+    Just (Right (PersistentExtension (cast -> Just x))) -> x `shouldBe` v
+    _ -> expectationFailure "unexpected"

tests/Main.hs

@@ -4,6 +4,7 @@ import Test.Hspec
 import Test.Hspec.QuickCheck
 
 import qualified ExtensibleConf
+import qualified ExtensibleState
 import qualified ManageDocks
 import qualified NoBorders
 import qualified RotateSome
@@ -48,6 +49,7 @@ main = hspec $ do
         prop "prop_skipGetLastWord"  XPrompt.prop_skipGetLastWord
     context "NoBorders"      NoBorders.spec
     context "ExtensibleConf" ExtensibleConf.spec
+    context "ExtensibleState" ExtensibleState.spec
     context "CycleRecentWS"  CycleRecentWS.spec
     context "OrgMode"        OrgMode.spec
     context "GridSelect"     GridSelect.spec

xmonad-contrib.cabal

@@ -58,7 +58,7 @@ library
                    mtl >= 1 && < 3,
                    unix,
                    X11 >= 1.10 && < 1.11,
-                   xmonad >= 0.16.99999 && < 0.18,
+                   xmonad >= 0.16.999999 && < 0.18,
                    utf8-string
 
     ghc-options:   -Wall -Wno-unused-do-bind
@@ -378,6 +378,7 @@ test-suite tests
   main-is:        Main.hs
   other-modules:  CycleRecentWS
                   ExtensibleConf
+                  ExtensibleState
                   GridSelect
                   Instances
                   ManageDocks