xmonad-contrib part of "Make extensibleState primarily keyed by TypeR…

…ep …"

We've been using the String we get out of `show . typeOf` as key in
`extensibleState`, but that has a somewhat serious bug: it shows
unqualified type names, so if two modules use the same type name, their
extensible states will be stored in one place and get overwritten all
the time.

To fix this, the `extensibleState` map is now primarily keyed by the
TypeRep themselves, with fallback to String for not yet deserialized
data. XMonad.Core now exports `showExtType` which serializes type names
qualified, and this is used in `writeStateToFile`.

A simpler fix would be to just change the serialization of type names in
`XMonad.Util.ExtensibleState`, but I'm afraid that might slows things
down: Most types used here will start with "XMonad.", and that's a lot
of useless linked-list pointer jumping.

Fixes: xmonad#94

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 .)

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

@@ -378,6 +378,7 @@ test-suite tests
   main-is:        Main.hs
   other-modules:  CycleRecentWS
                   ExtensibleConf
+                  ExtensibleState
                   GridSelect
                   Instances
                   ManageDocks