From 5a0ce21e12e765125ad8068e919cf97b70df8257 Mon Sep 17 00:00:00 2001
From: Tom Smeding <t.j.smeding@uu.nl>
Date: Wed, 28 Aug 2024 16:10:58 +0200
Subject: Implement sorting of floated expressions

---
 src/Data/StableName/Extra.hs | 27 +++++++++++++++++++++++++++
 1 file changed, 27 insertions(+)

(limited to 'src/Data/StableName')

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)
-- 
cgit v1.2.3-70-g09d2