aboutsummaryrefslogtreecommitdiff
path: root/src/Data/StableName
diff options
context:
space:
mode:
authorTom Smeding <t.j.smeding@uu.nl>2024-08-28 16:10:58 +0200
committerTom Smeding <t.j.smeding@uu.nl>2024-08-28 16:10:58 +0200
commit5a0ce21e12e765125ad8068e919cf97b70df8257 (patch)
treeed38cf21945c6a2b0434c23a35b3136935dbaf0e /src/Data/StableName
parent869be329dd05eede1dd1adb3c3b6ce2340074818 (diff)
Implement sorting of floated expressions
Diffstat (limited to 'src/Data/StableName')
-rw-r--r--src/Data/StableName/Extra.hs27
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)