From 2d771b46379491ed736546ce0780dd3c450c3b3f Mon Sep 17 00:00:00 2001 From: Tomas Janousek Date: Thu, 2 Sep 2021 18:50:26 +0100 Subject: [PATCH] =?UTF-8?q?xmonad-contrib=20part=20of=20"Make=20extensible?= =?UTF-8?q?State=20primarily=20keyed=20by=20TypeRep=20=E2=80=A6"?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 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: https://github.com/xmonad/xmonad-contrib/issues/94 --- XMonad/Util/ExtensibleState.hs | 83 +++++++++++++++++++++++----------- tests/ExtensibleState.hs | 57 +++++++++++++++++++++++ tests/Main.hs | 2 + xmonad-contrib.cabal | 1 + 4 files changed, 117 insertions(+), 26 deletions(-) create mode 100644 tests/ExtensibleState.hs diff --git a/XMonad/Util/ExtensibleState.hs b/XMonad/Util/ExtensibleState.hs index e7628dc824..fb47c46e6b 100644 --- a/XMonad/Util/ExtensibleState.hs +++ b/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 .) diff --git a/tests/ExtensibleState.hs b/tests/ExtensibleState.hs new file mode 100644 index 0000000000..87b0d1c739 --- /dev/null +++ b/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" diff --git a/tests/Main.hs b/tests/Main.hs index 7712f9532a..139b8e899e 100644 --- a/tests/Main.hs +++ b/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 diff --git a/xmonad-contrib.cabal b/xmonad-contrib.cabal index f6c0a8db82..6ff7c91097 100644 --- a/xmonad-contrib.cabal +++ b/xmonad-contrib.cabal @@ -378,6 +378,7 @@ test-suite tests main-is: Main.hs other-modules: CycleRecentWS ExtensibleConf + ExtensibleState GridSelect Instances ManageDocks