Implement sorting of floated expressions

1 files changed, 27 insertions, 0 deletions

diff --git a/src/Data/StableName/Extra.hs b/src/Data/StableName/Extra.hs
index f568740..cf37cfe 100644
--- a/src/Data/StableName/Extra.hs
+++ b/src/Data/StableName/Extra.hs
@@ -1,10 +1,16 @@
 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE ExistentialQuantification #-}
 {-# OPTIONS_GHC -fno-full-laziness -fno-cse #-}
 module Data.StableName.Extra (
   StableName,
   makeStableName',
+  showStableName,
 ) where
 
+import Data.Hashable
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HM
+import Data.IORef
 import GHC.StableName
 import System.IO.Unsafe
 
@@ -15,3 +21,24 @@ import System.IO.Unsafe
 {-# NOINLINE makeStableName' #-}
 makeStableName' :: a -> StableName a
 makeStableName' !x = unsafePerformIO (makeStableName x)
+
+
+data SomeStableName = forall a. SomeStableName (StableName a)
+
+instance Eq SomeStableName where
+  SomeStableName a == SomeStableName b = eqStableName a b
+
+instance Hashable SomeStableName where
+  hashWithSalt salt (SomeStableName name) = hashWithSalt salt name
+
+{-# NOINLINE showStableNameCache #-}
+showStableNameCache :: IORef (HashMap SomeStableName Int, Int)
+showStableNameCache = unsafePerformIO $ newIORef (mempty, 0)
+
+{-# NOINLINE showStableName #-}
+showStableName :: StableName a -> String
+showStableName name =
+  unsafePerformIO $ atomicModifyIORef' showStableNameCache $ \tup@(mp, nexti) ->
+    case HM.lookup (SomeStableName name) mp of
+      Just res -> (tup, '$' : show res)
+      Nothing -> ((HM.insert (SomeStableName name) nexti mp, nexti + 1), '$' : show nexti)