From 0048ab5c859ba8345e31e3ebdf8f846b134b5856 Mon Sep 17 00:00:00 2001
From: parsonsmatt <parsonsmatt@gmail.com>
Date: Mon, 2 Jun 2025 11:45:21 -0600
Subject: [PATCH 01/11] Stricter VectorState

---
 .gitignore                                    |  3 ++-
 .../src/Prometheus/Metric/Vector.hs           | 27 +++++++++++--------
 2 files changed, 18 insertions(+), 12 deletions(-)

diff --git a/.gitignore b/.gitignore
index 10c1a6e..9914019 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,7 +1,8 @@
 dist/
+dist-newstyle/
 .cabal-sandbox/
 cabal.sandbox.config
 cabal.config
 .stack-work
 */*.yaml.lock
-.devcontainer
\ No newline at end of file
+.devcontainer
diff --git a/prometheus-client/src/Prometheus/Metric/Vector.hs b/prometheus-client/src/Prometheus/Metric/Vector.hs
index 117cc84..d06c9e0 100644
--- a/prometheus-client/src/Prometheus/Metric/Vector.hs
+++ b/prometheus-client/src/Prometheus/Metric/Vector.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE BangPatterns #-}
+
 module Prometheus.Metric.Vector (
     Vector (..)
 ,   vector
@@ -20,7 +22,10 @@ import qualified Data.Text as T
 import Data.Traversable (forM)
 
 
-type VectorState l m = (Metric m, Map.Map l (m, IO [SampleGroup]))
+data VectorState l m = VectorState
+    { vectorStateMetric :: !(Metric m)
+    , vectorStateMetricMap :: !(Map.Map l (m, IO [SampleGroup]))
+    }
 
 data Vector l m = MkVector (IORef.IORef (VectorState l m))
 
@@ -30,7 +35,7 @@ instance NFData (Vector l m) where
 -- | Creates a new vector of metrics given a label.
 vector :: Label l => l -> Metric m -> Metric (Vector l m)
 vector labels gen = Metric $ do
-    ioref <- checkLabelKeys labels $ IORef.newIORef (gen, Map.empty)
+    ioref <- checkLabelKeys labels $ IORef.newIORef $ VectorState gen Map.empty
     return (MkVector ioref, collectVector labels ioref)
 
 checkLabelKeys :: Label l => l -> a -> a
@@ -58,7 +63,7 @@ checkLabelKeys keys r = foldl check r $ map (T.unpack . fst) $ labelPairs keys k
 -- It is not clear that this will always be a valid assumption.
 collectVector :: Label l => l -> IORef.IORef (VectorState l m) -> IO [SampleGroup]
 collectVector keys ioref = do
-    (_, metricMap) <- IORef.readIORef ioref
+    VectorState _ metricMap <- IORef.readIORef ioref
     joinSamples <$> concat <$> mapM collectInner (Map.assocs metricMap)
     where
         collectInner (labels, (_metric, sampleGroups)) =
@@ -80,7 +85,7 @@ getVectorWith :: Vector label metric
               -> (metric -> IO a)
               -> IO [(label, a)]
 getVectorWith (MkVector valueTVar) f = do
-    (_, metricMap) <- IORef.readIORef valueTVar
+    VectorState _ metricMap <- IORef.readIORef valueTVar
     Map.assocs <$> forM metricMap (f . fst)
 
 -- | Given a label, applies an operation to the corresponding metric in the
@@ -91,26 +96,26 @@ withLabel :: (Label label, MonadMonitor m)
           -> (metric -> IO ())
           -> m ()
 withLabel (MkVector ioref) label f = doIO $ do
-    (Metric gen, _) <- IORef.readIORef ioref
+    VectorState (Metric gen) _ <- IORef.readIORef ioref
     newMetric <- gen
-    metric <- Atomics.atomicModifyIORefCAS ioref $ \(_, metricMap) ->
+    (metric, !newVectorState) <- Atomics.atomicModifyIORefCAS ioref $ \(VectorState _ metricMap) ->
         let maybeMetric = Map.lookup label metricMap
             updatedMap  = Map.insert label newMetric metricMap
         in  case maybeMetric of
-                Nothing     -> ((Metric gen, updatedMap), newMetric)
-                Just metric -> ((Metric gen, metricMap), metric)
-    f (fst metric)
+                Nothing     -> (VectorState (Metric gen) updatedMap, newMetric)
+                Just metric -> (VectorState (Metric gen) metricMap, metric)
+    f metric
 
 -- | Removes a label from a vector.
 removeLabel :: (Label label, MonadMonitor m)
             => Vector label metric -> label -> m ()
 removeLabel (MkVector valueTVar) label =
     doIO $ Atomics.atomicModifyIORefCAS_ valueTVar f
-    where f (desc, metricMap) = (desc, Map.delete label metricMap)
+    where f (VectorState desc metricMap) = VectorState desc (Map.delete label metricMap)
 
 -- | Removes all labels from a vector.
 clearLabels :: (Label label, MonadMonitor m)
             => Vector label metric -> m ()
 clearLabels (MkVector valueTVar) =
     doIO $ Atomics.atomicModifyIORefCAS_ valueTVar f
-    where f (desc, _) = (desc, Map.empty)
+    where f (VectorState desc _) = VectorState desc Map.empty

From 97e7cf652140bbe6c2bba70a3c82faaee1628282 Mon Sep 17 00:00:00 2001
From: parsonsmatt <parsonsmatt@gmail.com>
Date: Tue, 10 Jun 2025 08:38:15 -0600
Subject: [PATCH 02/11] LabelPairs

---
 .gitignore                                    |  3 +-
 .../src/Prometheus/Export/Text.hs             |  7 ++--
 prometheus-client/src/Prometheus/Label.hs     | 38 +++++++++++--------
 prometheus-client/src/Prometheus/Metric.hs    |  6 +--
 .../src/Prometheus/Metric/Counter.hs          |  4 +-
 .../src/Prometheus/Metric/Gauge.hs            |  4 +-
 .../src/Prometheus/Metric/Histogram.hs        |  9 +++--
 .../src/Prometheus/Metric/Summary.hs          | 21 +++++-----
 .../src/Prometheus/Metric/Vector.hs           |  4 +-
 9 files changed, 54 insertions(+), 42 deletions(-)

diff --git a/.gitignore b/.gitignore
index 10c1a6e..9914019 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,7 +1,8 @@
 dist/
+dist-newstyle/
 .cabal-sandbox/
 cabal.sandbox.config
 cabal.config
 .stack-work
 */*.yaml.lock
-.devcontainer
\ No newline at end of file
+.devcontainer
diff --git a/prometheus-client/src/Prometheus/Export/Text.hs b/prometheus-client/src/Prometheus/Export/Text.hs
index 4cb1019..674e609 100644
--- a/prometheus-client/src/Prometheus/Export/Text.hs
+++ b/prometheus-client/src/Prometheus/Export/Text.hs
@@ -4,6 +4,7 @@ module Prometheus.Export.Text (
     exportMetricsAsText
 ) where
 
+import Prometheus.Label (unLabelPairs, LabelPair(..))
 import Prometheus.Info
 import Prometheus.Metric
 import Prometheus.Registry
@@ -65,7 +66,7 @@ exportSamples samples =
 exportSample :: Sample -> Build.Builder
 exportSample (Sample name labels value) =
   Build.byteString (T.encodeUtf8 name)
