hls-graph - avoid duplicating key texts

Author: wz1000

ghcide/src/Development/IDE/Core/Shake.hs

@@ -1207,7 +1207,7 @@ updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnosti
         addTagUnsafe :: String -> String -> String -> a -> a
         addTagUnsafe msg t x v = unsafePerformIO(addTag (msg <> t) x) `seq` v
         update :: (forall a. String -> String -> a -> a) -> [Diagnostic] -> STMDiagnosticStore -> STM [Diagnostic]
-        update addTagUnsafe new store = addTagUnsafe "count" (show $ Prelude.length new) $ setStageDiagnostics addTagUnsafe uri ver (T.pack $ show k) new store
+        update addTagUnsafe new store = addTagUnsafe "count" (show $ Prelude.length new) $ setStageDiagnostics addTagUnsafe uri ver (renderKey k) new store
     addTag "version" (show ver)
     mask_ $ do
         -- Mask async exceptions to ensure that updated diagnostics are always

hls-graph/hls-graph.cabal

@@ -82,6 +82,7 @@ library
     , transformers
     , unliftio
     , unordered-containers
+    , text
 
   if flag(embed-files)
         cpp-options: -DFILE_EMBED

hls-graph/src/Development/IDE/Graph.hs

@@ -4,7 +4,7 @@ module Development.IDE.Graph(
     Rules,
     Action, action,
     Key(.., Key),
-    newKey,
+    newKey, renderKey,
     actionFinally, actionBracket, actionCatch, actionFork,
     -- * Configuration
     ShakeOptions(shakeAllowRedefineRules, shakeExtra),

hls-graph/src/Development/IDE/Graph/Internal/Types.hs

@@ -25,6 +25,8 @@ import qualified Data.HashMap.Strict           as Map
 import           Data.HashSet                  (HashSet, member)
 import qualified Data.IntMap                   as IM
 import qualified Data.HashSet                  as Set
+import qualified Data.Text                     as T
+import           Data.Text                     (Text)
 import           Data.IORef
 import           Data.List                     (intercalate)
 import           Data.Maybe
@@ -86,11 +88,11 @@ newtype Step = Step Int
 ---------------------------------------------------------------------
 -- Keys
 
-data KeyValue = forall a . (Typeable a, Hashable a, Show a) => KeyValue a
+data KeyValue = forall a . (Typeable a, Hashable a, Show a) => KeyValue a Text
 
 newtype Key = UnsafeMkKey Int
 
-pattern Key a <- (lookupKeyValue -> KeyValue a)
+pattern Key a <- (lookupKeyValue -> KeyValue a _)
 
 data KeyMap = KeyMap !(Map.HashMap KeyValue Key) !(IM.IntMap KeyValue) {-# UNPACK #-} !Int
 
@@ -101,7 +103,7 @@ keyMap = unsafePerformIO $ newIORef (KeyMap Map.empty IM.empty 0)
 
 newKey :: (Typeable a, Hashable a, Show a) => a -> Key
 newKey k = unsafePerformIO $ do
-  let !newKey = KeyValue k
+  let !newKey = KeyValue k (T.pack (show k))
   atomicModifyIORef' keyMap $ \km@(KeyMap hm im n) ->
     let new_key = Map.lookup newKey hm
     in case new_key of
@@ -126,11 +128,14 @@ instance Show Key where
   show (Key x) = show x
 
 instance Eq KeyValue where
-    KeyValue a == KeyValue b = Just a == cast b
+    KeyValue a _ == KeyValue b _ = Just a == cast b
 instance Hashable KeyValue where
-    hashWithSalt i (KeyValue x) = hashWithSalt i (typeOf x, x)
+    hashWithSalt i (KeyValue x _) = hashWithSalt i (typeOf x, x)
 instance Show KeyValue where
-    show (KeyValue x) = show x
+    show (KeyValue x t) = T.unpack t
+
+renderKey :: Key -> Text
+renderKey (lookupKeyValue -> KeyValue _ t) = t
 
 newtype Value = Value Dynamic