Make extensibleState primarily keyed by TypeRep instead of type names

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/xmonad-contrib#94

CHANGES.md

@@ -65,6 +65,13 @@
     it easier for us to clean up the codebase. These can still be suppressed
     manually using an `OPTIONS_GHC` pragma with `-Wno-deprecations`.
 
+  * Extensible state type names no longer need to be unique, because the
+    `extensibleState` map in `XState` is now primarily keyed by the
+    machine-readable type representation rather than the human-readable type
+    name. Human-readable type names are still used for serialization of state
+    between restarts, and this representation now encodes module names as
+    well to avoid conflicts between types with equal names.
+
 ## 0.15 (September 30, 2018)
 
   * Reimplement `sendMessage` to deal properly with windowset changes made

src/XMonad/Core.hs

@@ -1,6 +1,13 @@
-{-# LANGUAGE ExistentialQuantification, FlexibleInstances, GeneralizedNewtypeDeriving,
-             MultiParamTypeClasses, TypeSynonymInstances, DeriveDataTypeable,
-             LambdaCase, NamedFieldPuns, DeriveTraversable #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE ViewPatterns #-}
 
 -----------------------------------------------------------------------------
 -- |
@@ -23,7 +30,7 @@ module XMonad.Core (
     XConf(..), XConfig(..), LayoutClass(..),
     Layout(..), readsLayout, Typeable, Message,
     SomeMessage(..), fromMessage, LayoutMessages(..),
-    StateExtension(..), ExtensionClass(..), ConfExtension(..),
+    StateExtension(..), ExtensionClass(..), ConfExtension(..), showExtType,
     runX, catchX, userCode, userCodeDef, io, catchIO, installSignalHandlers, uninstallSignalHandlers,
     withDisplay, withWindowSet, isRoot, runOnWorkspaces,
     getAtom, spawn, spawnPID, xfork, xmessage, recompile, trace, whenJust, whenX,
@@ -73,7 +80,7 @@ data XState = XState
     , waitingUnmap     :: !(M.Map Window Int)            -- ^ the number of expected UnmapEvents
     , dragging         :: !(Maybe (Position -> Position -> X (), X ()))
     , numberlockMask   :: !KeyMask                       -- ^ The numlock modifier
-    , extensibleState  :: !(M.Map String (Either String StateExtension))
+    , extensibleState  :: !(M.Map (Either String TypeRep) (Either String StateExtension))
     -- ^ stores custom state information.
     --
     -- The module "XMonad.Util.ExtensibleState" in xmonad-contrib
@@ -420,6 +427,20 @@ data StateExtension =
 -- | Existential type to store a config extension.
 data ConfExtension = forall a. Typeable a => ConfExtension a
 
+-- | Serialize extension type name.
+-- Produces a (more) unique representation than the Show instance of TypeRep
+-- which only includes type names but not module/package names. 'showExtType'
+-- adds modules names as well. Package names are omitted to support migration
+-- of extensible state during xmonad version upgrades.
+showExtType :: TypeRep -> String
+showExtType = ($ "") . showTypeRep
+  where
+    showTypeRep (splitTyConApp -> (tc, tas)) =
+        showParen (not (null tas)) $
+        showTyCon tc . foldr (\ta -> ((showChar ' ' . showTypeRep ta) .)) id tas
+    showTyCon tc =
+        showString (tyConModule tc) . showChar '.' . showString (tyConName tc)
+
 -- ---------------------------------------------------------------------
 -- | General utilities
 --

src/XMonad/Operations.hs

@@ -23,13 +23,13 @@ import qualified XMonad.StackSet as W
 import Data.Maybe
 import Data.Monoid          (Endo(..),Any(..))
 import Data.List            (nub, (\\), find)
+import Data.Bifunctor       (bimap)
 import Data.Bits            ((.|.), (.&.), complement, testBit)
 import Data.Function        (on)
 import Data.Ratio
 import qualified Data.Map as M
 import qualified Data.Set as S
 
-import Control.Arrow (second)
 import Control.Monad.Reader
 import Control.Monad.State
 import qualified Control.Exception as C
@@ -473,12 +473,12 @@ data StateFile = StateFile
 -- so that xmonad can resume with that state intact.
 writeStateToFile :: X ()
 writeStateToFile = do
-    let maybeShow (t, Right (PersistentExtension ext)) = Just (t, show ext)
-        maybeShow (t, Left str) = Just (t, str)
-        maybeShow _ = Nothing
+    let showExt (Right t, Right (PersistentExtension ext)) = Just (showExtType t, show ext)
+        showExt (Left t, Left str) = Just (t, str)
+        showExt _ = Nothing
 
         wsData   = W.mapLayout show . windowset
-        extState = catMaybes . map maybeShow . M.toList . extensibleState
+        extState = catMaybes . map showExt . M.toList . extensibleState
 
     path <- asks $ stateFileName . directories
     stateData <- gets (\s -> StateFile (wsData s) (extState s))
@@ -502,7 +502,7 @@ readStateFile xmc = do
       sf <- join sf'
 
       let winset = W.ensureTags layout (workspaces xmc) $ W.mapLayout (fromMaybe layout . maybeRead lreads) (sfWins sf)
-          extState = M.fromList . map (second Left) $ sfExt sf
+          extState = M.fromList . map (bimap Left Left) $ sfExt sf
 
       return XState { windowset       = winset
                     , numberlockMask  = 0