-    <> (case labels of
+    <> (case unLabelPairs labels of
          [] -> mempty
          l:ls ->
            Build.charUtf8 '{'
@@ -75,8 +76,8 @@ exportSample (Sample name labels value) =
     <> Build.charUtf8 ' '
     <> Build.byteString value
 
-exportLabel :: (Text, Text) -> Build.Builder
-exportLabel (key, value) =
+exportLabel :: LabelPair -> Build.Builder
+exportLabel LabelPair { labelKey = key, labelValue = value } =
   Build.byteString (T.encodeUtf8 key)
     <> Build.charUtf8 '='
     <> Build.stringUtf8 (show value)
diff --git a/prometheus-client/src/Prometheus/Label.hs b/prometheus-client/src/Prometheus/Label.hs
index 4067e21..957b638 100644
--- a/prometheus-client/src/Prometheus/Label.hs
+++ b/prometheus-client/src/Prometheus/Label.hs
@@ -1,9 +1,12 @@
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE GADTs #-}
 
 module Prometheus.Label (
     Label (..)
-,   LabelPairs
+,   LabelPairs(..)
+,   LabelPair(..)
 ,   Label0
 ,   Label1
 ,   Label2
@@ -20,7 +23,12 @@ import Data.Text
 
 -- | A list of tuples where the first value is the label and the second is the
 -- value of that label.
-type LabelPairs = [(Text, Text)]
+newtype LabelPairs = LabelPairs { unLabelPairs :: [LabelPair] }
+    deriving stock Show
+    deriving newtype (Semigroup, Monoid)
+
+data LabelPair = LabelPair { labelKey :: !Text, labelValue :: !Text }
+    deriving stock Show
 
 -- | Label describes a class of types that can be used to as the label of
 -- a vector.
@@ -30,55 +38,55 @@ class Ord l => Label l where
 type Label0 = ()
 
 instance Label () where
-    labelPairs () () = []
+    labelPairs () () = LabelPairs mempty
 
 type Label1 = Text
 
 instance Label Text where
-    labelPairs key value = [(key, value)]
+    labelPairs key value = LabelPairs [LabelPair key value]
 
 type Label2 = (Text, Text)
 
 instance (a ~ Text, b ~ a) => Label (a, b)  where
-    labelPairs (k1, k2) (v1, v2) = [(k1, v1), (k2, v2)]
+    labelPairs (k1, k2) (v1, v2) = LabelPairs [LabelPair k1 v1, LabelPair k2 v2]
 
 type Label3 = (Text, Text, Text)
 
 instance (a ~ Text, b ~ a, c ~ a) => Label (a, b, c)  where
-    labelPairs (k1, k2, k3) (v1, v2, v3) = [(k1, v1), (k2, v2), (k3, v3)]
+    labelPairs (k1, k2, k3) (v1, v2, v3) = LabelPairs [LabelPair k1 v1, LabelPair k2 v2, LabelPair k3 v3]
 
 type Label4 = (Text, Text, Text, Text)
 
 instance (a ~ Text, b ~ a, c ~ a, d ~ a) => Label (a, b, c, d)  where
     labelPairs (k1, k2, k3, k4) (v1, v2, v3, v4) =
-            [(k1, v1), (k2, v2), (k3, v3), (k4, v4)]
+            LabelPairs [LabelPair k1 v1, LabelPair k2 v2, LabelPair k3 v3, LabelPair k4 v4]
 
 type Label5 = (Text, Text, Text, Text, Text)
 
 instance (a ~ Text, b ~ a, c ~ a, d ~ a, e ~ a) => Label (a, b, c, d, e)  where
     labelPairs (k1, k2, k3, k4, k5) (v1, v2, v3, v4, v5) =
-            [(k1, v1), (k2, v2), (k3, v3), (k4, v4), (k5, v5)]
+            LabelPairs [LabelPair k1 v1, LabelPair k2 v2, LabelPair k3 v3, LabelPair k4 v4, LabelPair k5 v5]
 
 type Label6 = (Text, Text, Text, Text, Text, Text)
 
 instance (a ~ Text, b ~ a, c ~ a, d ~ a, e ~ a, f ~ a) => Label (a, b, c, d, e, f)  where
     labelPairs (k1, k2, k3, k4, k5, k6) (v1, v2, v3, v4, v5, v6) =
-            [(k1, v1), (k2, v2), (k3, v3), (k4, v4), (k5, v5), (k6, v6)]
+            LabelPairs [LabelPair k1 v1, LabelPair k2 v2, LabelPair k3 v3, LabelPair k4 v4, LabelPair k5 v5, LabelPair k6 v6]
 
 type Label7 = (Text, Text, Text, Text, Text, Text, Text)
 
 instance (a ~ Text, b ~ a, c ~ a, d ~ a, e ~ a, f ~ a, g ~ a) => Label (a, b, c, d, e, f, g)  where
     labelPairs (k1, k2, k3, k4, k5, k6, k7) (v1, v2, v3, v4, v5, v6, v7) =
-            [(k1, v1), (k2, v2), (k3, v3), (k4, v4), (k5, v5), (k6, v6),
-             (k7, v7)]
+            LabelPairs [LabelPair k1 v1, LabelPair k2 v2, LabelPair k3 v3, LabelPair k4 v4, LabelPair k5 v5, LabelPair k6 v6,
+             LabelPair k7 v7]
 
 type Label8 = (Text, Text, Text, Text, Text, Text, Text, Text)
 
 instance (a ~ Text, b ~ a, c ~ a, d ~ a, e ~ a, f ~ a, g ~ a, h ~ a) => Label (a, b, c, d, e, f, g, h) where
     labelPairs (k1, k2, k3, k4, k5, k6, k7, k8)
                (v1, v2, v3, v4, v5, v6, v7, v8) =
-            [(k1, v1), (k2, v2), (k3, v3), (k4, v4), (k5, v5), (k6, v6),
-             (k7, v7), (k8, v8)]
+            LabelPairs [LabelPair k1 v1, LabelPair k2 v2, LabelPair k3 v3, LabelPair k4 v4, LabelPair k5 v5, LabelPair k6 v6,
+             LabelPair k7 v7, LabelPair k8 v8]
 
 type Label9 = (Text, Text, Text, Text, Text, Text, Text, Text,
                Text)
@@ -86,5 +94,5 @@ type Label9 = (Text, Text, Text, Text, Text, Text, Text, Text,
 instance (a ~ Text, b ~ a, c ~ a, d ~ a, e ~ a, f ~ a, g ~ a, h ~ a, i ~ a) => Label (a, b, c, d, e, f, g, h, i) where
     labelPairs (k1, k2, k3, k4, k5, k6, k7, k8, k9)
                (v1, v2, v3, v4, v5, v6, v7, v8, v9) =
-            [(k1, v1), (k2, v2), (k3, v3), (k4, v4), (k5, v5), (k6, v6),
-             (k7, v7), (k8, v8), (k9, v9)]
+            LabelPairs [LabelPair k1 v1, LabelPair k2 v2, LabelPair k3 v3, LabelPair k4 v4, LabelPair k5 v5, LabelPair k6 v6,
+             LabelPair k7 v7, LabelPair k8 v8, LabelPair k9 v9]
diff --git a/prometheus-client/src/Prometheus/Metric.hs b/prometheus-client/src/Prometheus/Metric.hs
index f3cbfbc..317ca96 100644
--- a/prometheus-client/src/Prometheus/Metric.hs
+++ b/prometheus-client/src/Prometheus/Metric.hs
@@ -34,12 +34,12 @@ instance Show SampleType where
 -- | A single value recorded at a moment in time. The sample type contains the
 -- name of the sample, a list of labels and their values, and the value encoded
 -- as a ByteString.
-data Sample = Sample Text LabelPairs BS.ByteString
+data Sample = Sample !Text !LabelPairs !BS.ByteString
     deriving (Show)
 
 -- | A Sample group is a list of samples that is tagged with meta data
 -- including the name, help string, and type of the sample.
-data SampleGroup = SampleGroup Info SampleType [Sample]
+data SampleGroup = SampleGroup !Info !SampleType [Sample]
     deriving (Show)
 
 -- | A metric represents a single value that is being monitored. It is comprised
@@ -58,7 +58,7 @@ newtype Metric s =
       --    metric. A counter would return state pointing to the mutable
       --    reference.
       -- 2. An 'IO' action that samples the metric and returns 'SampleGroup's.
-      --    This is the data that will be stored by Prometheus. 
+      --    This is the data that will be stored by Prometheus.
       construct :: IO (s, IO [SampleGroup])
     }
 
diff --git a/prometheus-client/src/Prometheus/Metric/Counter.hs b/prometheus-client/src/Prometheus/Metric/Counter.hs
index 239a2e9..6a29512 100644
--- a/prometheus-client/src/Prometheus/Metric/Counter.hs
+++ b/prometheus-client/src/Prometheus/Metric/Counter.hs
@@ -67,7 +67,7 @@ unsafeAddCounter c x = do
 addDurationToCounter :: (MonadIO m, MonadMonitor m) => Counter -> m a -> m a
 addDurationToCounter metric io = do
     (result, duration) <- timeAction io
-    _ <- addCounter metric duration 
+    _ <- addCounter metric duration
     return result
 
 -- | Retrieves the current value of a counter metric.
@@ -77,7 +77,7 @@ getCounter (MkCounter ioref) = liftIO $ IORef.readIORef ioref
 collectCounter :: Info -> IORef.IORef Double -> IO [SampleGroup]
 collectCounter info c = do
     value <- IORef.readIORef c
-    let sample = Sample (metricName info) [] (BS.fromString $ show value)
+    let sample = Sample (metricName info) mempty (BS.fromString $ show value)
     return [SampleGroup info CounterType [sample]]
 
 -- | Count the amount of times an action throws any synchronous exception.
diff --git a/prometheus-client/src/Prometheus/Metric/Gauge.hs b/prometheus-client/src/Prometheus/Metric/Gauge.hs
index c0fd80f..8a3d043 100644
--- a/prometheus-client/src/Prometheus/Metric/Gauge.hs
+++ b/prometheus-client/src/Prometheus/Metric/Gauge.hs
@@ -71,11 +71,11 @@ getGauge (MkGauge ioref) = liftIO $ IORef.readIORef ioref
 setGaugeToDuration :: (MonadIO m, MonadMonitor m) => Gauge -> m a -> m a
 setGaugeToDuration metric io = do
     (result, duration) <- timeAction io
-    setGauge metric duration 
+    setGauge metric duration
     return result
 
 collectGauge :: Info -> IORef.IORef Double -> IO [SampleGroup]
 collectGauge info c = do
     value <- IORef.readIORef c
-    let sample = Sample (metricName info) [] (BS.fromString $ show value)
+    let sample = Sample (metricName info) mempty (BS.fromString $ show value)
     return [SampleGroup info GaugeType [sample]]
diff --git a/prometheus-client/src/Prometheus/Metric/Histogram.hs b/prometheus-client/src/Prometheus/Metric/Histogram.hs
index e99da74..14c0325 100644
--- a/prometheus-client/src/Prometheus/Metric/Histogram.hs
+++ b/prometheus-client/src/Prometheus/Metric/Histogram.hs
@@ -16,6 +16,7 @@ module Prometheus.Metric.Histogram (
 ,   getHistogram
 ) where
 
+import Prometheus.Label (labelPairs)
 import Prometheus.Info
 import Prometheus.Metric
 import Prometheus.Metric.Observer
@@ -101,14 +102,14 @@ insert value BucketCounts { histTotal = total, histCount = count, histCountsPerB
 collectHistogram :: Info -> STM.TVar BucketCounts -> IO [SampleGroup]
 collectHistogram info bucketCounts = STM.atomically $ do
     BucketCounts total count counts <- STM.readTVar bucketCounts
-    let sumSample = Sample (name <> "_sum") [] (bsShow total)
-    let countSample = Sample (name <> "_count") [] (bsShow count)
-    let infSample = Sample (name <> "_bucket") [(bucketLabel, "+Inf")] (bsShow count)
+    let sumSample = Sample (name <> "_sum") mempty (bsShow total)
+    let countSample = Sample (name <> "_count") mempty (bsShow count)
+    let infSample = Sample (name <> "_bucket") (labelPairs bucketLabel "+Inf") (bsShow count)
     let samples = map toSample (cumulativeSum (Map.toAscList counts))
     return [SampleGroup info HistogramType $ samples ++ [infSample, sumSample, countSample]]
     where
         toSample (upperBound, count') =
-            Sample (name <> "_bucket") [(bucketLabel, formatFloat upperBound)] $ bsShow count'
+            Sample (name <> "_bucket") (labelPairs bucketLabel (formatFloat upperBound)) $ bsShow count'
         name = metricName info
 
         -- We don't particularly want scientific notation, so force regular
diff --git a/prometheus-client/src/Prometheus/Metric/Summary.hs b/prometheus-client/src/Prometheus/Metric/Summary.hs
index dcc5b5d..e0cddab 100644
--- a/prometheus-client/src/Prometheus/Metric/Summary.hs
+++ b/prometheus-client/src/Prometheus/Metric/Summary.hs
@@ -10,6 +10,7 @@ module Prometheus.Metric.Summary (
 ,   getSummary
 ) where
 
+import Prometheus.Label (labelPairs)
 import Prometheus.Info
 import Prometheus.Metric
 import Prometheus.Metric.Observer
@@ -40,13 +41,13 @@ instance NFData Summary where
 
 type Quantile = (Rational, Rational)
 
--- | K is a parameter divisible by two, in the range 4-1024 used in the RelativeErrorQuantile algorithm to 
+-- | K is a parameter divisible by two, in the range 4-1024 used in the RelativeErrorQuantile algorithm to
 -- determine how many items must be retained per compaction section. As the value increases, the accuracy
--- of the sketch increases as well. This function iterates on the k value starting from 6 
--- (conservative on space, but reasonably accurate) until it finds a K value that satisfies the specified 
--- error bounds for the given quantile. Note: this algorithm maintains highest accuracy for the upper tail 
--- of the quantile when passed the 'HighRanksAreAccurate', sampling out more items at lower ranks during 
--- the compaction process. Thus, extremely tight error bounds on low quantile values may cause this 
+-- of the sketch increases as well. This function iterates on the k value starting from 6
+-- (conservative on space, but reasonably accurate) until it finds a K value that satisfies the specified
+-- error bounds for the given quantile. Note: this algorithm maintains highest accuracy for the upper tail
+-- of the quantile when passed the 'HighRanksAreAccurate', sampling out more items at lower ranks during
+-- the compaction process. Thus, extremely tight error bounds on low quantile values may cause this
 -- function to return 'Nothing'.
 --
 -- If another smart constructor was exposed for summary creation, specific k values & LowRanksAreAccurate
@@ -93,8 +94,8 @@ collectSummary info (MkSummary sketchVar quantiles_) = withMVar sketchVar $ \ske
     count_ <- ReqSketch.count sketch
     estimatedQuantileValues <- forM quantiles_ $ \qv ->
       (,) <$> pure (fst qv) <*> ReqSketch.quantile sketch (toDouble $ fst qv)
-    let sumSample = Sample (metricName info <> "_sum") [] (bsShow itemSum)
-    let countSample = Sample (metricName info <> "_count") [] (bsShow count_)
+    let sumSample = Sample (metricName info <> "_sum") mempty (bsShow itemSum)
+    let countSample = Sample (metricName info <> "_count") mempty (bsShow count_)
     return [SampleGroup info SummaryType $ map toSample estimatedQuantileValues ++ [sumSample, countSample]]
     where
         bsShow :: Show s => s -> BS.ByteString
@@ -102,11 +103,11 @@ collectSummary info (MkSummary sketchVar quantiles_) = withMVar sketchVar $ \ske
 
         toSample :: (Rational, Double) -> Sample
         toSample (q, estimatedValue) =
-            Sample (metricName info) [("quantile", T.pack . show $ toDouble q)] $
+            Sample (metricName info) (labelPairs "quantile" (T.pack . show $ toDouble q)) $
                 bsShow estimatedValue
 
         toDouble :: Rational -> Double
         toDouble = fromRational
 
 defaultQuantiles :: [Quantile]
-defaultQuantiles = [(0.5, 0.05), (0.9, 0.01), (0.99, 0.001)]
\ No newline at end of file
+defaultQuantiles = [(0.5, 0.05), (0.9, 0.01), (0.99, 0.001)]
diff --git a/prometheus-client/src/Prometheus/Metric/Vector.hs b/prometheus-client/src/Prometheus/Metric/Vector.hs
index 117cc84..f9d0871 100644
--- a/prometheus-client/src/Prometheus/Metric/Vector.hs
+++ b/prometheus-client/src/Prometheus/Metric/Vector.hs
@@ -34,7 +34,7 @@ vector labels gen = Metric $ do
     return (MkVector ioref, collectVector labels ioref)
 
 checkLabelKeys :: Label l => l -> a -> a
-checkLabelKeys keys r = foldl check r $ map (T.unpack . fst) $ labelPairs keys keys
+checkLabelKeys keys r = foldl check r $ map (T.unpack . labelKey) $ unLabelPairs $ labelPairs keys keys
     where
         check _ "instance" = error "The label 'instance' is reserved."
         check _ "job"      = error "The label 'job' is reserved."
@@ -68,7 +68,7 @@ collectVector keys ioref = do
             SampleGroup info ty (map (prependLabels labels) samples)
 
         prependLabels l (Sample name labels value) =
-            Sample name (labelPairs keys l ++ labels) value
+            Sample name (labelPairs keys l <> labels) value
 
         joinSamples []                      = []
         joinSamples s@(SampleGroup i t _:_) = [SampleGroup i t (extract s)]

From 80c19799c1eb9d8505629a08ff45da63c2783d19 Mon Sep 17 00:00:00 2001
From: parsonsmatt <parsonsmatt@gmail.com>
Date: Tue, 10 Jun 2025 08:38:23 -0600
Subject: [PATCH 03/11] docs

---
 prometheus-client/docs/memory-use.md | 24 ++++++++++++++++++++++++
 1 file changed, 24 insertions(+)
 create mode 100644 prometheus-client/docs/memory-use.md

diff --git a/prometheus-client/docs/memory-use.md b/prometheus-client/docs/memory-use.md
new file mode 100644
index 0000000..43a5248
--- /dev/null
+++ b/prometheus-client/docs/memory-use.md
@@ -0,0 +1,24 @@
+# Investigating Memory Use in `prometheus-client`
+
+We're runnig into problems with unexpectedly high memory use in `prometheus-client`, so I've been investigating improving the behavior.
+
+Specifically, we're notificing a significant increase in the amount of time and memory allocated while calling `exportMetricsToText`.
+Every time we call the endpoint, more and more memory is used to render the response.
+There are two reasonable possibilities for this:
+
+1. The `exportMetricsToText` is producing a significantly larger `Text` value, which naturally requires significantly more memory.
+2. The metrics themselves are somehow holding on to excessive memory or thunks.
+
+Diagnosing this in our application is difficult - our profiling build is currently broken.
+So I'm currently just looking at the code and correcting known smells.
+
+## `LabelPairs`
+
+The `LabelPairs` type was a `[(Text, Text)]`.
+Lists and tuples are both known sources of potential laziness issues.
+As a first pass, I replaced the type with a `newtype` so I could control the API for accessing and adding entries.
+Then I replaced the tuple with a `data LabelPair = LabelPair { labelKey :: !Text, labelValue :: !Text }`.
+This should prevent thunk accumulation for labels, and the concrete type may enable further memory improvement from GHC.
+
+The fields on `Sample` are made strict, as well.
+This should prevent thunk accumulation on the `Text` and `ByteString`, but a lazy `LabelPairs` is still possible.

From b89033fd1e297defdf63bf6bf9c2cd1a3f43791d Mon Sep 17 00:00:00 2001
From: parsonsmatt <parsonsmatt@gmail.com>
Date: Tue, 10 Jun 2025 08:56:39 -0600
Subject: [PATCH 04/11] more stuff

---
 prometheus-client/docs/memory-use.md          | 28 +++++++++++++++++++
 prometheus-client/src/Prometheus/Label.hs     | 24 ++++++++--------
 prometheus-client/src/Prometheus/Metric.hs    |  8 +++++-
 .../src/Prometheus/Metric/Counter.hs          |  2 +-
 .../src/Prometheus/Metric/Gauge.hs            |  2 +-
 .../src/Prometheus/Metric/Histogram.hs        |  2 +-
 .../src/Prometheus/Metric/Summary.hs          |  2 +-
 .../src/Prometheus/Metric/Vector.hs           | 10 +++----
 prometheus-client/src/Prometheus/Registry.hs  |  2 +-
 9 files changed, 58 insertions(+), 22 deletions(-)

diff --git a/prometheus-client/docs/memory-use.md b/prometheus-client/docs/memory-use.md
index 43a5248..499e5e0 100644
--- a/prometheus-client/docs/memory-use.md
+++ b/prometheus-client/docs/memory-use.md
@@ -22,3 +22,31 @@ This should prevent thunk accumulation for labels, and the concrete type may ena
 
 The fields on `Sample` are made strict, as well.
 This should prevent thunk accumulation on the `Text` and `ByteString`, but a lazy `LabelPairs` is still possible.
+
+Additionally, the `labelPairs` function now uses bang patterns on each `Text` in the tuple.
+Since this is the whole of the interface for constructing a `LabelPair`, this should prevent any thunk accumulation on labels.
+
+## `MetricImpl`
+
+A `Metric` had a field `construct :: IO (s, IO [SampleGroup])`.
+To avoid tuple, we introduce `MetricImpl s` which uses bang patterns on the fields.
+
+In practice, the `MetricImpl s` is almost always instantiated to a reference type, and evaluating a reference doesn't do much to help.
+I did find the clarity in names helpful.
+
+## `VectorState`
+
+A `Prometheus.Metric.Vector` previously was defined as:
+
+```haskell
+type VectorState l m = (Metric m, Map.Map l (m, IO [SampleGroup]))
+```
+
+This `VectorSTate` was being stored in an `IORef`.
+While the operation was evaluating the `VectorState` to WHNF, this only evaluated the tuple constructor, leaving the `Metric` and `Map.Map` unevaluated.
+The `Map` is from `Data.Map.Strict`, which means that the values are evaluated to WHNF.
+Methods from that module evaluate the structure of the `Map`, but polymorphic methods (ie `Functor`, `Traversable`) *do not*.
+
+We can reduce the possibility of memory leaks here by replacing this with a record, bang patterns, and omitting the tuple for the `MetricImpl` type.
+
+
diff --git a/prometheus-client/src/Prometheus/Label.hs b/prometheus-client/src/Prometheus/Label.hs
index 957b638..47f54ae 100644
--- a/prometheus-client/src/Prometheus/Label.hs
+++ b/prometheus-client/src/Prometheus/Label.hs
@@ -1,4 +1,6 @@
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE GADTs #-}
@@ -43,48 +45,48 @@ instance Label () where
 type Label1 = Text
 
 instance Label Text where
-    labelPairs key value = LabelPairs [LabelPair key value]
+    labelPairs !key !value = LabelPairs [LabelPair key value]
 
 type Label2 = (Text, Text)
 
 instance (a ~ Text, b ~ a) => Label (a, b)  where
-    labelPairs (k1, k2) (v1, v2) = LabelPairs [LabelPair k1 v1, LabelPair k2 v2]
+    labelPairs (!k1, !k2) (!v1, !v2) = LabelPairs [LabelPair k1 v1, LabelPair k2 v2]
 
 type Label3 = (Text, Text, Text)
 
 instance (a ~ Text, b ~ a, c ~ a) => Label (a, b, c)  where
-    labelPairs (k1, k2, k3) (v1, v2, v3) = LabelPairs [LabelPair k1 v1, LabelPair k2 v2, LabelPair k3 v3]
+    labelPairs (!k1, !k2, !k3) (!v1, !v2, !v3) = LabelPairs [LabelPair k1 v1, LabelPair k2 v2, LabelPair k3 v3]
 
 type Label4 = (Text, Text, Text, Text)
 
 instance (a ~ Text, b ~ a, c ~ a, d ~ a) => Label (a, b, c, d)  where
-    labelPairs (k1, k2, k3, k4) (v1, v2, v3, v4) =
+    labelPairs (!k1, !k2, !k3, !k4) (!v1, !v2, !v3, !v4) =
             LabelPairs [LabelPair k1 v1, LabelPair k2 v2, LabelPair k3 v3, LabelPair k4 v4]
 
 type Label5 = (Text, Text, Text, Text, Text)
 
 instance (a ~ Text, b ~ a, c ~ a, d ~ a, e ~ a) => Label (a, b, c, d, e)  where
-    labelPairs (k1, k2, k3, k4, k5) (v1, v2, v3, v4, v5) =
+    labelPairs (!k1, !k2, !k3, !k4, !k5) (!v1, !v2, !v3, !v4, !v5) =
             LabelPairs [LabelPair k1 v1, LabelPair k2 v2, LabelPair k3 v3, LabelPair k4 v4, LabelPair k5 v5]
 
 type Label6 = (Text, Text, Text, Text, Text, Text)
 
 instance (a ~ Text, b ~ a, c ~ a, d ~ a, e ~ a, f ~ a) => Label (a, b, c, d, e, f)  where
-    labelPairs (k1, k2, k3, k4, k5, k6) (v1, v2, v3, v4, v5, v6) =
+    labelPairs (!k1, !k2, !k3, !k4, !k5, !k6) (!v1, !v2, !v3, !v4, !v5, !v6) =
             LabelPairs [LabelPair k1 v1, LabelPair k2 v2, LabelPair k3 v3, LabelPair k4 v4, LabelPair k5 v5, LabelPair k6 v6]
 
 type Label7 = (Text, Text, Text, Text, Text, Text, Text)
 
 instance (a ~ Text, b ~ a, c ~ a, d ~ a, e ~ a, f ~ a, g ~ a) => Label (a, b, c, d, e, f, g)  where
-    labelPairs (k1, k2, k3, k4, k5, k6, k7) (v1, v2, v3, v4, v5, v6, v7) =
+    labelPairs (!k1, !k2, !k3, !k4, !k5, !k6, !k7) (!v1, !v2, !v3, !v4, !v5, !v6, !v7) =
             LabelPairs [LabelPair k1 v1, LabelPair k2 v2, LabelPair k3 v3, LabelPair k4 v4, LabelPair k5 v5, LabelPair k6 v6,
              LabelPair k7 v7]
 
 type Label8 = (Text, Text, Text, Text, Text, Text, Text, Text)
 
 instance (a ~ Text, b ~ a, c ~ a, d ~ a, e ~ a, f ~ a, g ~ a, h ~ a) => Label (a, b, c, d, e, f, g, h) where
-    labelPairs (k1, k2, k3, k4, k5, k6, k7, k8)
-               (v1, v2, v3, v4, v5, v6, v7, v8) =
+    labelPairs (!k1, !k2, !k3, !k4, !k5, !k6, !k7, !k8)
+               (!v1, !v2, !v3, !v4, !v5, !v6, !v7, !v8) =
             LabelPairs [LabelPair k1 v1, LabelPair k2 v2, LabelPair k3 v3, LabelPair k4 v4, LabelPair k5 v5, LabelPair k6 v6,
              LabelPair k7 v7, LabelPair k8 v8]
 
@@ -92,7 +94,7 @@ type Label9 = (Text, Text, Text, Text, Text, Text, Text, Text,
                Text)
 
 instance (a ~ Text, b ~ a, c ~ a, d ~ a, e ~ a, f ~ a, g ~ a, h ~ a, i ~ a) => Label (a, b, c, d, e, f, g, h, i) where
-    labelPairs (k1, k2, k3, k4, k5, k6, k7, k8, k9)
-               (v1, v2, v3, v4, v5, v6, v7, v8, v9) =
+    labelPairs (!k1, !k2, !k3, !k4, !k5, !k6, !k7, !k8, !k9)
+               (!v1, !v2, !v3, !v4, !v5, !v6, !v7, !v8, !v9) =
             LabelPairs [LabelPair k1 v1, LabelPair k2 v2, LabelPair k3 v3, LabelPair k4 v4, LabelPair k5 v5, LabelPair k6 v6,
              LabelPair k7 v7, LabelPair k8 v8, LabelPair k9 v9]
diff --git a/prometheus-client/src/Prometheus/Metric.hs b/prometheus-client/src/Prometheus/Metric.hs
index 317ca96..3ecd6b8 100644
--- a/prometheus-client/src/Prometheus/Metric.hs
+++ b/prometheus-client/src/Prometheus/Metric.hs
@@ -2,6 +2,7 @@
 
 module Prometheus.Metric (
     Metric (..)
+,   MetricImpl (..)
 ,   Sample (..)
 ,   SampleGroup (..)
 ,   SampleType (..)
@@ -59,7 +60,12 @@ newtype Metric s =
       --    reference.
       -- 2. An 'IO' action that samples the metric and returns 'SampleGroup's.
       --    This is the data that will be stored by Prometheus.
-      construct :: IO (s, IO [SampleGroup])
+      construct :: IO (MetricImpl s)
+    }
+
+data MetricImpl s = MetricImpl
+    { metricImplState :: !s
+    , metricImplCollect :: IO [SampleGroup]
     }
 
 instance NFData a => NFData (Metric a) where
diff --git a/prometheus-client/src/Prometheus/Metric/Counter.hs b/prometheus-client/src/Prometheus/Metric/Counter.hs
index 6a29512..1bc74f5 100644
--- a/prometheus-client/src/Prometheus/Metric/Counter.hs
+++ b/prometheus-client/src/Prometheus/Metric/Counter.hs
@@ -32,7 +32,7 @@ instance NFData Counter where
 counter :: Info -> Metric Counter
 counter info = Metric $ do
     ioref <- IORef.newIORef 0
-    return (MkCounter ioref, collectCounter info ioref)
+    return $ MetricImpl (MkCounter ioref) (collectCounter info ioref)
 
 withCounter :: MonadMonitor m
           => Counter
diff --git a/prometheus-client/src/Prometheus/Metric/Gauge.hs b/prometheus-client/src/Prometheus/Metric/Gauge.hs
index 8a3d043..1104754 100644
--- a/prometheus-client/src/Prometheus/Metric/Gauge.hs
+++ b/prometheus-client/src/Prometheus/Metric/Gauge.hs
@@ -31,7 +31,7 @@ instance NFData Gauge where
 gauge :: Info -> Metric Gauge
 gauge info = Metric $ do
     ioref <- IORef.newIORef 0
-    return (MkGauge ioref, collectGauge info ioref)
+    return $ MetricImpl (MkGauge ioref) (collectGauge info ioref)
 
 withGauge :: MonadMonitor m
           => Gauge
diff --git a/prometheus-client/src/Prometheus/Metric/Histogram.hs b/prometheus-client/src/Prometheus/Metric/Histogram.hs
index 14c0325..97c78d2 100644
--- a/prometheus-client/src/Prometheus/Metric/Histogram.hs
+++ b/prometheus-client/src/Prometheus/Metric/Histogram.hs
@@ -47,7 +47,7 @@ instance NFData Histogram where
 histogram :: Info -> [Bucket] -> Metric Histogram
 histogram info buckets = Metric $ do
   countsTVar <- STM.newTVarIO  (emptyCounts buckets)
-  return (MkHistogram countsTVar, collectHistogram info countsTVar)
+  return $ MetricImpl (MkHistogram countsTVar) (collectHistogram info countsTVar)
 
 -- | Upper-bound for a histogram bucket.
 type Bucket = Double
diff --git a/prometheus-client/src/Prometheus/Metric/Summary.hs b/prometheus-client/src/Prometheus/Metric/Summary.hs
index e0cddab..6b56857 100644
--- a/prometheus-client/src/Prometheus/Metric/Summary.hs
+++ b/prometheus-client/src/Prometheus/Metric/Summary.hs
@@ -72,7 +72,7 @@ summary info quantiles_ = Metric $ do
     rs <- mkReqSketch kInt HighRanksAreAccurate
     mv <- newMVar $ rs {criterion = (:<=)}
     let summary_ = MkSummary mv quantiles_
-    return (summary_, collectSummary info summary_)
+    return $ MetricImpl summary_ (collectSummary info summary_)
     where
         kInt = fromIntegral $ case mapMaybe determineK quantiles_ of
           [] -> error "Unable to create a Summary meeting the provided quantile precision requirements"
diff --git a/prometheus-client/src/Prometheus/Metric/Vector.hs b/prometheus-client/src/Prometheus/Metric/Vector.hs
index 781f3ae..0fa4a70 100644
--- a/prometheus-client/src/Prometheus/Metric/Vector.hs
+++ b/prometheus-client/src/Prometheus/Metric/Vector.hs
@@ -24,7 +24,7 @@ import Data.Traversable (forM)
 
 data VectorState l m = VectorState
     { vectorStateMetric :: !(Metric m)
-    , vectorStateMetricMap :: !(Map.Map l (m, IO [SampleGroup]))
+    , vectorStateMetricMap :: !(Map.Map l (MetricImpl m))
     }
 
 data Vector l m = MkVector (IORef.IORef (VectorState l m))
@@ -36,7 +36,7 @@ instance NFData (Vector l m) where
 vector :: Label l => l -> Metric m -> Metric (Vector l m)
 vector labels gen = Metric $ do
     ioref <- checkLabelKeys labels $ IORef.newIORef $ VectorState gen Map.empty
-    return (MkVector ioref, collectVector labels ioref)
+    return $ MetricImpl (MkVector ioref) (collectVector labels ioref)
 
 checkLabelKeys :: Label l => l -> a -> a
 checkLabelKeys keys r = foldl check r $ map (T.unpack . labelKey) $ unLabelPairs $ labelPairs keys keys
@@ -66,7 +66,7 @@ collectVector keys ioref = do
     VectorState _ metricMap <- IORef.readIORef ioref
     joinSamples <$> concat <$> mapM collectInner (Map.assocs metricMap)
     where
-        collectInner (labels, (_metric, sampleGroups)) =
+        collectInner (labels, (MetricImpl _metric sampleGroups)) =
             map (adjustSamples labels) <$> sampleGroups
 
         adjustSamples labels (SampleGroup info ty samples) =
@@ -86,7 +86,7 @@ getVectorWith :: Vector label metric
               -> IO [(label, a)]
 getVectorWith (MkVector valueTVar) f = do
     VectorState _ metricMap <- IORef.readIORef valueTVar
-    Map.assocs <$> forM metricMap (f . fst)
+    Map.assocs <$> forM metricMap (f . metricImplState)
 
 -- | Given a label, applies an operation to the corresponding metric in the
 -- vector.
@@ -98,7 +98,7 @@ withLabel :: (Label label, MonadMonitor m)
 withLabel (MkVector ioref) label f = doIO $ do
     VectorState (Metric gen) _ <- IORef.readIORef ioref
     newMetric <- gen
-    (metric, !newVectorState) <- Atomics.atomicModifyIORefCAS ioref $ \(VectorState _ metricMap) ->
+    MetricImpl metric newVectorState <- Atomics.atomicModifyIORefCAS ioref $ \(VectorState _ metricMap) ->
         let maybeMetric = Map.lookup label metricMap
             updatedMap  = Map.insert label newMetric metricMap
         in  case maybeMetric of
diff --git a/prometheus-client/src/Prometheus/Registry.hs b/prometheus-client/src/Prometheus/Registry.hs
index 7de5381..e61b44e 100644
--- a/prometheus-client/src/Prometheus/Registry.hs
+++ b/prometheus-client/src/Prometheus/Registry.hs
@@ -31,7 +31,7 @@ globalRegistry = unsafePerformIO $ STM.newTVarIO []
 -- | Registers a metric with the global metric registry.
 register :: MonadIO m => Metric s -> m s
 register (Metric mk) = liftIO $ do
-    (metric, sampleGroups) <- mk
+    MetricImpl metric sampleGroups <- mk
     let addToRegistry = (sampleGroups :)
     liftIO $ STM.atomically $ STM.modifyTVar' globalRegistry addToRegistry
     return metric

From d6f89c3d29152bce8523be650f4a627a1f55f493 Mon Sep 17 00:00:00 2001
From: parsonsmatt <parsonsmatt@gmail.com>
Date: Tue, 10 Jun 2025 09:08:00 -0600
Subject: [PATCH 05/11] Sample carries Builder directly, avoiding Show

---
 prometheus-client/docs/memory-use.md             | 16 ++++++++++++++++
 prometheus-client/src/Prometheus/Export/Text.hs  |  2 +-
 prometheus-client/src/Prometheus/Metric.hs       |  3 ++-
 .../src/Prometheus/Metric/Counter.hs             |  3 ++-
 prometheus-client/src/Prometheus/Metric/Gauge.hs |  3 ++-
 .../src/Prometheus/Metric/Histogram.hs           | 13 ++++++-------
 .../src/Prometheus/Metric/Summary.hs             | 10 ++++------
 7 files changed, 33 insertions(+), 17 deletions(-)

diff --git a/prometheus-client/docs/memory-use.md b/prometheus-client/docs/memory-use.md
index 499e5e0..a99534e 100644
--- a/prometheus-client/docs/memory-use.md
+++ b/prometheus-client/docs/memory-use.md
@@ -49,4 +49,20 @@ Methods from that module evaluate the structure of the `Map`, but polymorphic me
 
 We can reduce the possibility of memory leaks here by replacing this with a record, bang patterns, and omitting the tuple for the `MetricImpl` type.
 
+## `Counter` to `Builder`
 
+`Counter` is a very simple metric.
+Since the operations used for modifying the `IORef` all evaluate the value to WHNF, and the value is a `Double`, we are not retaining memory here.
+
+However, there is a performance inefficiency: the use
+
+```haskell
+    let sample = Sample (metricName info) mempty (BS.fromString $ show value)
+```
+
+`show :: Double -> String` is going to inefficiently allocate a `[Char]`, which will then be packed using `BS.fromString`.
+Later, in consumption of this, we will convert that `ByteString` into a `Builder`.
+A more efficient approach would use [`doubleDec`](https://hackage-content.haskell.org/package/bytestring-0.12.2.0/docs/Data-ByteString-Builder.html#v:doubleDec) to directly convert to a `Builder`, avoiding allocating the intermediate `String`.
+
+Since the only actual use of the `Sample`'s payload value is in building the report, we can change `Sample` to contain a `Builder` and encode things directly.
+This will improve efficiency by avoiding allocating intermediate `String`s.
diff --git a/prometheus-client/src/Prometheus/Export/Text.hs b/prometheus-client/src/Prometheus/Export/Text.hs
index 674e609..19d76ae 100644
--- a/prometheus-client/src/Prometheus/Export/Text.hs
+++ b/prometheus-client/src/Prometheus/Export/Text.hs
@@ -74,7 +74,7 @@ exportSample (Sample name labels value) =
              <> mconcat [ Build.charUtf8 ',' <> exportLabel l' | l' <- ls ]
              <> Build.charUtf8 '}')
     <> Build.charUtf8 ' '
-    <> Build.byteString value
+    <> value
 
 exportLabel :: LabelPair -> Build.Builder
 exportLabel LabelPair { labelKey = key, labelValue = value } =
diff --git a/prometheus-client/src/Prometheus/Metric.hs b/prometheus-client/src/Prometheus/Metric.hs
index 3ecd6b8..610a4e2 100644
--- a/prometheus-client/src/Prometheus/Metric.hs
+++ b/prometheus-client/src/Prometheus/Metric.hs
@@ -13,6 +13,7 @@ import Prometheus.Label
 
 import Control.DeepSeq
 import qualified Data.ByteString as BS
+import qualified Data.ByteString.Builder as Builder
 import Data.Text (Text)
 
 
@@ -35,7 +36,7 @@ instance Show SampleType where
 -- | A single value recorded at a moment in time. The sample type contains the
 -- name of the sample, a list of labels and their values, and the value encoded
 -- as a ByteString.
-data Sample = Sample !Text !LabelPairs !BS.ByteString
+data Sample = Sample !Text !LabelPairs !Builder.Builder
     deriving (Show)
 
 -- | A Sample group is a list of samples that is tagged with meta data
diff --git a/prometheus-client/src/Prometheus/Metric/Counter.hs b/prometheus-client/src/Prometheus/Metric/Counter.hs
index 1bc74f5..565ef77 100644
--- a/prometheus-client/src/Prometheus/Metric/Counter.hs
+++ b/prometheus-client/src/Prometheus/Metric/Counter.hs
@@ -20,6 +20,7 @@ import Control.Monad.IO.Class
 import Control.Monad (unless)
 import qualified Data.Atomics as Atomics
 import qualified Data.ByteString.UTF8 as BS
+import qualified Data.ByteString.Builder as Builder
 import qualified Data.IORef as IORef
 
 
@@ -77,7 +78,7 @@ getCounter (MkCounter ioref) = liftIO $ IORef.readIORef ioref
 collectCounter :: Info -> IORef.IORef Double -> IO [SampleGroup]
 collectCounter info c = do
     value <- IORef.readIORef c
-    let sample = Sample (metricName info) mempty (BS.fromString $ show value)
+    let sample = Sample (metricName info) mempty (Builder.doubleDec value)
     return [SampleGroup info CounterType [sample]]
 
 -- | Count the amount of times an action throws any synchronous exception.
diff --git a/prometheus-client/src/Prometheus/Metric/Gauge.hs b/prometheus-client/src/Prometheus/Metric/Gauge.hs
index 1104754..21def1f 100644
--- a/prometheus-client/src/Prometheus/Metric/Gauge.hs
+++ b/prometheus-client/src/Prometheus/Metric/Gauge.hs
@@ -15,6 +15,7 @@ import Prometheus.Metric
 import Prometheus.Metric.Observer (timeAction)
 import Prometheus.MonadMonitor
 
+import qualified Data.ByteString.Builder as Builder
 import Control.DeepSeq
 import Control.Monad.IO.Class
 import qualified Data.Atomics as Atomics
@@ -77,5 +78,5 @@ setGaugeToDuration metric io = do
 collectGauge :: Info -> IORef.IORef Double -> IO [SampleGroup]
 collectGauge info c = do
     value <- IORef.readIORef c
-    let sample = Sample (metricName info) mempty (BS.fromString $ show value)
+    let sample = Sample (metricName info) mempty (Builder.doubleDec value)
     return [SampleGroup info GaugeType [sample]]
diff --git a/prometheus-client/src/Prometheus/Metric/Histogram.hs b/prometheus-client/src/Prometheus/Metric/Histogram.hs
index 97c78d2..8fa1c12 100644
--- a/prometheus-client/src/Prometheus/Metric/Histogram.hs
+++ b/prometheus-client/src/Prometheus/Metric/Histogram.hs
@@ -23,6 +23,7 @@ import Prometheus.Metric.Observer
 import Prometheus.MonadMonitor
 
 import Control.Applicative ((<$>))
+import qualified Data.ByteString.Builder as Builder
 import qualified Control.Concurrent.STM as STM
 import Control.DeepSeq
 import Control.Monad.IO.Class
@@ -102,14 +103,15 @@ insert value BucketCounts { histTotal = total, histCount = count, histCountsPerB
 collectHistogram :: Info -> STM.TVar BucketCounts -> IO [SampleGroup]
 collectHistogram info bucketCounts = STM.atomically $ do
     BucketCounts total count counts <- STM.readTVar bucketCounts
-    let sumSample = Sample (name <> "_sum") mempty (bsShow total)
-    let countSample = Sample (name <> "_count") mempty (bsShow count)
-    let infSample = Sample (name <> "_bucket") (labelPairs bucketLabel "+Inf") (bsShow count)
+    let sumSample = Sample (name <> "_sum") mempty (Builder.doubleDec total)
+    let countSample = Sample (name <> "_count") mempty (Builder.intDec count)
+    let infSample = Sample (name <> "_bucket") (labelPairs bucketLabel "+Inf") (Builder.intDec count)
     let samples = map toSample (cumulativeSum (Map.toAscList counts))
     return [SampleGroup info HistogramType $ samples ++ [infSample, sumSample, countSample]]
     where
+        toSample :: (Double, Int) -> Sample
         toSample (upperBound, count') =
-            Sample (name <> "_bucket") (labelPairs bucketLabel (formatFloat upperBound)) $ bsShow count'
+            Sample (name <> "_bucket") (labelPairs bucketLabel (formatFloat upperBound)) $ Builder.intDec count'
         name = metricName info
 
         -- We don't particularly want scientific notation, so force regular
@@ -118,9 +120,6 @@ collectHistogram info bucketCounts = STM.atomically $ do
 
         cumulativeSum xs = zip (map fst xs) (scanl1 (+) (map snd xs))
 
-        bsShow :: Show s => s -> BS.ByteString
-        bsShow = BS.fromString . show
-
 -- | The label that defines the upper bound of a bucket of a histogram. @"le"@
 -- is short for "less than or equal to".
 bucketLabel :: Text
diff --git a/prometheus-client/src/Prometheus/Metric/Summary.hs b/prometheus-client/src/Prometheus/Metric/Summary.hs
index 6b56857..c510169 100644
--- a/prometheus-client/src/Prometheus/Metric/Summary.hs
+++ b/prometheus-client/src/Prometheus/Metric/Summary.hs
@@ -21,6 +21,7 @@ import Control.DeepSeq
 import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Primitive
+import qualified Data.ByteString.Builder as Builder
 import qualified Data.ByteString.UTF8 as BS
 import qualified Data.Text as T
 import DataSketches.Quantiles.RelativeErrorQuantile
@@ -94,17 +95,14 @@ collectSummary info (MkSummary sketchVar quantiles_) = withMVar sketchVar $ \ske
     count_ <- ReqSketch.count sketch
     estimatedQuantileValues <- forM quantiles_ $ \qv ->
       (,) <$> pure (fst qv) <*> ReqSketch.quantile sketch (toDouble $ fst qv)
-    let sumSample = Sample (metricName info <> "_sum") mempty (bsShow itemSum)
-    let countSample = Sample (metricName info <> "_count") mempty (bsShow count_)
+    let sumSample = Sample (metricName info <> "_sum") mempty (Builder.doubleDec itemSum)
+    let countSample = Sample (metricName info <> "_count") mempty (Builder.word64Dec count_)
     return [SampleGroup info SummaryType $ map toSample estimatedQuantileValues ++ [sumSample, countSample]]
     where
-        bsShow :: Show s => s -> BS.ByteString
-        bsShow = BS.fromString . show
-
         toSample :: (Rational, Double) -> Sample
         toSample (q, estimatedValue) =
             Sample (metricName info) (labelPairs "quantile" (T.pack . show $ toDouble q)) $
-                bsShow estimatedValue
+                Builder.doubleDec estimatedValue
 
         toDouble :: Rational -> Double
         toDouble = fromRational

From f51ba3c51945c18aed7c6d48267ce8668edc6db8 Mon Sep 17 00:00:00 2001
From: parsonsmatt <parsonsmatt@gmail.com>
Date: Tue, 10 Jun 2025 09:58:09 -0600
Subject: [PATCH 06/11] More improvements

---
 prometheus-client/docs/memory-use.md          | 23 ++++++++++++++
 .../src/Prometheus/Metric/Histogram.hs        | 14 +++++----
 .../src/Prometheus/Metric/Summary.hs          | 30 +++++++++++++------
 3 files changed, 53 insertions(+), 14 deletions(-)

diff --git a/prometheus-client/docs/memory-use.md b/prometheus-client/docs/memory-use.md
index a99534e..da536fd 100644
--- a/prometheus-client/docs/memory-use.md
+++ b/prometheus-client/docs/memory-use.md
@@ -66,3 +66,26 @@ A more efficient approach would use [`doubleDec`](https://hackage-content.haskel
 
 Since the only actual use of the `Sample`'s payload value is in building the report, we can change `Sample` to contain a `Builder` and encode things directly.
 This will improve efficiency by avoiding allocating intermediate `String`s.
+
+## `Histogram`
+
+While investigating `Histogram`, I found a few potential issues:
+
+1. `cumulativeSum` has numerous problems: 
+    * The function holds onto the entire `Map` converted-into-a-`[(Double, Int)]` in order to `zip` it with itself. 
+    * `scanl1` is lazy, similar to `foldl`. On lists, this will result in thunk accumulation.
+2. `showFFloat` is used, requiring a `Double -> String -> Text -> Builder` conversion path.
+3. The entire computation is done inside of a `STM.atomically`.
+   This means that, should anything write to the `TVar`, all of the computation will be retried.
+   This is *probably* bad - we want to capture the state of the metrics *now*, and then return the `SampleGroup`, rather than allowing the computation to be aborted and retried multiple times.
+
+The first two problems are based on the sizeof the histogram, so the number of buckets.
+Every additional bucket causes another float to be rendered into a string, and another list cons cell to be held on to.
+Since number of buckets is likely small, this is probably not a big deal.
+
+However, might as well fix it up where I can!
+`scanl1'` does not exist in `base`, but we can avoid retaining the input list in memory by preserving the tuple structure.
+A bang pattern on the accumulator can help.
+
+`formatFloat` is used to produce a `Text` label value for the `LabelPair`.
+This suggests we can use `Data.Text.Lazy.Builder` to avoid the intermediate `String`.
diff --git a/prometheus-client/src/Prometheus/Metric/Histogram.hs b/prometheus-client/src/Prometheus/Metric/Histogram.hs
index 8fa1c12..ba076fa 100644
--- a/prometheus-client/src/Prometheus/Metric/Histogram.hs
+++ b/prometheus-client/src/Prometheus/Metric/Histogram.hs
@@ -24,6 +24,7 @@ import Prometheus.MonadMonitor
 
 import Control.Applicative ((<$>))
 import qualified Data.ByteString.Builder as Builder
+import qualified Data.ByteString.Builder.RealFloat as Builder
 import qualified Control.Concurrent.STM as STM
 import Control.DeepSeq
 import Control.Monad.IO.Class
@@ -32,7 +33,9 @@ import qualified Data.Map.Strict as Map
 import Data.Monoid ((<>))
 import Data.Text (Text)
 import qualified Data.Text as T
-import Numeric (showFFloat)
+import qualified Data.Text.Lazy as T.Lazy
+import qualified Data.Text.Lazy.Builder as T.Builder
+import qualified Data.Text.Lazy.Builder.RealFloat as T.Builder
 
 -- | A histogram. Counts the number of observations that fall within the
 -- specified buckets.
@@ -101,8 +104,8 @@ insert value BucketCounts { histTotal = total, histCount = count, histCountsPerB
 
 -- | Collect the current state of a histogram.
 collectHistogram :: Info -> STM.TVar BucketCounts -> IO [SampleGroup]
-collectHistogram info bucketCounts = STM.atomically $ do
-    BucketCounts total count counts <- STM.readTVar bucketCounts
+collectHistogram info bucketCounts = do
+    BucketCounts total count counts <- STM.atomically $ STM.readTVar bucketCounts
     let sumSample = Sample (name <> "_sum") mempty (Builder.doubleDec total)
     let countSample = Sample (name <> "_count") mempty (Builder.intDec count)
     let infSample = Sample (name <> "_bucket") (labelPairs bucketLabel "+Inf") (Builder.intDec count)
@@ -116,9 +119,10 @@ collectHistogram info bucketCounts = STM.atomically $ do
 
         -- We don't particularly want scientific notation, so force regular
         -- numeric representation instead.
-        formatFloat x = T.pack (showFFloat Nothing x "")
+        formatFloat x =
+            T.Lazy.toStrict $ T.Builder.toLazyText $ T.Builder.formatRealFloat T.Builder.Fixed Nothing x
 
-        cumulativeSum xs = zip (map fst xs) (scanl1 (+) (map snd xs))
+        cumulativeSum = scanl1 (\(!l, !x) (!l', !x') -> (l', x + x'))
 
 -- | The label that defines the upper bound of a bucket of a histogram. @"le"@
 -- is short for "less than or equal to".
diff --git a/prometheus-client/src/Prometheus/Metric/Summary.hs b/prometheus-client/src/Prometheus/Metric/Summary.hs
index c510169..89b4b89 100644
--- a/prometheus-client/src/Prometheus/Metric/Summary.hs
+++ b/prometheus-client/src/Prometheus/Metric/Summary.hs
@@ -2,7 +2,7 @@
 {-# language OverloadedStrings #-}
 module Prometheus.Metric.Summary (
     Summary
-,   Quantile
+,   Quantile(..)
 ,   summary
 ,   defaultQuantiles
 ,   observe
@@ -22,8 +22,9 @@ import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Primitive
 import qualified Data.ByteString.Builder as Builder
-import qualified Data.ByteString.UTF8 as BS
-import qualified Data.Text as T
+import qualified Data.Text.Lazy as T.Lazy
+import qualified Data.Text.Lazy.Builder as T.Builder
+import qualified Data.Text.Lazy.Builder.RealFloat as T.Builder
 import DataSketches.Quantiles.RelativeErrorQuantile
 import qualified DataSketches.Quantiles.RelativeErrorQuantile as ReqSketch
 import Data.Maybe (mapMaybe)
@@ -40,7 +41,13 @@ instance NFData Summary where
   rnf (MkSummary a b) = a `seq` b `deepseq` ()
 
 
-type Quantile = (Rational, Rational)
+data Quantile = Quantile
+  { quantileRank :: !Rational
+  , quantileAcceptableError :: !Rational
+  }
+
+instance NFData Quantile where
+  rnf (Quantile a b) = rnf a `seq` rnf b `seq` ()
 
 -- | K is a parameter divisible by two, in the range 4-1024 used in the RelativeErrorQuantile algorithm to
 -- determine how many items must be retained per compaction section. As the value increases, the accuracy
@@ -54,7 +61,7 @@ type Quantile = (Rational, Rational)
 -- If another smart constructor was exposed for summary creation, specific k values & LowRanksAreAccurate
 -- could be used to refine accuracy settings to bias towards lower quantiles when retaining accurate samples.
 determineK :: Quantile -> Maybe Word32
-determineK (rank_, acceptableError) = go 6
+determineK Quantile { quantileRank = rank_, quantileAcceptableError = acceptableError } = go 6
     where
         go k =
             let rse = relativeStandardError (fromIntegral k) (fromRational rank_) HighRanksAreAccurate 50000
@@ -87,25 +94,30 @@ instance Observer Summary where
 getSummary :: MonadIO m => Summary -> m [(Rational, Double)]
 getSummary (MkSummary sketchVar quantiles_) = liftIO $ withMVar sketchVar $ \sketch -> do
   forM quantiles_ $ \qv ->
-    (,) <$> pure (fst qv) <*> ReqSketch.quantile sketch (fromRational $ fst qv)
+    (,) <$> pure (quantileRank qv) <*> ReqSketch.quantile sketch (fromRational $ quantileRank qv)
 
 collectSummary :: Info -> Summary -> IO [SampleGroup]
 collectSummary info (MkSummary sketchVar quantiles_) = withMVar sketchVar $ \sketch -> do
     itemSum <- ReqSketch.sum sketch
     count_ <- ReqSketch.count sketch
     estimatedQuantileValues <- forM quantiles_ $ \qv ->
-      (,) <$> pure (fst qv) <*> ReqSketch.quantile sketch (toDouble $ fst qv)
+      (,) <$> pure (quantileRank qv) <*> ReqSketch.quantile sketch (toDouble $ quantileRank qv)
     let sumSample = Sample (metricName info <> "_sum") mempty (Builder.doubleDec itemSum)
     let countSample = Sample (metricName info <> "_count") mempty (Builder.word64Dec count_)
     return [SampleGroup info SummaryType $ map toSample estimatedQuantileValues ++ [sumSample, countSample]]
     where
         toSample :: (Rational, Double) -> Sample
         toSample (q, estimatedValue) =
-            Sample (metricName info) (labelPairs "quantile" (T.pack . show $ toDouble q)) $
+            Sample (metricName info) (labelPairs "quantile" (formatFloat $ toDouble q)) $
                 Builder.doubleDec estimatedValue
 
+        -- We don't particularly want scientific notation, so force regular
+        -- numeric representation instead.
+        formatFloat x =
+            T.Lazy.toStrict $ T.Builder.toLazyText $ T.Builder.realFloat x
+
         toDouble :: Rational -> Double
         toDouble = fromRational
 
 defaultQuantiles :: [Quantile]
-defaultQuantiles = [(0.5, 0.05), (0.9, 0.01), (0.99, 0.001)]
+defaultQuantiles = [Quantile 0.5 0.05, Quantile 0.9 0.01, Quantile 0.99 0.001]

From ae9fc9fb34a05d562e9bf12b4f44459972daeb4d Mon Sep 17 00:00:00 2001
From: Matt Parsons <parsonsmatt@gmail.com>
Date: Tue, 10 Jun 2025 12:19:32 -0600
Subject: [PATCH 07/11] Apply suggestions from code review

Co-authored-by: Mary Paskhaver <mary.paskhaver@gmail.com>
Co-authored-by: mattkahrs <mattkahrs@gmail.com>
---
 prometheus-client/docs/memory-use.md | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/prometheus-client/docs/memory-use.md b/prometheus-client/docs/memory-use.md
index da536fd..c049232 100644
--- a/prometheus-client/docs/memory-use.md
+++ b/prometheus-client/docs/memory-use.md
@@ -1,6 +1,6 @@
 # Investigating Memory Use in `prometheus-client`
 
-We're runnig into problems with unexpectedly high memory use in `prometheus-client`, so I've been investigating improving the behavior.
+We're running into problems with unexpectedly high memory use in `prometheus-client`, so I've been investigating improving the behavior.
 
 Specifically, we're notificing a significant increase in the amount of time and memory allocated while calling `exportMetricsToText`.
 Every time we call the endpoint, more and more memory is used to render the response.
@@ -42,7 +42,7 @@ A `Prometheus.Metric.Vector` previously was defined as:
 type VectorState l m = (Metric m, Map.Map l (m, IO [SampleGroup]))
 ```
 
-This `VectorSTate` was being stored in an `IORef`.
+This `VectorState` was being stored in an `IORef`.
 While the operation was evaluating the `VectorState` to WHNF, this only evaluated the tuple constructor, leaving the `Metric` and `Map.Map` unevaluated.
 The `Map` is from `Data.Map.Strict`, which means that the values are evaluated to WHNF.
 Methods from that module evaluate the structure of the `Map`, but polymorphic methods (ie `Functor`, `Traversable`) *do not*.

From 57398095e27ce0ba3a0a97089e18608ce9425376 Mon Sep 17 00:00:00 2001
From: parsonsmatt <parsonsmatt@gmail.com>
Date: Tue, 10 Jun 2025 12:41:17 -0600
Subject: [PATCH 08/11] fix the build

---
 .gitignore                                        |  1 +
 prometheus-client/prometheus-client.cabal         |  3 ++-
 prometheus-client/src/Prometheus/Metric.hs        |  4 ++--
 .../tests/Prometheus/Metric/SummarySpec.hs        | 15 ++++++++-------
 stack.yaml                                        |  5 +----
 5 files changed, 14 insertions(+), 14 deletions(-)

diff --git a/.gitignore b/.gitignore
index 9914019..5e8bf99 100644
--- a/.gitignore
+++ b/.gitignore
@@ -6,3 +6,4 @@ cabal.config
 .stack-work
 */*.yaml.lock
 .devcontainer
+stack.yaml.lock
diff --git a/prometheus-client/prometheus-client.cabal b/prometheus-client/prometheus-client.cabal
index c016b0a..6afb447 100644
--- a/prometheus-client/prometheus-client.cabal
+++ b/prometheus-client/prometheus-client.cabal
@@ -37,7 +37,7 @@ library
   build-depends:
       atomic-primops     >=0.4
     , base               >=4.7 && <5
-    , bytestring         >=0.9
+    , bytestring         >=0.11.2
     , clock
     , containers
     , deepseq
@@ -68,6 +68,7 @@ test-suite spec
   default-language:  Haskell2010
   hs-source-dirs:    src, tests
   main-is:           Spec.hs
+  build-tool-depends: hspec-discover:hspec-discover
   build-depends:
       QuickCheck
     , atomic-primops
diff --git a/prometheus-client/src/Prometheus/Metric.hs b/prometheus-client/src/Prometheus/Metric.hs
index 610a4e2..b162c44 100644
--- a/prometheus-client/src/Prometheus/Metric.hs
+++ b/prometheus-client/src/Prometheus/Metric.hs
@@ -37,12 +37,12 @@ instance Show SampleType where
 -- name of the sample, a list of labels and their values, and the value encoded
 -- as a ByteString.
 data Sample = Sample !Text !LabelPairs !Builder.Builder
-    deriving (Show)
+    -- deriving (Show)
 
 -- | A Sample group is a list of samples that is tagged with meta data
 -- including the name, help string, and type of the sample.
 data SampleGroup = SampleGroup !Info !SampleType [Sample]
-    deriving (Show)
+    -- deriving (Show)
 
 -- | A metric represents a single value that is being monitored. It is comprised
 -- of a handle value and a collect method. The handle value is typically a new
diff --git a/prometheus-client/tests/Prometheus/Metric/SummarySpec.hs b/prometheus-client/tests/Prometheus/Metric/SummarySpec.hs
index a736129..daf5eab 100644
--- a/prometheus-client/tests/Prometheus/Metric/SummarySpec.hs
+++ b/prometheus-client/tests/Prometheus/Metric/SummarySpec.hs
@@ -11,7 +11,7 @@ import Prometheus.Metric.Summary
 import Control.Applicative ((<$>))
 import Control.Monad
 import Data.Int (Int64)
-import Data.List (sort, sortBy)
+import Data.List (sort, sortBy, sortOn)
 import Numeric (fromRat)
 import System.Random.Shuffle
 import Test.Hspec
@@ -19,7 +19,7 @@ import Test.QuickCheck
 
 spec :: Spec
 spec = describe "Prometheus.Metric.Summary" $ do
-    observeToUnsafe 
+    observeToUnsafe
     let windowSize = 10000
     it "computes quantiles correctly for [0,10000) in order" $ do
         m <- register $ summary (Info "name" "help") quantiles
@@ -53,7 +53,7 @@ spec = describe "Prometheus.Metric.Summary" $ do
 testMetric :: Summary
 testMetric = do
   unsafeRegister $ summary (Info "test_histogram" "") quantiles
-  
+
 observeToUnsafe :: Spec
 observeToUnsafe =
   it "Is able to observe to a top-level 'unsafeRegister' metric" $ do
@@ -125,15 +125,16 @@ checkQuantiles m windowSize values = do
                 ]
 
 quantiles :: [Quantile]
-quantiles = [(0.5, 0.05), (0.9, 0.01), (0.99, 0.001)]
+quantiles = [Quantile 0.5 0.05, Quantile 0.9 0.01, Quantile 0.99 0.001]
 
 getQuantiles :: [Quantile] -> Summary -> IO [(Rational, Rational, Double)]
 getQuantiles qs s = do
-    values <- sortQuantiles <$> getSummary s
+    values <- sortQuantiles' <$> getSummary s
     let sortedQuantiles = sortQuantiles qs
-    return $ zipWith (\(q, e) (_, v) -> (q, e, v)) sortedQuantiles values
+    return $ zipWith (\(Quantile q e) (_, v) -> (q, e, v)) sortedQuantiles values
     where
-        sortQuantiles = sortBy (\(a, _) (b, _) -> compare a b)
+        sortQuantiles = sortBy (\(Quantile a _) (Quantile b _) -> compare a b)
+        sortQuantiles' = sortOn fst
 
 -- | Return a tuple that describes the range of that an element's true rank can
 -- be in. For example, in the list [0, 0, 0, 1] the result for querying 0 will
diff --git a/stack.yaml b/stack.yaml
index ec9efad..0c29c07 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -5,7 +5,4 @@ packages:
 - prometheus-metrics-ghc
 - prometheus-proc
 - wai-middleware-prometheus
-extra-deps:
-- unix-memory-0.1.2
-- data-sketches-0.3.0.0
-resolver: lts-18.5
+resolver: lts-22.43

From 95051ad432d839b6650fcffb14216512e405bfeb Mon Sep 17 00:00:00 2001
From: parsonsmatt <parsonsmatt@gmail.com>
Date: Tue, 10 Jun 2025 12:50:01 -0600
Subject: [PATCH 09/11] fix doctets

---
 prometheus-client/src/Prometheus.hs | 21 +++++++++++----------
 1 file changed, 11 insertions(+), 10 deletions(-)

diff --git a/prometheus-client/src/Prometheus.hs b/prometheus-client/src/Prometheus.hs
index 654d4ed..59fefa2 100644
--- a/prometheus-client/src/Prometheus.hs
+++ b/prometheus-client/src/Prometheus.hs
@@ -57,7 +57,7 @@ module Prometheus (
 -- set the value of a gauge as well as add and subtract arbitrary values.
 --
 -- >>> myGauge <- register $ gauge (Info "my_gauge" "An example gauge")
--- >>> setGauge myGauge 100 
+-- >>> setGauge myGauge 100
 -- >>> addGauge myGauge 50
 -- >>> subGauge myGauge 25
 -- >>> getGauge myGauge
@@ -113,7 +113,7 @@ module Prometheus (
 -- summaries in that they can be meaningfully aggregated across processes.
 --
 -- >>> myHistogram <- register $ histogram (Info "my_histogram" "") defaultBuckets
--- >>> observe myHistogram 0 
+-- >>> observe myHistogram 0
 -- >>> getHistogram myHistogram
 -- fromList [(5.0e-3,1),(1.0e-2,0),(2.5e-2,0),(5.0e-2,0),(0.1,0),(0.25,0),(0.5,0),(1.0,0),(2.5,0),(5.0,0),(10.0,0)]
 ,   Histogram
@@ -130,11 +130,11 @@ module Prometheus (
 -- partitioned across a set of dimensions.
 --
 -- >>> myVector <- register $ vector ("method", "code") $ counter (Info "http_requests" "")
--- >>> withLabel myVector ("GET", "200") incCounter 
--- >>> withLabel myVector ("GET", "200") incCounter 
--- >>> withLabel myVector ("GET", "404") incCounter 
--- >>> withLabel myVector ("POST", "200") incCounter 
--- >>> getVectorWith myVector getCounter 
+-- >>> withLabel myVector ("GET", "200") incCounter
+-- >>> withLabel myVector ("GET", "200") incCounter
+-- >>> withLabel myVector ("GET", "404") incCounter
+-- >>> withLabel myVector ("POST", "200") incCounter
+-- >>> getVectorWith myVector getCounter
 -- [(("GET","200"),2.0),(("GET","404"),1.0),(("POST","200"),1.0)]
 -- >>> exportMetricsAsText >>= Data.ByteString.Lazy.putStr
 -- # HELP http_requests
@@ -199,11 +199,11 @@ module Prometheus (
 -- >>> :m +Data.ByteString.UTF8
 -- >>> newtype CPUTime = MkCPUTime ()
 -- >>> let info = Info "cpu_time" "The current CPU time"
--- >>> let toValue = Data.ByteString.UTF8.fromString . show
--- >>> let toSample = Sample "cpu_time" [] . toValue
+-- >>> let toValue = Data.ByteString.Builder.stringUtf8 . show
+-- >>> let toSample = Sample "cpu_time" mempty . toValue
 -- >>> let toSampleGroup = (:[]) . SampleGroup info GaugeType . (:[]) . toSample
 -- >>> let collectCPUTime = fmap toSampleGroup getCPUTime
--- >>> let cpuTimeMetric = Metric (return (MkCPUTime (), collectCPUTime))
+-- >>> let cpuTimeMetric = Metric (return $ MetricImpl (MkCPUTime ()) collectCPUTime)
 -- >>> register cpuTimeMetric
 -- >>> exportMetricsAsText >>= Data.ByteString.Lazy.putStr
 -- # HELP cpu_time The current CPU time
@@ -266,5 +266,6 @@ import Prometheus.Registry
 -- $setup
 -- >>> :module +Prometheus
 -- >>> :module +Control.Monad
+-- >>> :module +Data.ByteString.Builder
 -- >>> :set -XOverloadedStrings
 -- >>> unregisterAll

From 44272e33df510fea219cc9bba8e9ac1dbacf5f7e Mon Sep 17 00:00:00 2001
From: parsonsmatt <parsonsmatt@gmail.com>
Date: Tue, 10 Jun 2025 13:27:34 -0600
Subject: [PATCH 10/11] fix prometheus-metrics-ghc

---
 prometheus-client/src/Prometheus.hs           |  1 +
 .../prometheus-metrics-ghc.cabal              |  1 +
 .../src/Prometheus/Metric/GHC.hs              | 83 +++++++++----------
 3 files changed, 42 insertions(+), 43 deletions(-)

diff --git a/prometheus-client/src/Prometheus.hs b/prometheus-client/src/Prometheus.hs
index 59fefa2..52cbba8 100644
--- a/prometheus-client/src/Prometheus.hs
+++ b/prometheus-client/src/Prometheus.hs
@@ -244,6 +244,7 @@ module Prometheus (
 
 ,   Info (..)
 ,   Metric (..)
+,   MetricImpl (..)
 ,   Sample (..)
 ,   SampleGroup (..)
 ,   SampleType (..)
diff --git a/prometheus-metrics-ghc/prometheus-metrics-ghc.cabal b/prometheus-metrics-ghc/prometheus-metrics-ghc.cabal
index 91f2192..7ffc7b1 100644
--- a/prometheus-metrics-ghc/prometheus-metrics-ghc.cabal
+++ b/prometheus-metrics-ghc/prometheus-metrics-ghc.cabal
@@ -28,6 +28,7 @@ library
     , prometheus-client  >=1.0.0 && <1.2
     , utf8-string        >=0.3
     , text
+    , bytestring
   ghc-options: -Wall
 
 test-suite doctest
diff --git a/prometheus-metrics-ghc/src/Prometheus/Metric/GHC.hs b/prometheus-metrics-ghc/src/Prometheus/Metric/GHC.hs
index 1148b12..8166e1b 100644
--- a/prometheus-metrics-ghc/src/Prometheus/Metric/GHC.hs
+++ b/prometheus-metrics-ghc/src/Prometheus/Metric/GHC.hs
@@ -19,8 +19,9 @@ module Prometheus.Metric.GHC (
 #if __GLASGOW_HASKELL__ < 710
 import Control.Applicative ((<$>))
 #endif
-import qualified Data.ByteString.UTF8 as BS
 import Data.Text (Text)
+import Data.ByteString.Builder (Builder)
+import qualified Data.ByteString.Builder as Builder
 import Data.Fixed (Fixed, E9)
 #if __GLASGOW_HASKELL__ < 804
 import GHC.Conc (numSparks, getNumCapabilities)
@@ -35,7 +36,7 @@ import Prometheus
 data GHCMetrics = GHCMetrics
 
 ghcMetrics :: Metric GHCMetrics
-ghcMetrics = ghcMetricsWithLabels []
+ghcMetrics = ghcMetricsWithLabels mempty
 
 ghcMetricsWithLabels :: LabelPairs -> Metric GHCMetrics
 ghcMetricsWithLabels labels = Metric (do
@@ -46,7 +47,7 @@ ghcMetricsWithLabels labels = Metric (do
     getRTSStatsEnabled
 #endif
   if statsEnabled
-  then return (GHCMetrics, do
+  then return $ MetricImpl GHCMetrics $ do
         stats <-
 #if __GLASGOW_HASKELL__ < 804
             getGCStats
@@ -54,8 +55,7 @@ ghcMetricsWithLabels labels = Metric (do
             getRTSStats
 #endif
         concat <$> mapM (\f -> f labels stats) ghcCollectors
-    )
-  else return (GHCMetrics, return [])
+  else return $ MetricImpl GHCMetrics (return [])
   )
 
 #if __GLASGOW_HASKELL__ < 804
@@ -172,92 +172,92 @@ ghcCollectors = [
             "ghc_gcs_total"
             "Total number of GCs"
             CounterType
-            gcs
+            (Builder.word32Dec . gcs)
     , statsCollector
             "ghc_major_gcs_total"
             "Total number of major (oldest generation) GCs"
             CounterType
-            major_gcs
+            (Builder.word32Dec . major_gcs)
     , statsCollector
             "ghc_allocated_bytes_total"
             "Total bytes allocated"
             CounterType
-            allocated_bytes
+            (Builder.word64Dec . allocated_bytes)
     , statsCollector
             "ghc_max_live_bytes"
             "Maximum live data (including large objects + compact regions)"
             GaugeType
-            max_live_bytes
+            (Builder.word64Dec . max_live_bytes)
     , statsCollector
             "ghc_max_large_objects_bytes"
             "Maximum live data in large objects"
             GaugeType
-            max_large_objects_bytes
+            (Builder.word64Dec . max_large_objects_bytes)
     , statsCollector
             "ghc_max_compact_bytes"
             "Maximum live data in compact regions"
             GaugeType
-            max_compact_bytes
+            (Builder.word64Dec . max_compact_bytes)
     , statsCollector
             "ghc_max_slop_bytes"
             "Maximum slop"
             GaugeType
-            max_slop_bytes
+            (Builder.word64Dec . max_slop_bytes)
     , statsCollector
             "ghc_max_mem_in_use_bytes"
             "Maximum memory in use by the RTS"
             GaugeType
-            max_mem_in_use_bytes
+            (Builder.word64Dec . max_mem_in_use_bytes)
     , statsCollector
             "ghc_cumulative_live_bytes_total"
             "Sum of live bytes across all major GCs. Divided by major_gcs gives the average live data over the lifetime of the program."
             CounterType
-            cumulative_live_bytes
+            (Builder.word64Dec . cumulative_live_bytes)
     , statsCollector
             "ghc_copied_bytes_total"
             "Sum of copied_bytes across all GCs"
             CounterType
-            copied_bytes
+            (Builder.word64Dec . copied_bytes)
     , statsCollector
             "ghc_par_copied_bytes_total"
             "Sum of copied_bytes across all parallel GCs"
             CounterType
-            par_copied_bytes
+            (Builder.word64Dec . par_copied_bytes)
     , statsCollector
             "ghc_cumulative_par_max_copied_bytes_total"
             "Sum of par_max_copied_bytes across all parallel GCs"
             CounterType
-            cumulative_par_max_copied_bytes
+            (Builder.word64Dec . cumulative_par_max_copied_bytes)
     , statsCollector
             "ghc_mutator_cpu_seconds_total"
             "Total CPU time used by the mutator"
             CounterType
-            (rtsTimeToSeconds . mutator_cpu_ns)
+            (Builder.doubleDec . fromRational . toRational . rtsTimeToSeconds . mutator_cpu_ns)
     , statsCollector
             "ghc_mutator_elapsed_seconds_total"
             "Total elapsed time used by the mutator"
             CounterType
-            (rtsTimeToSeconds . mutator_elapsed_ns)
+            (Builder.doubleDec . fromRational . toRational . rtsTimeToSeconds . mutator_elapsed_ns)
     , statsCollector
             "ghc_gc_cpu_seconds_total"
             "Total CPU time used by the GC"
             CounterType
-            (rtsTimeToSeconds . gc_cpu_ns)
+            (Builder.doubleDec . fromRational . toRational . rtsTimeToSeconds . gc_cpu_ns)
     , statsCollector
             "ghc_gc_elapsed_seconds_total"
             "Total elapsed time used by the GC"
             CounterType
-            (rtsTimeToSeconds . gc_elapsed_ns)
+            (Builder.doubleDec . fromRational . toRational . rtsTimeToSeconds . gc_elapsed_ns)
     , statsCollector
             "ghc_cpu_seconds_total"
             "Total CPU time (at the previous GC)"
             CounterType
-            (rtsTimeToSeconds . cpu_ns)
+            (Builder.doubleDec . fromRational . toRational . rtsTimeToSeconds . cpu_ns)
     , statsCollector
             "ghc_elapsed_seconds_total"
             "Total elapsed time (at the previous GC)"
             CounterType
-            (rtsTimeToSeconds . elapsed_ns)
+            (Builder.doubleDec . fromRational . toRational . rtsTimeToSeconds . elapsed_ns)
 
     , statsCollector
             "ghc_gcdetails_gen"
@@ -266,67 +266,67 @@ ghcCollectors = [
                           -- Gauge makes little sense here.
                           -- With Histogram we'll be able to see which
                           -- generations are collected most often.
-            (gcdetails_gen . gc)
+            (Builder.word32Dec . gcdetails_gen . gc)
     , statsCollector
             "ghc_gcdetails_threads"
             "Number of threads used in this GC"
             GaugeType
-            (gcdetails_threads . gc)
+            (Builder.word32Dec . gcdetails_threads . gc)
     , statsCollector
             "ghc_gcdetails_allocated_bytes"
             "Number of bytes allocated since the previous GC"
             GaugeType -- TODO: this doesn't seem very meaningful.
-            (gcdetails_allocated_bytes . gc)
+            (Builder.word64Dec . gcdetails_allocated_bytes . gc)
     , statsCollector
             "ghc_gcdetails_live_bytes"
             "Total amount of live data in the heap (including large + compact data)"
             GaugeType
-            (gcdetails_live_bytes . gc)
+            (Builder.word64Dec . gcdetails_live_bytes . gc)
     , statsCollector
             "ghc_gcdetails_large_objects_bytes"
             "Total amount of live data in large objects"
             GaugeType
-            (gcdetails_large_objects_bytes . gc)
+            (Builder.word64Dec . gcdetails_large_objects_bytes . gc)
     , statsCollector
             "ghc_gcdetails_compact_bytes"
             "Total amount of live data in compact regions"
             GaugeType
-            (gcdetails_compact_bytes . gc)
+            (Builder.word64Dec . gcdetails_compact_bytes . gc)
     , statsCollector
             "ghc_gcdetails_slop_bytes"
             "Total amount of slop (wasted memory)"
             GaugeType
-            (gcdetails_slop_bytes . gc)
+            (Builder.word64Dec . gcdetails_slop_bytes . gc)
     , statsCollector
             "ghc_gcdetails_mem_in_use_bytes"
             "Total amount of memory in use by the RTS"
             GaugeType
-            (gcdetails_mem_in_use_bytes . gc)
+            (Builder.word64Dec . gcdetails_mem_in_use_bytes . gc)
     , statsCollector
             "ghc_gcdetails_copied_bytes"
             "Total amount of data copied during this GC"
             GaugeType -- TODO: this will also vary wildly between GCs of different generations.
-            (gcdetails_copied_bytes . gc)
+            (Builder.word64Dec . gcdetails_copied_bytes . gc)
     , statsCollector
             "ghc_gcdetails_par_max_copied_bytes"
             "In parallel GC, the max amount of data copied by any one thread"
             GaugeType
-            (gcdetails_par_max_copied_bytes . gc)
+            (Builder.word64Dec . gcdetails_par_max_copied_bytes . gc)
     , statsCollector
             "ghc_gcdetails_sync_elapsed_seconds"
             "The time elapsed during synchronisation before GC"
             GaugeType
-            (rtsTimeToSeconds . gcdetails_sync_elapsed_ns . gc)
+            (Builder.doubleDec . fromRational . toRational . rtsTimeToSeconds . gcdetails_sync_elapsed_ns . gc)
     , statsCollector
             "ghc_gcdetails_cpu_seconds"
             "The CPU time used during GC itself"
             GaugeType
-            (rtsTimeToSeconds . gcdetails_cpu_ns . gc)
+            (Builder.doubleDec . fromRational . toRational . rtsTimeToSeconds . gcdetails_cpu_ns . gc)
     , statsCollector
             "ghc_gcdetails_elapsed_seconds"
             "The time elapsed during GC itself"
             GaugeType
-            (rtsTimeToSeconds . gcdetails_elapsed_ns . gc)
+            (Builder.doubleDec . fromRational . toRational . rtsTimeToSeconds . gcdetails_elapsed_ns . gc)
   ]
 
 -- | Convert from 'RtsTime' (nanoseconds) to seconds with nanosecond precision.
@@ -335,19 +335,16 @@ rtsTimeToSeconds = (/ 1e9) . fromIntegral
 #endif
 
 #if __GLASGOW_HASKELL__ < 804
-statsCollector :: Show a
-               => Text -> Text -> SampleType -> (GCStats -> a) -> LabelPairs -> GCStats -> IO [SampleGroup]
+statsCollector :: Text -> Text -> SampleType -> (GCStats -> Builder) -> LabelPairs -> GCStats -> IO [SampleGroup]
 statsCollector name help sampleType stat labels gcstats =
     showCollector name help sampleType (stat gcstats) labels
 #else
-statsCollector :: Show a
-               => Text -> Text -> SampleType -> (RTSStats -> a) -> LabelPairs -> RTSStats -> IO [SampleGroup]
+statsCollector :: Text -> Text -> SampleType -> (RTSStats -> Builder) -> LabelPairs -> RTSStats -> IO [SampleGroup]
 statsCollector name help sampleType stat labels rtsStats =
     showCollector name help sampleType (stat rtsStats) labels
 #endif
 
-showCollector :: Show a => Text -> Text -> SampleType -> a -> LabelPairs -> IO [SampleGroup]
+showCollector :: Text -> Text -> SampleType -> Builder -> LabelPairs -> IO [SampleGroup]
 showCollector name help sampleType value labels = do
     let info = Info name help
-    let valueBS = BS.fromString $ show value
-    return [SampleGroup info sampleType [Sample name labels valueBS]]
+    return [SampleGroup info sampleType [Sample name labels value]]

From fba600488aa0ef62041d58ca9527acc46e8d863a Mon Sep 17 00:00:00 2001
From: parsonsmatt <parsonsmatt@gmail.com>
Date: Tue, 10 Jun 2025 14:52:57 -0600
Subject: [PATCH 11/11] ugh

---
 prometheus-client/src/Prometheus.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/prometheus-client/src/Prometheus.hs b/prometheus-client/src/Prometheus.hs
index 52cbba8..108dd6e 100644
--- a/prometheus-client/src/Prometheus.hs
+++ b/prometheus-client/src/Prometheus.hs
@@ -100,7 +100,7 @@ module Prometheus (
 -- [(1 % 2,0.0),(9 % 10,0.0),(99 % 100,0.0)]
 
 ,   Summary
-,   Quantile
+,   Quantile(..)
 ,   summary
 ,   defaultQuantiles
 ,   getSummary