From 2097fdbc4e3a930c1ce418c4d064600972ff7b78 Mon Sep 17 00:00:00 2001
From: Brandon Chinn <brandonchinn178@gmail.com>
Date: Fri, 26 Jun 2026 00:18:59 -0700
Subject: [PATCH 1/4] Add new Prometheus.V3 API

---
 ExampleV3.hs                          |  72 +++++++++
 prometheus.cabal                      |  35 +++++
 src/Prometheus/V3.hs                  |  96 ++++++++++++
 src/Prometheus/V3/Collector.hs        |  39 +++++
 src/Prometheus/V3/Encode.hs           | 129 ++++++++++++++++
 src/Prometheus/V3/Encode/Value.hs     |  17 +++
 src/Prometheus/V3/Http/Serve.hs       |  87 +++++++++++
 src/Prometheus/V3/Label.hs            | 211 ++++++++++++++++++++++++++
 src/Prometheus/V3/LabelName.hs        |  51 +++++++
 src/Prometheus/V3/Metric/Base.hs      |  64 ++++++++
 src/Prometheus/V3/Metric/Counter.hs   | 114 ++++++++++++++
 src/Prometheus/V3/Metric/Gauge.hs     | 135 ++++++++++++++++
 src/Prometheus/V3/Metric/Histogram.hs | 138 +++++++++++++++++
 src/Prometheus/V3/Metric/Labelled.hs  |  95 ++++++++++++
 src/Prometheus/V3/MetricName.hs       |  61 ++++++++
 src/Prometheus/V3/Name.hs             | 115 ++++++++++++++
 src/Prometheus/V3/Registry.hs         | 114 ++++++++++++++
 src/Prometheus/V3/Sample.hs           |  51 +++++++
 18 files changed, 1624 insertions(+)
 create mode 100644 ExampleV3.hs
 create mode 100644 src/Prometheus/V3.hs
 create mode 100644 src/Prometheus/V3/Collector.hs
 create mode 100644 src/Prometheus/V3/Encode.hs
 create mode 100644 src/Prometheus/V3/Encode/Value.hs
 create mode 100644 src/Prometheus/V3/Http/Serve.hs
 create mode 100644 src/Prometheus/V3/Label.hs
 create mode 100644 src/Prometheus/V3/LabelName.hs
 create mode 100644 src/Prometheus/V3/Metric/Base.hs
 create mode 100644 src/Prometheus/V3/Metric/Counter.hs
 create mode 100644 src/Prometheus/V3/Metric/Gauge.hs
 create mode 100644 src/Prometheus/V3/Metric/Histogram.hs
 create mode 100644 src/Prometheus/V3/Metric/Labelled.hs
 create mode 100644 src/Prometheus/V3/MetricName.hs
 create mode 100644 src/Prometheus/V3/Name.hs
 create mode 100644 src/Prometheus/V3/Registry.hs
 create mode 100644 src/Prometheus/V3/Sample.hs

diff --git a/ExampleV3.hs b/ExampleV3.hs
new file mode 100644
index 000000000..a15160e05
--- /dev/null
+++ b/ExampleV3.hs
@@ -0,0 +1,72 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoFieldSelectors #-}
+
+import Control.Concurrent (threadDelay)
+import Control.Monad (forever)
+import Data.Hashable (Hashable)
+import GHC.Generics (Generic)
+import qualified Prometheus.V3 as Prom
+import qualified Prometheus.V3.Metric.Counter as Counter
+
+
+type Status = Int
+
+
+data Method = GET | POST
+    deriving (Eq, Generic, Hashable)
+instance Prom.IsLabelValue Method where
+    toLabelValue = \case
+        GET -> "GET"
+        POST -> "POST"
+
+
+fooCounter :: Prom.Counter
+fooCounter = Counter.register "foo_total" "Number of foos"
+{-# OPAQUE fooCounter #-}
+
+
+requestsCounter :: Prom.Labelled (Method, Status) Prom.Counter
+requestsCounter =
+    Prom.register
+        . Prom.withLabels ("method", "status") labels
+        $ Counter.new "requests_total" "Number of requests"
+  where
+    labels =
+        [ (method, status)
+        | method <- [GET, POST]
+        , status <- [200, 404, 500]
+        ]
+{-# OPAQUE requestsCounter #-}
+
+
+data Request = Request
+    { method :: Method
+    }
+
+
+myHandler :: Request -> IO ()
+myHandler req = do
+    status <- pure 200
+
+    Counter.inc fooCounter
+    Counter.inc (Counter.labels (req.method, status) requestsCounter)
+
+    -- Cache it, for a hot loop
+    c <- Counter.labels (req.method, status) requestsCounter
+    Counter.inc c
+
+
+main :: IO ()
+main = do
+    Prom.serveMetrics 9090 -- Serves metrics on separate thread
+    myHandler Request{method = GET}
+    myHandler Request{method = GET}
+
+    putStrLn ">>> Server running."
+    putStrLn ">>> Run `curl localhost:9090` to see metrics"
+    putStrLn ">>> Press Ctrl-C to exit"
+    forever $ threadDelay 10000000
diff --git a/prometheus.cabal b/prometheus.cabal
index db57a7874..1da7a1beb 100644
--- a/prometheus.cabal
+++ b/prometheus.cabal
@@ -87,19 +87,39 @@ library
                  , System.Metrics.Prometheus.MetricId
                  , System.Metrics.Prometheus.Registry
                  , System.Metrics.Prometheus.RegistryT
+                 , Prometheus.V3
+                 , Prometheus.V3.Collector
+                 , Prometheus.V3.Encode
+                 , Prometheus.V3.Encode.Value
+                 , Prometheus.V3.Http.Serve
+                 , Prometheus.V3.Label
+                 , Prometheus.V3.LabelName
+                 , Prometheus.V3.Metric.Base
+                 , Prometheus.V3.Metric.Counter
+                 , Prometheus.V3.Metric.Gauge
+                 , Prometheus.V3.Metric.Histogram
+                 , Prometheus.V3.Metric.Labelled
+                 , Prometheus.V3.MetricName
+                 , Prometheus.V3.Name
+                 , Prometheus.V3.Registry
+                 , Prometheus.V3.Sample
 
   build-depends: base            >= 4.9  && < 5
                , atomic-primops  >= 0.8  && < 0.9
                , bytestring      >= 0.10 && < 0.13
                , containers      >= 0.5  && < 0.8
+               , hashable
                , http-client     >= 0.4  && < 0.8
                , http-client-tls >= 0.3  && < 0.5
                , http-types      >= 0.8  && < 0.13
                , network-uri     >= 2.5  && < 2.7
                , text            >= 1.2  && < 2.2
+               , time
                , transformers    >= 0.4  && < 0.7
                , wai             >= 3.2  && < 3.3
                , warp            >= 3.2  && < 3.5
+               , unliftio
+               , unordered-containers
 
 executable prometheus-example
   main-is: Example.hs
@@ -115,6 +135,21 @@ executable prometheus-example
   else
     buildable:         False
 
+executable prometheus-example-v3
+  main-is: ExampleV3.hs
+  default-language: Haskell2010
+
+  ghc-options: -Wall -fwarn-tabs -fno-warn-unused-do-bind
+
+  build-depends: base
+               , hashable
+               , prometheus
+
+  if flag(buildexamples)
+    buildable:         True
+  else
+    buildable:         False
+
 source-repository head
   type:     git
   location: https://github.com/bitnomial/prometheus
diff --git a/src/Prometheus/V3.hs b/src/Prometheus/V3.hs
new file mode 100644
index 000000000..a37b3a093
--- /dev/null
+++ b/src/Prometheus/V3.hs
@@ -0,0 +1,96 @@
+-- | A new implementation of the API, following Prometheus's standard for writing
+-- client libraries: https://prometheus.io/docs/instrumenting/writing_clientlibs/
+--
+-- When releasing prometheus-3.0:
+--   * Rename this as Prometheus
+--   * Remove old 'System.Metrics.Prometheus' modules
+--   * Update README/Cabal description for new API
+--   * Delete this preamble
+--
+-- == Usage
+--
+-- The recommended usage is to initialize the metrics as top-level global
+-- variables in the same file as the functions they're instrumenting.
+--
+-- Note: globally registered metrics are only registered when it's used for the
+-- first time, due to laziness.
+--
+-- @
+-- {-# LANGUAGE OverloadedStrings #-}
+--
+-- import Prometheus.V3 qualified as Prom
+-- import Prometheus.V3.Metric.Counter qualified as Counter
+--
+-- fooCounter :: Prom.Counter
+-- fooCounter = Counter.register "foo_total" "Number of foos"
+-- {-# OPAQUE fooCounter #-}
+--
+-- requestsCounter :: Prom.Labelled Prom.Counter
+-- requestsCounter =
+--   Prom.register
+--     . Prom.withLabels ("method", "status") labels
+--     $ Counter.new "requests_total" "Number of requests"
+--   where
+--     labels =
+--       [ (method, status)
+--       | method <- [GET, POST]
+--       , status <- [200, 404, 500]
+--       ]
+-- {-# OPAQUE requestsCounter #-}
+--
+-- myHandler req = do
+--   status <- run req
+--
+--   Counter.inc fooCounter
+--   Counter.inc (Counter.labels (requestMethod req, status) requestsCounter)
+--
+--   -- Cache it, for a hot loop
+--   c <- Counter.labels (requestMethod req, status) requestsCounter
+--   Counter.inc c
+--
+-- main :: IO ()
+-- main = do
+--   Prom.serveMetrics 9090 -- Serves metrics on separate thread
+-- @
+--
+-- Alternatively, you could initialize metrics in IO and pass it to your
+-- functions as normal (e.g. Reader monad, as a function arg, etc.):
+--
+-- @
+-- registry <- Prom.newRegistry
+-- fooCounter <- Prom.registerTo registry $ Counter.new "foo_counter" ""
+-- @
+--
+-- For advanced use-cases, you can also construct your own
+-- 'Prometheus.V3.Collector.Collector' manually and register it to the registry.
+module Prometheus.V3 (
+    -- * Metric types
+    Metric,
+    Counter,
+    Gauge,
+    Histogram,
+
+    -- * Labels
+    Labelled,
+    withLabels,
+    IsLabelValue (..),
+
+    -- * Registry
+    globalRegistry,
+    registerTo,
+    unregisterFrom,
+    register,
+
+    -- * Serving metrics
+    serveMetrics,
+) where
+
+import Prometheus.V3.Http.Serve
+import Prometheus.V3.Label
+import Prometheus.V3.Metric.Base
+import Prometheus.V3.Metric.Counter (Counter)
+import Prometheus.V3.Metric.Gauge (Gauge)
+import Prometheus.V3.Metric.Histogram (Histogram)
+import Prometheus.V3.Metric.Labelled
+import Prometheus.V3.Registry
+
diff --git a/src/Prometheus/V3/Collector.hs b/src/Prometheus/V3/Collector.hs
new file mode 100644
index 000000000..cd42cb6ca
--- /dev/null
+++ b/src/Prometheus/V3/Collector.hs
@@ -0,0 +1,39 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE NoFieldSelectors #-}
+
+module Prometheus.V3.Collector (
+    Collector (..),
+
+    -- * Re-exports
+    MetricName,
+    Description,
+    MetricType (..),
+    Sample (..),
+    SampleValue (..),
+    defaultSample,
+    ToSampleValue (..),
+) where
+
+import Prometheus.V3.Metric.Base (
+    Description,
+    MetricName,
+    MetricType (..),
+ )
+import Prometheus.V3.Sample (
+    Sample (..),
+    SampleValue (..),
+    ToSampleValue (..),
+    defaultSample,
+ )
+
+
+data Collector = Collector
+    { name :: MetricName
+    , description :: Description
+    , type_ :: MetricType
+    , getSamples :: IO [Sample]
+    }
diff --git a/src/Prometheus/V3/Encode.hs b/src/Prometheus/V3/Encode.hs
new file mode 100644
index 000000000..c838d7fcc
--- /dev/null
+++ b/src/Prometheus/V3/Encode.hs
@@ -0,0 +1,129 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Prometheus.V3.Encode (
+    encodeRegistrySample,
+
+    -- * Options
+    Options (..),
+    EscapeScheme (..),
+    defaultOptions,
+) where
+
+import Data.ByteString.Builder
+import qualified Data.List as List
+import qualified Data.Map as Map
+import Data.Text (Text)
+import qualified Data.Text.Encoding as Text
+import Prometheus.V3.Collector (Collector (..))
+import Prometheus.V3.Encode.Value
+import Prometheus.V3.Label (Label)
+import Prometheus.V3.Metric.Base (
+    MetricType (..),
+ )
+import Prometheus.V3.Name (EscapeScheme (..), showName)
+import Prometheus.V3.Registry (RegistrySample)
+import Prometheus.V3.Sample (
+    Sample (..),
+    SampleValue (..),
+ )
+
+
+data Options = Options
+    { escapeScheme :: EscapeScheme
+    }
+
+
+defaultOptions :: Options
+defaultOptions =
+    Options
+        { escapeScheme = EscapingUnderscores
+        }
+
+
+-- | Render 'RegistrySample' to Prometheus text format.
+encodeRegistrySample :: Options -> RegistrySample -> Builder
+encodeRegistrySample opts =
+    unlines2
+        . map (encodeCollectorSample opts)
+        . Map.elems
+  where
+    unlines2 s = intercalate (newline <> newline) s <> newline
+
+
+encodeCollectorSample :: Options -> (Collector, [Sample]) -> Builder
+encodeCollectorSample opts (collector, samples) =
+    intercalate newline $
+        [ "# HELP " <> name <> space <> description
+        , "# TYPE " <> name <> space <> type_
+        , intercalate newline $ map (encodeSample opts name) samples
+        ]
+  where
+    name = text $ showName opts.escapeScheme collector.name
+    description = text collector.description
+    type_ = encodeMetricType collector.type_
+
+
+encodeSample :: Options -> Builder -> Sample -> Builder
+encodeSample opts name sample =
+    mconcat
+        [ name <> text sample.suffix
+        , encodeLabels opts sample.labels
+        , space
+        , encodeSampleValue sample.value
+        ]
+
+
+encodeLabels :: Options -> [Label] -> Builder
+encodeLabels opts = \case
+    [] -> mempty
+    labels ->
+        mconcat
+            [ char8 '{'
+            , intercalate (char8 ',') . map (encodeLabel opts) $ labels
+            , char8 '}'
+            ]
+
+
+encodeLabel :: Options -> Label -> Builder
+encodeLabel opts (name, value) =
+    mconcat
+        [ text $ showName opts.escapeScheme name
+        , char8 '='
+        , text $ showPromText value
+        ]
+
+
+encodeSampleValue :: SampleValue -> Builder
+encodeSampleValue = \case
+    SampleValueInt64 n -> int64Dec n
+    SampleValueDouble n -> text $ showPromDouble n
+
+
+encodeMetricType :: MetricType -> Builder
+encodeMetricType = \case
+    MetricTypeCounter -> "counter"
+    MetricTypeGauge -> "gauge"
+    MetricTypeHistogram -> "histogram"
+    MetricTypeSummary -> "summary"
+    MetricTypeUntyped -> "untyped"
+
+
+{----- Helpers -----}
+
+text :: Text -> Builder
+text = byteString . Text.encodeUtf8
+
+
+intercalate :: (Monoid a) => a -> [a] -> a
+intercalate a = mconcat . List.intersperse a
+
+
+newline :: Builder
+newline = char8 '\n'
+
+
+space :: Builder
+space = char8 ' '
diff --git a/src/Prometheus/V3/Encode/Value.hs b/src/Prometheus/V3/Encode/Value.hs
new file mode 100644
index 000000000..b801ed36e
--- /dev/null
+++ b/src/Prometheus/V3/Encode/Value.hs
@@ -0,0 +1,17 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Prometheus.V3.Encode.Value (
+    showPromDouble,
+    showPromText,
+) where
+
+import Data.Text (Text)
+import qualified System.Metrics.Prometheus.Encode.Text.MetricId as V2
+
+
+showPromDouble :: Double -> Text
+showPromDouble = V2.textValue
+
+
+showPromText :: Text -> Text
+showPromText s = "\"" <> V2.escape s <> "\""
diff --git a/src/Prometheus/V3/Http/Serve.hs b/src/Prometheus/V3/Http/Serve.hs
new file mode 100644
index 000000000..30adfebcb
--- /dev/null
+++ b/src/Prometheus/V3/Http/Serve.hs
@@ -0,0 +1,87 @@
+{-# LANGUAGE DisambiguateRecordFields #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoFieldSelectors #-}
+
+module Prometheus.V3.Http.Serve (
+    serveMetrics,
+    serveMetricsWith,
+    Options (..),
+    defaultOptions,
+    app,
+) where
+
+import Control.Monad (void)
+import Control.Monad.IO.Class (liftIO)
+import Data.Text (Text)
+import qualified Network.HTTP.Types as HTTP
+import Network.Wai (
+    Application,
+    Request,
+    Response,
+ )
+import qualified Network.Wai as Wai
+import Network.Wai.Handler.Warp (Port)
+import qualified Network.Wai.Handler.Warp as Warp
+import Prometheus.V3.Encode (EscapeScheme (EscapingUnderscores))
+import qualified Prometheus.V3.Encode as Encode
+import Prometheus.V3.Registry (Registry, globalRegistry)
+import qualified Prometheus.V3.Registry as Registry
+import UnliftIO (MonadUnliftIO)
+import UnliftIO.Concurrent (forkIO)
+
+
+data Options = Options
+    { port :: Port
+    , path :: [Text]
+    -- ^ The path to serve the endpoint.
+    --
+    -- For example:
+    --   * @/@ => @[]@
+    --   * @/metrics@ => @["metrics"]@
+    , registry :: Registry
+    }
+
+
+defaultOptions :: Options
+defaultOptions =
+    Options
+        { port = 9090
+        , path = []
+        , registry = globalRegistry
+        }
+
+
+serveMetrics :: (MonadUnliftIO m) => Port -> m ()
+serveMetrics port = serveMetricsWith defaultOptions{port = port}
+
+
+serveMetricsWith :: (MonadUnliftIO m) => Options -> m ()
+serveMetricsWith opts = void . forkIO . liftIO $ Warp.run opts.port (app opts)
+
+
+app :: Options -> Application
+app opts request respond = (respond =<<) $ do
+    case (HTTP.parseMethod request.requestMethod, request.pathInfo) of
+        (Right HTTP.GET, path) | path == opts.path -> metricsResponse opts request
+        _ -> pure response404
+
+
+metricsResponse :: Options -> Request -> IO Response
+metricsResponse opts _ = do
+    samples <- Registry.sample opts.registry
+    let body = Encode.encodeRegistrySample encodeOpts samples
+    pure $ Wai.responseBuilder HTTP.status200 headers body
+  where
+    headers = [(HTTP.hContentType, "text/plain; version=0.0.4")]
+    encodeOpts =
+        Encode.Options
+            { escapeScheme = EscapingUnderscores -- TODO: parse from Accept header
+            }
+
+
+response404 :: Response
+response404 = Wai.responseLBS HTTP.status404 headers body
+  where
+    headers = [(HTTP.hContentType, "text/plain")]
+    body = ""
diff --git a/src/Prometheus/V3/Label.hs b/src/Prometheus/V3/Label.hs
new file mode 100644
index 000000000..82e9f5dc3
--- /dev/null
+++ b/src/Prometheus/V3/Label.hs
@@ -0,0 +1,211 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Prometheus.V3.Label (
+    LabelName,
+    LabelValue,
+    Label,
+    IsLabelValue (..),
+    IsLabelNameTuple (..),
+    IsLabelValueTuple (..),
+) where
+
+import Data.Hashable (Hashable)
+import Data.Text (Text)
+import qualified Data.Text as Text
+import Data.Tuple (Solo (..))
+import Prometheus.V3.Encode.Value (showPromDouble)
+import Prometheus.V3.LabelName (LabelName)
+
+
+type LabelValue = Text
+
+
+type Label = (LabelName, LabelValue)
+
+
+-- | A class for all types that can be used as the value of a Label.
+class (Hashable a) => IsLabelValue a where
+    toLabelValue :: a -> LabelValue
+
+
+instance IsLabelValue Text where
+    toLabelValue = id
+instance IsLabelValue Int where
+    toLabelValue = Text.pack . show
+instance IsLabelValue Double where
+    toLabelValue = showPromDouble
+
+
+class IsLabelNameTuple names where
+    toLabelNameList :: names -> [LabelName]
+
+
+class
+    ( IsLabelNameTuple (LabelTupleNames values)
+    , Hashable values
+    ) =>
+    IsLabelValueTuple values
+    where
+    type LabelTupleNames values
+    toLabelValueList :: values -> [LabelValue]
+
+
+instance IsLabelNameTuple LabelName where
+    toLabelNameList a = [a]
+instance (IsLabelValue a) => IsLabelValueTuple (Solo a) where
+    type LabelTupleNames (Solo a) = LabelName
+    toLabelValueList (MkSolo a) = [toLabelValue a]
+instance
+    IsLabelNameTuple
+        ( LabelName
+        , LabelName
+        )
+    where
+    toLabelNameList (a, b) = [a, b]
+instance
+    ( IsLabelValue a
+    , IsLabelValue b
+    ) =>
+    IsLabelValueTuple (a, b)
+    where
+    type LabelTupleNames (a, b) = (LabelName, LabelName)
+    toLabelValueList (a, b) = [toLabelValue a, toLabelValue b]
+instance
+    IsLabelNameTuple
+        ( LabelName
+        , LabelName
+        , LabelName
+        )
+    where
+    toLabelNameList (a, b, c) = [a, b, c]
+instance
+    ( IsLabelValue a
+    , IsLabelValue b
+    , IsLabelValue c
+    ) =>
+    IsLabelValueTuple (a, b, c)
+    where
+    type LabelTupleNames (a, b, c) = (LabelName, LabelName, LabelName)
+    toLabelValueList (a, b, c) =
+        [ toLabelValue a
+        , toLabelValue b
+        , toLabelValue c
+        ]
+instance
+    IsLabelNameTuple
+        ( LabelName
+        , LabelName
+        , LabelName
+        , LabelName
+        )
+    where
+    toLabelNameList (a, b, c, d) = [a, b, c, d]
+instance
+    ( IsLabelValue a
+    , IsLabelValue b
+    , IsLabelValue c
+    , IsLabelValue d
+    ) =>
+    IsLabelValueTuple (a, b, c, d)
+    where
+    type LabelTupleNames (a, b, c, d) = (LabelName, LabelName, LabelName, LabelName)
+    toLabelValueList (a, b, c, d) =
+        [ toLabelValue a
+        , toLabelValue b
+        , toLabelValue c
+        , toLabelValue d
+        ]
+instance
+    IsLabelNameTuple
+        ( LabelName
+        , LabelName
+        , LabelName
+        , LabelName
+        , LabelName
+        )
+    where
+    toLabelNameList (a, b, c, d, e) = [a, b, c, d, e]
+instance
+    ( IsLabelValue a
+    , IsLabelValue b
+    , IsLabelValue c
+    , IsLabelValue d
+    , IsLabelValue e
+    ) =>
+    IsLabelValueTuple (a, b, c, d, e)
+    where
+    type LabelTupleNames (a, b, c, d, e) = (LabelName, LabelName, LabelName, LabelName, LabelName)
+    toLabelValueList (a, b, c, d, e) =
+        [ toLabelValue a
+        , toLabelValue b
+        , toLabelValue c
+        , toLabelValue d
+        , toLabelValue e
+        ]
+instance
+    IsLabelNameTuple
+        ( LabelName
+        , LabelName
+        , LabelName
+        , LabelName
+        , LabelName
+        , LabelName
+        )
+    where
+    toLabelNameList (a, b, c, d, e, f) = [a, b, c, d, e, f]
+instance
+    ( IsLabelValue a
+    , IsLabelValue b
+    , IsLabelValue c
+    , IsLabelValue d
+    , IsLabelValue e
+    , IsLabelValue f
+    ) =>
+    IsLabelValueTuple (a, b, c, d, e, f)
+    where
+    type LabelTupleNames (a, b, c, d, e, f) = (LabelName, LabelName, LabelName, LabelName, LabelName, LabelName)
+    toLabelValueList (a, b, c, d, e, f) =
+        [ toLabelValue a
+        , toLabelValue b
+        , toLabelValue c
+        , toLabelValue d
+        , toLabelValue e
+        , toLabelValue f
+        ]
+instance
+    IsLabelNameTuple
+        ( LabelName
+        , LabelName
+        , LabelName
+        , LabelName
+        , LabelName
+        , LabelName
+        , LabelName
+        )
+    where
+    toLabelNameList (a, b, c, d, e, f, g) = [a, b, c, d, e, f, g]
+instance
+    ( IsLabelValue a
+    , IsLabelValue b
+    , IsLabelValue c
+    , IsLabelValue d
+    , IsLabelValue e
+    , IsLabelValue f
+    , IsLabelValue g
+    ) =>
+    IsLabelValueTuple (a, b, c, d, e, f, g)
+    where
+    type LabelTupleNames (a, b, c, d, e, f, g) = (LabelName, LabelName, LabelName, LabelName, LabelName, LabelName, LabelName)
+    toLabelValueList (a, b, c, d, e, f, g) =
+        [ toLabelValue a
+        , toLabelValue b
+        , toLabelValue c
+        , toLabelValue d
+        , toLabelValue e
+        , toLabelValue f
+        , toLabelValue g
+        ]
diff --git a/src/Prometheus/V3/LabelName.hs b/src/Prometheus/V3/LabelName.hs
new file mode 100644
index 000000000..4c3425d22
--- /dev/null
+++ b/src/Prometheus/V3/LabelName.hs
@@ -0,0 +1,51 @@
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Prometheus.V3.LabelName (
+    LabelName,
+    fromTextUnsafe,
+    fromText,
+) where
+
+import Data.Proxy (Proxy (..))
+import Data.String (IsString (..))
+import Data.Text (Text)
+import qualified Data.Text as Text
+import GHC.Stack (HasCallStack)
+import Prometheus.V3.Name (IsName (..), Name, makeName)
+
+
+-- | A LabelName can be any UTF-8 string, although it's recommended to match
+--   the regex @[a-zA-Z_][a-zA-Z0-9_]*@. It must not start with "__", which will
+--   be a runtime error.
+--
+-- https://prometheus.io/docs/concepts/data_model/
+newtype LabelName = LabelName Name
+    deriving stock (Show)
+    deriving newtype (Eq, Ord)
+
+
+instance IsString LabelName where
+    fromString = fromTextUnsafe . Text.pack
+instance IsName LabelName where
+    getName (LabelName name) = name
+    isValidLegacyChar _ c =
+        or
+            [ 'a' <= c && c <= 'z'
+            , 'A' <= c && c <= 'Z'
+            , '0' <= c && c <= '9'
+            , c == '_'
+            ]
+
+
+fromTextUnsafe :: (HasCallStack) => Text -> LabelName
+fromTextUnsafe = either (error . Text.unpack) id . fromText
+
+
+fromText :: Text -> Either Text LabelName
+fromText s
+    | Text.null s = Left "Label names must not be empty"
+    | "__" `Text.isPrefixOf` s = Left $ "Label names must not start with '__', got: " <> s
+    | otherwise = Right . LabelName $ makeName (Proxy @LabelName) s
diff --git a/src/Prometheus/V3/Metric/Base.hs b/src/Prometheus/V3/Metric/Base.hs
new file mode 100644
index 000000000..345cb87f6
--- /dev/null
+++ b/src/Prometheus/V3/Metric/Base.hs
@@ -0,0 +1,64 @@
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE NoFieldSelectors #-}
+
+module Prometheus.V3.Metric.Base (
+    MetricName,
+    Description,
+    Metric (..),
+    IsMetric (..),
+    MetricType (..),
+
+    -- * Helpers
+    withDuration,
+) where
+
+import Control.Monad.IO.Class (liftIO)
+import Data.Proxy (Proxy (..))
+import Data.Text (Text)
+import Data.Time (diffUTCTime, getCurrentTime)
+import Prometheus.V3.Label (LabelName)
+import Prometheus.V3.MetricName (MetricName)
+import Prometheus.V3.Sample (Sample)
+import UnliftIO (MonadUnliftIO)
+import UnliftIO.Exception (bracket)
+
+
+type Description = Text
+
+
+data Metric a = Metric
+    { name :: MetricName
+    , description :: Description
+    , initialize :: IO a
+    }
+
+
+data MetricType
+    = MetricTypeCounter
+    | MetricTypeGauge
+    | MetricTypeSummary
+    | MetricTypeHistogram
+    | MetricTypeUntyped
+    deriving stock (Show, Eq, Enum, Bounded)
+
+
+class IsMetric a where
+    {-# MINIMAL getMetricType, getMetricSamples #-}
+    getMetricType :: Proxy a -> MetricType
+    getMetricSamples :: a -> IO [Sample]
+
+
+    isValidMetricLabel :: Proxy a -> LabelName -> Bool
+    isValidMetricLabel _ _ = True
+
+
+{----- Helpers -----}
+
+withDuration :: (MonadUnliftIO m) => (Double -> m ()) -> m a -> m a
+withDuration f action = bracket (liftIO getCurrentTime) finalize (\_ -> action)
+  where
+    finalize start = do
+        end <- liftIO getCurrentTime
+        f (realToFrac $ end `diffUTCTime` start)
diff --git a/src/Prometheus/V3/Metric/Counter.hs b/src/Prometheus/V3/Metric/Counter.hs
new file mode 100644
index 000000000..ba322855b
--- /dev/null
+++ b/src/Prometheus/V3/Metric/Counter.hs
@@ -0,0 +1,114 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE NoFieldSelectors #-}
+-- Remove after inlining V2.Counter
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Prometheus.V3.Metric.Counter (
+    V2.Counter,
+    register,
+    new,
+
+    -- * Methods
+    IsCounter,
+    inc,
+    add,
+    reset,
+    sample,
+    addAndSample,
+
+    -- ** Helpers
+    countExceptions,
+    countExceptionsWhere,
+
+    -- * Re-exports
+    labels,
+) where
+
+import Control.Monad (when)
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import Prometheus.V3.Metric.Base
+import Prometheus.V3.Metric.Labelled (labels)
+import qualified Prometheus.V3.Registry as Registry
+import Prometheus.V3.Sample
+import qualified System.Metrics.Prometheus.Metric.Counter as V2
+import UnliftIO (MonadUnliftIO)
+import UnliftIO.Exception (Exception, withException)
+
+
+-- | An alias for @'Registry.register' (new ...)@.
+register :: MetricName -> Description -> V2.Counter
+register name description = Registry.register $ new name description
+{-# INLINE register #-}
+
+
+new :: MetricName -> Description -> Metric V2.Counter
+new name description =
+    Metric
+        { name
+        , description
+        , initialize = liftIO V2.new
+        }
+
+
+instance IsMetric V2.Counter where
+    getMetricType _ = MetricTypeCounter
+    getMetricSamples counter = do
+        n <- sample counter
+        pure [defaultSample{value = toSampleValue n}]
+
+
+class IsCounter c where
+    getCounter :: c -> IO V2.Counter
+instance IsCounter V2.Counter where
+    getCounter = pure
+instance IsCounter (IO V2.Counter) where
+    getCounter = id
+
+
+inc :: (IsCounter c, MonadIO m) => c -> m ()
+inc c = liftIO $ V2.inc =<< getCounter c
+{-# INLINE inc #-}
+
+
+add :: (IsCounter c, MonadIO m) => c -> Int -> m ()
+add c n = liftIO $ V2.add n =<< getCounter c
+{-# INLINE add #-}
+
+
+reset :: (IsCounter c, MonadIO m) => c -> m ()
+reset c = liftIO $ V2.set 0 =<< getCounter c
+{-# INLINE reset #-}
+
+
+sample :: (IsCounter c, MonadIO m) => c -> m Int
+sample c = liftIO $ fmap V2.unCounterSample . V2.sample =<< getCounter c
+{-# INLINE sample #-}
+
+
+addAndSample :: (IsCounter c, MonadIO m) => c -> Int -> m Int
+addAndSample c n = liftIO $ fmap V2.unCounterSample . V2.addAndSample n =<< getCounter c
+{-# INLINE addAndSample #-}
+
+
+{----- Helpers -----}
+
+-- | Count the number of times a particular exception is thrown.
+countExceptions ::
+    forall e c m a.
+    (IsCounter c, Exception e, MonadUnliftIO m) =>
+    c -> m a -> m a
+countExceptions c = countExceptionsWhere c (\(_ :: e) -> True)
+{-# INLINE countExceptions #-}
+
+
+-- | Like 'countExceptions', except provide a function to decide whether to
+-- include the exception in the count.
+countExceptionsWhere ::
+    forall e c m a.
+    (IsCounter c, Exception e, MonadUnliftIO m) =>
+    c -> (e -> Bool) -> m a -> m a
+countExceptionsWhere c f io = io `withException` \e -> when (f e) (inc c)
+{-# INLINE countExceptionsWhere #-}
diff --git a/src/Prometheus/V3/Metric/Gauge.hs b/src/Prometheus/V3/Metric/Gauge.hs
new file mode 100644
index 000000000..f0f87e9a4
--- /dev/null
+++ b/src/Prometheus/V3/Metric/Gauge.hs
@@ -0,0 +1,135 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE NoFieldSelectors #-}
+-- Remove after inlining V2.Gauge
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Prometheus.V3.Metric.Gauge (
+    V2.Gauge,
+    register,
+    new,
+    newAt,
+
+    -- * Methods
+    IsGauge,
+    inc,
+    add,
+    dec,
+    sub,
+    set,
+    sample,
+    modifyAndSample,
+
+    -- ** Helpers
+    setToCurrentTime,
+    trackInProgress,
+    time,
+
+    -- * Re-exports
+    labels,
+) where
+
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import Data.Time.Clock.POSIX (getPOSIXTime)
+import Prometheus.V3.Metric.Base
+import Prometheus.V3.Metric.Labelled (labels)
+import qualified Prometheus.V3.Registry as Registry
+import Prometheus.V3.Sample
+import qualified System.Metrics.Prometheus.Metric.Gauge as V2
+import UnliftIO (MonadUnliftIO)
+import UnliftIO.Exception (bracket_)
+
+
+-- | An alias for @'Registry.register' (new ...)@.
+register :: MetricName -> Description -> V2.Gauge
+register name description = Registry.register $ new name description
+{-# INLINE register #-}
+
+
+new :: MetricName -> Description -> Metric V2.Gauge
+new name description = newAt name description 0
+
+
+newAt :: MetricName -> Description -> Double -> Metric V2.Gauge
+newAt name description val =
+    Metric
+        { name
+        , description
+        , initialize = do
+            gauge <- V2.new
+            set gauge val
+            pure gauge
+        }
+
+
+instance IsMetric V2.Gauge where
+    getMetricType _ = MetricTypeGauge
+    getMetricSamples gauge = do
+        n <- sample gauge
+        pure [defaultSample{value = toSampleValue n}]
+
+
+class IsGauge g where
+    getGauge :: g -> IO V2.Gauge
+instance IsGauge V2.Gauge where
+    getGauge = pure
+instance IsGauge (IO V2.Gauge) where
+    getGauge = id
+
+
+inc :: (IsGauge g, MonadIO m) => g -> m ()
+inc g = liftIO $ V2.inc =<< getGauge g
+{-# INLINE inc #-}
+
+
+add :: (IsGauge g, MonadIO m) => g -> Double -> m ()
+add g x = liftIO $ V2.add x =<< getGauge g
+{-# INLINE add #-}
+
+
+dec :: (IsGauge g, MonadIO m) => g -> m ()
+dec g = liftIO $ V2.dec =<< getGauge g
+{-# INLINE dec #-}
+
+
+sub :: (IsGauge g, MonadIO m) => g -> Double -> m ()
+sub g x = liftIO $ V2.sub x =<< getGauge g
+{-# INLINE sub #-}
+
+
+set :: (IsGauge g, MonadIO m) => g -> Double -> m ()
+set g x = liftIO $ V2.set x =<< getGauge g
+{-# INLINE set #-}
+
+
+sample :: (IsGauge g, MonadIO m) => g -> m Double
+sample g = liftIO $ fmap V2.unGaugeSample . V2.sample =<< getGauge g
+{-# INLINE sample #-}
+
+
+modifyAndSample :: (IsGauge g, MonadIO m) => g -> (Double -> Double) -> m Double
+modifyAndSample g f = liftIO $ fmap V2.unGaugeSample . V2.modifyAndSample f =<< getGauge g
+{-# INLINE modifyAndSample #-}
+
+
+{----- Helpers -----}
+
+-- | Set to the current number of seconds since the epoch.
+setToCurrentTime :: (IsGauge g, MonadIO m) => g -> m ()
+setToCurrentTime g = do
+    now <- liftIO getPOSIXTime
+    g' <- liftIO $ getGauge g
+    set g' (realToFrac now)
+{-# INLINE setToCurrentTime #-}
+
+
+-- | Increment the gauge when the given action is running and decrement when it's exited.
+trackInProgress :: (IsGauge g, MonadUnliftIO m) => g -> m a -> m a
+trackInProgress g = bracket_ (inc g) (dec g)
+{-# INLINE trackInProgress #-}
+
+
+-- | Set the gauge to the duration of the given action.
+time :: (IsGauge g, MonadUnliftIO m) => g -> m a -> m a
+time g = withDuration (set g)
+{-# INLINE time #-}
diff --git a/src/Prometheus/V3/Metric/Histogram.hs b/src/Prometheus/V3/Metric/Histogram.hs
new file mode 100644
index 000000000..c525be760
--- /dev/null
+++ b/src/Prometheus/V3/Metric/Histogram.hs
@@ -0,0 +1,138 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+-- Remove after inlining V2.Histogram
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Prometheus.V3.Metric.Histogram (
+    V2.Histogram,
+    register,
+    new,
+
+    -- * Specifying bounds
+    linearBuckets,
+    expBuckets,
+
+    -- * Methods
+    IsHistogram,
+    reset,
+    observe,
+    sample,
+    observeAndSample,
+
+    -- ** Helpers
+    time,
+
+    -- * Re-exports
+    labels,
+) where
+
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import qualified Data.Map as Map
+import Prometheus.V3.Label (toLabelValue)
+import Prometheus.V3.Metric.Base
+import Prometheus.V3.Metric.Labelled (labels)
+import qualified Prometheus.V3.Registry as Registry
+import Prometheus.V3.Sample
+import qualified System.Metrics.Prometheus.Metric.Histogram as V2
+import UnliftIO (MonadUnliftIO)
+
+
+-- | An alias for @'Registry.register' (new ...)@.
+register :: MetricName -> Description -> [V2.UpperBound] -> V2.Histogram
+register name description bounds = Registry.register $ new name description bounds
+{-# INLINE register #-}
+
+
+new ::
+    MetricName ->
+    Description ->
+    [V2.UpperBound] ->
+    Metric V2.Histogram
+new name description bounds =
+    Metric
+        { name
+        , description
+        , initialize = liftIO $ V2.new bounds
+        }
+
+
+instance IsMetric V2.Histogram where
+    getMetricType _ = MetricTypeHistogram
+    getMetricSamples hist = do
+        V2.HistogramSample{..} <- sample hist
+        let sumSample = defaultSample{suffix = "_sum", value = toSampleValue histSum}
+            countSample = defaultSample{suffix = "_count", value = toSampleValue histCount}
+            bucketSamples =
+                [ defaultSample
+                    { suffix = "_bucket"
+                    , labels = [("le", toLabelValue upperBound)]
+                    , value = toSampleValue n
+                    }
+                | (upperBound, n) <- Map.toList histBuckets
+                ]
+        pure $ [sumSample, countSample] ++ bucketSamples
+
+
+    isValidMetricLabel _ = \case
+        "le" -> False -- https://prometheus.io/docs/instrumenting/writing_clientlibs/#histogram
+        _ -> True
+
+
+linearBuckets ::
+    -- | Start
+    V2.UpperBound ->
+    -- | Width
+    Double ->
+    -- | Count
+    Int ->
+    [V2.UpperBound]
+linearBuckets start width count = [start + (width * fromIntegral i) | i <- [1 .. count]]
+
+
+expBuckets ::
+    -- | Start
+    V2.UpperBound ->
+    -- | Factor
+    Double ->
+    -- | Count
+    Int ->
+    [V2.UpperBound]
+expBuckets start factor count = [start * (factor ** fromIntegral i) | i <- [1 .. count]]
+
+
+class IsHistogram h where
+    getHistogram :: h -> IO V2.Histogram
+instance IsHistogram V2.Histogram where
+    getHistogram = pure
+instance IsHistogram (IO V2.Histogram) where
+    getHistogram = id
+
+
+reset :: (IsHistogram h, MonadIO m) => h -> m ()
+reset h = liftIO $ V2.reset =<< getHistogram h
+{-# INLINE reset #-}
+
+
+observe :: (IsHistogram h, MonadIO m) => h -> Double -> m ()
+observe h x = liftIO $ V2.observe x =<< getHistogram h
+{-# INLINE observe #-}
+
+
+sample :: (IsHistogram h, MonadIO m) => h -> m V2.HistogramSample
+sample h = liftIO $ V2.sample =<< getHistogram h
+{-# INLINE sample #-}
+
+
+observeAndSample :: (IsHistogram h, MonadIO m) => h -> Double -> m V2.HistogramSample
+observeAndSample h x = liftIO $ V2.observeAndSample x =<< getHistogram h
+{-# INLINE observeAndSample #-}
+
+
+{----- Helpers -----}
+
+time :: (IsHistogram h, MonadUnliftIO m) => h -> m a -> m a
+time h = withDuration (observe h)
+{-# INLINE time #-}
diff --git a/src/Prometheus/V3/Metric/Labelled.hs b/src/Prometheus/V3/Metric/Labelled.hs
new file mode 100644
index 000000000..a21202d44
--- /dev/null
+++ b/src/Prometheus/V3/Metric/Labelled.hs
@@ -0,0 +1,95 @@
+{-# LANGUAGE DisambiguateRecordFields #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE NoFieldSelectors #-}
+
+module Prometheus.V3.Metric.Labelled (
+    Labelled (..),
+    withLabels,
+    labels,
+) where
+
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HashMap
+import Data.Hashable (Hashable)
+import Data.Proxy (Proxy (..))
+import Prometheus.V3.Label (
+    IsLabelValueTuple,
+    LabelTupleNames,
+    toLabelNameList,
+    toLabelValueList,
+ )
+import Prometheus.V3.Metric.Base
+import Prometheus.V3.Sample (Sample (..))
+import UnliftIO.MVar (MVar, modifyMVar, newMVar, readMVar)
+
+
+data Labelled l a = Labelled
+    { labelNames :: LabelTupleNames l
+    , initChild :: IO a
+    , metricMapVar :: MVar (HashMap l a)
+    }
+
+
+withLabels ::
+    forall l a.
+    (IsMetric a, IsLabelValueTuple l) =>
+    LabelTupleNames l ->
+    [l] ->
+    Metric a ->
+    Metric (Labelled l a)
+withLabels labelNames initialLabels metric =
+    validateLabelNames
+        metric
+            { initialize = do
+                metricMap <-
+                    fmap HashMap.fromList . sequence $
+                        [ (vals,) <$> metric.initialize
+                        | vals <- initialLabels
+                        ]
+                metricMapVar <- newMVar metricMap
+                pure
+                    Labelled
+                        { labelNames
+                        , initChild = metric.initialize
+                        , metricMapVar
+                        }
+            }
+  where
+    -- TODO: error on duplicate labels
+    validateLabelNames =
+        case filter (not . isValid) (toLabelNameList labelNames) of
+            [] -> id
+            invalidNames -> error $ "Invalid label names: " <> show invalidNames
+
+    isValid = isValidMetricLabel (Proxy @a)
+
+
+labels :: (Hashable l) => l -> Labelled l a -> IO a
+labels labelVals labelled =
+    modifyMVar labelled.metricMapVar $ \metricMap -> do
+        case HashMap.lookup labelVals metricMap of
+            Just child -> pure (metricMap, child)
+            Nothing -> do
+                child <- labelled.initChild
+                pure (HashMap.insert labelVals child metricMap, child)
+
+
+instance (IsMetric a, IsLabelValueTuple l) => IsMetric (Labelled l a) where
+    getMetricType _ = getMetricType (Proxy @a)
+    getMetricSamples labelled = do
+        metricMap <- readMVar labelled.metricMapVar
+        samplesMap <- traverse getMetricSamples metricMap
+        pure
+            [ sample
+                { labels = zip labelNameList (toLabelValueList labelVals) <> sample.labels
+                }
+            | (labelVals, samples) <- HashMap.toList samplesMap
+            , sample <- samples
+            ]
+      where
+        labelNameList = toLabelNameList labelled.labelNames
diff --git a/src/Prometheus/V3/MetricName.hs b/src/Prometheus/V3/MetricName.hs
new file mode 100644
index 000000000..a4dc3e07d
--- /dev/null
+++ b/src/Prometheus/V3/MetricName.hs
@@ -0,0 +1,61 @@
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Prometheus.V3.MetricName (
+    MetricName,
+    fromTextUnsafe,
+    fromText,
+    toText,
+    toName,
+) where
+
+import Data.Proxy (Proxy (..))
+import Data.String (IsString (..))
+import Data.Text (Text)
+import qualified Data.Text as Text
+import GHC.Stack (HasCallStack)
+import Prometheus.V3.Name (IsName (..), Name, makeName)
+import qualified Prometheus.V3.Name as Name
+
+
+-- | A Name can be any UTF-8 string, although it's recommended to match the
+--   regex @[a-zA-Z_:][a-zA-Z0-9_:]*@.
+--
+-- https://prometheus.io/docs/concepts/data_model/
+newtype MetricName = MetricName Name
+    deriving stock (Show)
+    deriving newtype (Eq, Ord)
+
+
+instance IsString MetricName where
+    fromString = fromTextUnsafe . Text.pack
+instance IsName MetricName where
+    getName (MetricName name) = name
+    isValidLegacyChar _ c =
+        or
+            [ 'a' <= c && c <= 'z'
+            , 'A' <= c && c <= 'Z'
+            , '0' <= c && c <= '9'
+            , c == '_'
+            , c == ':'
+            ]
+
+
+fromTextUnsafe :: (HasCallStack) => Text -> MetricName
+fromTextUnsafe = either (error . Text.unpack) id . fromText
+
+
+fromText :: Text -> Either Text MetricName
+fromText s
+    | Text.null s = Left "Metric names must not be empty"
+    | otherwise = Right . MetricName $ makeName (Proxy @MetricName) s
+
+
+toText :: MetricName -> Text
+toText = Name.toText . toName
+
+
+toName :: MetricName -> Name
+toName (MetricName n) = n
diff --git a/src/Prometheus/V3/Name.hs b/src/Prometheus/V3/Name.hs
new file mode 100644
index 000000000..5b790110c
--- /dev/null
+++ b/src/Prometheus/V3/Name.hs
@@ -0,0 +1,115 @@
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Prometheus.V3.Name (
+    Name,
+    IsName (..),
+    makeName,
+    NeedsEscape (..),
+    EscapeScheme (..),
+    toText,
+    showName,
+) where
+
+import Data.Char (isDigit)
+import Data.Proxy (Proxy (..))
+import Data.Text (Text)
+import qualified Data.Text as Text
+
+
+data Name
+    = Name
+        -- | The actual Name
+        Text
+        -- | A cached value precomputed from the Name
+        NeedsEscape
+    deriving stock (Show)
+
+
+-- | Two Names are equal if and only if the raw Text is equivalent.
+-- To check if two Names are equal modulo normalization, check equality on the
+-- result of 'showName'.
+instance Eq Name where
+    Name s1 _ == Name s2 _ = s1 == s2
+
+
+-- | Names are compared only with their raw Text. To compare normalized Names,
+-- use 'showName'.
+instance Ord Name where
+    Name s1 _ `compare` Name s2 _ = s1 `compare` s2
+
+
+toText :: Name -> Text
+toText (Name s _) = s
+
+
+class IsName a where
+    getName :: a -> Name
+    isValidLegacyChar :: Proxy a -> Char -> Bool
+
+
+isValidLegacyHeadChar :: (IsName a) => Proxy a -> Char -> Bool
+isValidLegacyHeadChar proxy c =
+    isValidLegacyChar proxy c && (not . isDigit) c
+
+
+makeName :: (IsName a) => Proxy a -> Text -> Name
+makeName proxy s = Name s needsEscape
+  where
+    needsEscape =
+        case Text.uncons s of
+            Just (c, cs)
+                | isValidLegacyHeadChar proxy c
+                , Text.all (isValidLegacyChar proxy) cs ->
+                    NoNeedsEscape
+            _ -> NeedsEscape
+
+
+-- | A flag to precompute whether a name needs escaping or not.
+-- This way, in the happy path where names don't need escaping, we
+-- validate the name once at registration and encoding the name is
+-- immediate.
+data NeedsEscape = NeedsEscape | NoNeedsEscape
+    deriving stock (Show)
+
+
+-- | https://prometheus.io/docs/instrumenting/escaping_schemes/
+data EscapeScheme
+    = -- | escaping=allow-utf-8
+      NoEscaping
+    | -- | escaping=underscores
+      EscapingUnderscores
+    | -- | escaping=dots
+      EscapingDots
+    | -- | escaping=values
+      EscapingValues
+
+
+showName :: forall a. (IsName a) => EscapeScheme -> a -> Text
+showName scheme a =
+    case needsEscape of
+        NoNeedsEscape -> name
+        NeedsEscape -> escapeName (Proxy @a) scheme name
+  where
+    Name name needsEscape = getName a
+
+
+escapeName :: (IsName a) => Proxy a -> EscapeScheme -> Text -> Text
+escapeName proxy = \case
+    NoEscaping -> id
+    EscapingUnderscores -> escapeUnderscores proxy
+    EscapingDots -> error "escaping=dots is not yet supported" -- TODO
+    EscapingValues -> error "escaping=values is not yet supported" -- TODO
+
+
+escapeUnderscores :: (IsName a) => Proxy a -> Text -> Text
+escapeUnderscores proxy s = prefix <> Text.map replace s
+  where
+    prefix =
+        case Text.uncons s of
+            Just (c, _) | isValidLegacyHeadChar proxy c -> ""
+            _ -> "_"
+    replace c = if isValidLegacyChar proxy c then c else '_'
diff --git a/src/Prometheus/V3/Registry.hs b/src/Prometheus/V3/Registry.hs
new file mode 100644
index 000000000..dd0eb149c
--- /dev/null
+++ b/src/Prometheus/V3/Registry.hs
@@ -0,0 +1,114 @@
+{-# LANGUAGE DisambiguateRecordFields #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE NoFieldSelectors #-}
+
+module Prometheus.V3.Registry (
+    Registry (..),
+    new,
+    globalRegistry,
+    register,
+    registerTo,
+    unregisterFrom,
+    ToCollector,
+
+    -- * Sampling
+    RegistrySample,
+    sample,
+) where
+
+import Control.Monad (forM)
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Proxy (Proxy (..))
+import Prometheus.V3.Collector (Collector (..))
+import Prometheus.V3.Metric.Base (
+    Description,
+    IsMetric,
+    Metric (..),
+    MetricName,
+    MetricType,
+    getMetricSamples,
+    getMetricType,
+ )
+import Prometheus.V3.Sample (Sample)
+import System.IO.Unsafe (unsafePerformIO)
+import UnliftIO.IORef (IORef, atomicModifyIORef', newIORef, readIORef)
+
+
+newtype Registry = Registry (IORef (Map MetricName Collector))
+
+
+new :: (MonadIO m) => m Registry
+new = Registry <$> newIORef Map.empty
+
+
+globalRegistry :: Registry
+globalRegistry = unsafePerformIO new
+{-# OPAQUE globalRegistry #-}
+
+
+class ToCollector a where
+    type RegisterResult a
+    getCollectorName :: a -> MetricName
+    getCollectorDescription :: a -> Description
+    getCollectorType :: a -> MetricType
+    getCollectorSample :: a -> IO (IO [Sample], RegisterResult a)
+instance ToCollector Collector where
+    type RegisterResult Collector = Collector
+    getCollectorName = (.name)
+    getCollectorDescription = (.description)
+    getCollectorType = (.type_)
+    getCollectorSample collector = pure (collector.getSamples, collector)
+instance (IsMetric a) => ToCollector (Metric a) where
+    type RegisterResult (Metric a) = a
+    getCollectorName = (.name)
+    getCollectorDescription = (.description)
+    getCollectorType _ = getMetricType (Proxy @a)
+    getCollectorSample metric = do
+        a <- metric.initialize
+        pure (getMetricSamples a, a)
+
+
+-- | Register the given metric with the global registry.
+--
+-- Only safe to use with top-level variables, which must be annotated with OPAQUE.
+register :: (ToCollector a) => a -> RegisterResult a
+register = unsafePerformIO . registerTo globalRegistry
+{-# INLINE register #-}
+
+
+-- | Register the given metric with the given registry.
+registerTo :: (ToCollector a) => Registry -> a -> IO (RegisterResult a)
+registerTo (Registry registryMapRef) a = do
+    let name = getCollectorName a
+        description = getCollectorDescription a
+        type_ = getCollectorType a
+    (getSamples, res) <- getCollectorSample a
+    atomicModifyIORef' registryMapRef $ \registryMap ->
+        (Map.insert name Collector{..} registryMap, ())
+    pure res
+
+
+-- | Unregister the given metric from the given registry.
+unregisterFrom :: (ToCollector a) => Registry -> a -> IO ()
+unregisterFrom (Registry registryMapRef) a = do
+    atomicModifyIORef' registryMapRef $ \registryMap ->
+        (Map.delete (getCollectorName a) registryMap, ())
+
+
+type RegistrySample = Map MetricName (Collector, [Sample])
+
+
+sample :: (MonadIO m) => Registry -> m RegistrySample
+sample (Registry registryMapRef) = do
+    registryMap <- readIORef registryMapRef
+    liftIO . forM registryMap $ \collector -> do
+        samples <- collector.getSamples
+        -- TODO: revalidate labels with same logic as Labelled, for custom collectors
+        pure (collector, samples)
diff --git a/src/Prometheus/V3/Sample.hs b/src/Prometheus/V3/Sample.hs
new file mode 100644
index 000000000..3670d3c9b
--- /dev/null
+++ b/src/Prometheus/V3/Sample.hs
@@ -0,0 +1,51 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoFieldSelectors #-}
+
+module Prometheus.V3.Sample (
+    Sample (..),
+    defaultSample,
+
+    -- * SampleValue
+    SampleValue (..),
+    ToSampleValue (..),
+) where
+
+import Data.Int (Int64)
+import Data.Text (Text)
+import Data.Word (Word64)
+import Prometheus.V3.Label (Label)
+
+
+data Sample = Sample
+    { suffix :: Text
+    , labels :: [Label]
+    , value :: SampleValue
+    }
+
+
+data SampleValue
+    = SampleValueInt64 Int64
+    | SampleValueDouble Double
+
+
+defaultSample :: Sample
+defaultSample =
+    Sample
+        { suffix = ""
+        , labels = []
+        , value = SampleValueInt64 0
+        }
+
+
+class ToSampleValue a where
+    toSampleValue :: a -> SampleValue
+instance ToSampleValue Int where
+    toSampleValue = SampleValueInt64 . fromIntegral
+instance ToSampleValue Int64 where
+    toSampleValue = SampleValueInt64
+instance ToSampleValue Word64 where
+    toSampleValue = SampleValueInt64 . fromIntegral
+instance ToSampleValue Double where
+    toSampleValue = SampleValueDouble
+instance ToSampleValue Float where
+    toSampleValue = SampleValueDouble . realToFrac

From 357c13e6c739eec490c6cde9526e4c758f8fc372 Mon Sep 17 00:00:00 2001
From: Brandon Chinn <brandonchinn178@gmail.com>
Date: Fri, 26 Jun 2026 12:39:09 -0700
Subject: [PATCH 2/4] Make Gauge polymorphic

---
 prometheus.cabal                              |  1 +
 src/Prometheus/V3/Metric/Gauge.hs             | 54 ++++++++++++-------
 src/Prometheus/V3/Sample.hs                   |  5 ++
 src/Prometheus/V3/Utils/FromRealFrac.hs       | 21 ++++++++
 .../Metrics/Prometheus/Concurrent/Registry.hs |  2 +-
 .../Prometheus/Concurrent/RegistryT.hs        |  2 +-
 src/System/Metrics/Prometheus/Encode/Text.hs  |  2 +-
 src/System/Metrics/Prometheus/Metric.hs       |  9 ++--
 src/System/Metrics/Prometheus/Metric/Gauge.hs | 20 +++----
 src/System/Metrics/Prometheus/Registry.hs     |  2 +-
 src/System/Metrics/Prometheus/RegistryT.hs    |  2 +-
 11 files changed, 81 insertions(+), 39 deletions(-)
 create mode 100644 src/Prometheus/V3/Utils/FromRealFrac.hs

diff --git a/prometheus.cabal b/prometheus.cabal
index 1da7a1beb..da84d3dc1 100644
--- a/prometheus.cabal
+++ b/prometheus.cabal
@@ -103,6 +103,7 @@ library
                  , Prometheus.V3.Name
                  , Prometheus.V3.Registry
                  , Prometheus.V3.Sample
+                 , Prometheus.V3.Utils.FromRealFrac
 
   build-depends: base            >= 4.9  && < 5
                , atomic-primops  >= 0.8  && < 0.9
diff --git a/src/Prometheus/V3/Metric/Gauge.hs b/src/Prometheus/V3/Metric/Gauge.hs
index f0f87e9a4..3f123d7d9 100644
--- a/src/Prometheus/V3/Metric/Gauge.hs
+++ b/src/Prometheus/V3/Metric/Gauge.hs
@@ -1,5 +1,9 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE NoFieldSelectors #-}
 -- Remove after inlining V2.Gauge
 {-# OPTIONS_GHC -Wno-orphans #-}
@@ -12,6 +16,7 @@ module Prometheus.V3.Metric.Gauge (
 
     -- * Methods
     IsGauge,
+    IsNumGauge,
     inc,
     add,
     dec,
@@ -35,22 +40,23 @@ import Prometheus.V3.Metric.Base
 import Prometheus.V3.Metric.Labelled (labels)
 import qualified Prometheus.V3.Registry as Registry
 import Prometheus.V3.Sample
+import Prometheus.V3.Utils.FromRealFrac (FromRealFrac, fromRealFrac)
 import qualified System.Metrics.Prometheus.Metric.Gauge as V2
 import UnliftIO (MonadUnliftIO)
 import UnliftIO.Exception (bracket_)
 
 
 -- | An alias for @'Registry.register' (new ...)@.
-register :: MetricName -> Description -> V2.Gauge
+register :: (Num a, ToSampleValue a) => MetricName -> Description -> V2.Gauge a
 register name description = Registry.register $ new name description
 {-# INLINE register #-}
 
 
-new :: MetricName -> Description -> Metric V2.Gauge
+new :: (Num a) => MetricName -> Description -> Metric (V2.Gauge a)
 new name description = newAt name description 0
 
 
-newAt :: MetricName -> Description -> Double -> Metric V2.Gauge
+newAt :: (Num a) => MetricName -> Description -> a -> Metric (V2.Gauge a)
 newAt name description val =
     Metric
         { name
@@ -62,7 +68,7 @@ newAt name description val =
         }
 
 
-instance IsMetric V2.Gauge where
+instance (SampleValueNum a) => IsMetric (V2.Gauge a) where
     getMetricType _ = MetricTypeGauge
     getMetricSamples gauge = do
         n <- sample gauge
@@ -70,44 +76,50 @@ instance IsMetric V2.Gauge where
 
 
 class IsGauge g where
-    getGauge :: g -> IO V2.Gauge
-instance IsGauge V2.Gauge where
+    type GaugeElem g
+    getGauge :: g -> IO (V2.Gauge (GaugeElem g))
+instance IsGauge (V2.Gauge a) where
+    type GaugeElem (V2.Gauge a) = a
     getGauge = pure
-instance IsGauge (IO V2.Gauge) where
+instance IsGauge (IO (V2.Gauge a)) where
+    type GaugeElem (IO (V2.Gauge a)) = a
     getGauge = id
 
 
-inc :: (IsGauge g, MonadIO m) => g -> m ()
+type IsNumGauge g a = (IsGauge g, a ~ GaugeElem g, Num a)
+
+
+inc :: (IsNumGauge g a, MonadIO m) => g -> m ()
 inc g = liftIO $ V2.inc =<< getGauge g
 {-# INLINE inc #-}
 
 
-add :: (IsGauge g, MonadIO m) => g -> Double -> m ()
+add :: (IsNumGauge g a, MonadIO m) => g -> a -> m ()
 add g x = liftIO $ V2.add x =<< getGauge g
 {-# INLINE add #-}
 
 
-dec :: (IsGauge g, MonadIO m) => g -> m ()
+dec :: (IsNumGauge g a, MonadIO m) => g -> m ()
 dec g = liftIO $ V2.dec =<< getGauge g
 {-# INLINE dec #-}
 
 
-sub :: (IsGauge g, MonadIO m) => g -> Double -> m ()
+sub :: (IsNumGauge g a, MonadIO m) => g -> a -> m ()
 sub g x = liftIO $ V2.sub x =<< getGauge g
 {-# INLINE sub #-}
 
 
-set :: (IsGauge g, MonadIO m) => g -> Double -> m ()
+set :: (IsNumGauge g a, MonadIO m) => g -> a -> m ()
 set g x = liftIO $ V2.set x =<< getGauge g
 {-# INLINE set #-}
 
 
-sample :: (IsGauge g, MonadIO m) => g -> m Double
+sample :: (IsNumGauge g a, MonadIO m) => g -> m a
 sample g = liftIO $ fmap V2.unGaugeSample . V2.sample =<< getGauge g
 {-# INLINE sample #-}
 
 
-modifyAndSample :: (IsGauge g, MonadIO m) => g -> (Double -> Double) -> m Double
+modifyAndSample :: (IsNumGauge g a, MonadIO m) => g -> (a -> a) -> m a
 modifyAndSample g f = liftIO $ fmap V2.unGaugeSample . V2.modifyAndSample f =<< getGauge g
 {-# INLINE modifyAndSample #-}
 
@@ -115,21 +127,25 @@ modifyAndSample g f = liftIO $ fmap V2.unGaugeSample . V2.modifyAndSample f =<<
 {----- Helpers -----}
 
 -- | Set to the current number of seconds since the epoch.
-setToCurrentTime :: (IsGauge g, MonadIO m) => g -> m ()
+setToCurrentTime ::
+    (IsGauge g, FromRealFrac (GaugeElem g), MonadIO m) =>
+    g -> m ()
 setToCurrentTime g = do
     now <- liftIO getPOSIXTime
     g' <- liftIO $ getGauge g
-    set g' (realToFrac now)
+    set g' (fromRealFrac now)
 {-# INLINE setToCurrentTime #-}
 
 
 -- | Increment the gauge when the given action is running and decrement when it's exited.
-trackInProgress :: (IsGauge g, MonadUnliftIO m) => g -> m a -> m a
+trackInProgress :: (IsNumGauge g a, MonadUnliftIO m) => g -> m a -> m a
 trackInProgress g = bracket_ (inc g) (dec g)
 {-# INLINE trackInProgress #-}
 
 
 -- | Set the gauge to the duration of the given action.
-time :: (IsGauge g, MonadUnliftIO m) => g -> m a -> m a
-time g = withDuration (set g)
+time ::
+    (IsGauge g, FromRealFrac (GaugeElem g), MonadUnliftIO m) =>
+    g -> m a -> m a
+time g = withDuration (set g . fromRealFrac)
 {-# INLINE time #-}
diff --git a/src/Prometheus/V3/Sample.hs b/src/Prometheus/V3/Sample.hs
index 3670d3c9b..f7a23f372 100644
--- a/src/Prometheus/V3/Sample.hs
+++ b/src/Prometheus/V3/Sample.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE NoFieldSelectors #-}
 
@@ -8,6 +9,7 @@ module Prometheus.V3.Sample (
     -- * SampleValue
     SampleValue (..),
     ToSampleValue (..),
+    SampleValueNum,
 ) where
 
 import Data.Int (Int64)
@@ -49,3 +51,6 @@ instance ToSampleValue Double where
     toSampleValue = SampleValueDouble
 instance ToSampleValue Float where
     toSampleValue = SampleValueDouble . realToFrac
+
+
+type SampleValueNum a = (Num a, ToSampleValue a)
diff --git a/src/Prometheus/V3/Utils/FromRealFrac.hs b/src/Prometheus/V3/Utils/FromRealFrac.hs
new file mode 100644
index 000000000..58d81d15f
--- /dev/null
+++ b/src/Prometheus/V3/Utils/FromRealFrac.hs
@@ -0,0 +1,21 @@
+module Prometheus.V3.Utils.FromRealFrac (
+    FromRealFrac (..),
+) where
+
+import Data.Word (Word64)
+
+
+class (Num a) => FromRealFrac a where
+    fromRealFrac :: (RealFrac x) => x -> a
+
+
+instance FromRealFrac Int where
+    fromRealFrac = round
+instance FromRealFrac Word64 where
+    fromRealFrac = round
+
+
+instance FromRealFrac Double where
+    fromRealFrac = realToFrac
+instance FromRealFrac Float where
+    fromRealFrac = realToFrac
diff --git a/src/System/Metrics/Prometheus/Concurrent/Registry.hs b/src/System/Metrics/Prometheus/Concurrent/Registry.hs
index 123791433..2b50dbf51 100644
--- a/src/System/Metrics/Prometheus/Concurrent/Registry.hs
+++ b/src/System/Metrics/Prometheus/Concurrent/Registry.hs
@@ -46,7 +46,7 @@ registerCounter name labels = flip modifyMVarMasked register . unRegistry
     register = fmap swap . R.registerCounter name labels
 
 
-registerGauge :: Name -> Labels -> Registry -> IO Gauge
+registerGauge :: Name -> Labels -> Registry -> IO (Gauge Double)
 registerGauge name labels = flip modifyMVarMasked register . unRegistry
   where
     register = fmap swap . R.registerGauge name labels
diff --git a/src/System/Metrics/Prometheus/Concurrent/RegistryT.hs b/src/System/Metrics/Prometheus/Concurrent/RegistryT.hs
index 3b2b9208f..c67757224 100644
--- a/src/System/Metrics/Prometheus/Concurrent/RegistryT.hs
+++ b/src/System/Metrics/Prometheus/Concurrent/RegistryT.hs
@@ -39,7 +39,7 @@ registerCounter :: MonadIO m => Name -> Labels -> RegistryT m Counter
 registerCounter n l = RegistryT ask >>= liftIO . R.registerCounter n l
 
 
-registerGauge :: MonadIO m => Name -> Labels -> RegistryT m Gauge
+registerGauge :: MonadIO m => Name -> Labels -> RegistryT m (Gauge Double)
 registerGauge n l = RegistryT ask >>= liftIO . R.registerGauge n l
 
 
diff --git a/src/System/Metrics/Prometheus/Encode/Text.hs b/src/System/Metrics/Prometheus/Encode/Text.hs
index f18a5d3b7..f31271ab6 100644
--- a/src/System/Metrics/Prometheus/Encode/Text.hs
+++ b/src/System/Metrics/Prometheus/Encode/Text.hs
@@ -64,5 +64,5 @@ encodeCounter :: MetricId -> CounterSample -> Builder
 encodeCounter mid counter = encodeMetricId mid <> space <> encodeInt (unCounterSample counter)
 
 
-encodeGauge :: MetricId -> GaugeSample -> Builder
+encodeGauge :: MetricId -> GaugeSample Double -> Builder
 encodeGauge mid gauge = encodeMetricId mid <> space <> encodeDouble (unGaugeSample gauge)
diff --git a/src/System/Metrics/Prometheus/Metric.hs b/src/System/Metrics/Prometheus/Metric.hs
index e744524fe..1252f3519 100644
--- a/src/System/Metrics/Prometheus/Metric.hs
+++ b/src/System/Metrics/Prometheus/Metric.hs
@@ -14,21 +14,20 @@ import System.Metrics.Prometheus.Metric.Summary (SummarySample)
 
 data Metric
     = CounterMetric Counter
-    | GaugeMetric Gauge
-    | -- | Summary S.Summary
-      HistogramMetric Histogram
+    | GaugeMetric (Gauge Double) -- \| Summary S.Summary
+    | HistogramMetric Histogram
 
 
 data MetricSample
     = CounterMetricSample CounterSample
-    | GaugeMetricSample GaugeSample
+    | GaugeMetricSample (GaugeSample Double)
     | HistogramMetricSample HistogramSample
     | SummaryMetricSample SummarySample
 
 
 metricSample ::
     (CounterSample -> a) ->
-    (GaugeSample -> a) ->
+    (GaugeSample Double -> a) ->
     (HistogramSample -> a) ->
     (SummarySample -> a) ->
     MetricSample ->
diff --git a/src/System/Metrics/Prometheus/Metric/Gauge.hs b/src/System/Metrics/Prometheus/Metric/Gauge.hs
index 3c0852e2c..f547d6497 100644
--- a/src/System/Metrics/Prometheus/Metric/Gauge.hs
+++ b/src/System/Metrics/Prometheus/Metric/Gauge.hs
@@ -15,39 +15,39 @@ import Control.Applicative ((<$>))
 import Data.IORef (IORef, atomicModifyIORef', newIORef)
 
 
-newtype Gauge = Gauge {unGauge :: IORef Double}
-newtype GaugeSample = GaugeSample {unGaugeSample :: Double} deriving Show
+newtype Gauge a = Gauge {unGauge :: IORef a}
+newtype GaugeSample a = GaugeSample {unGaugeSample :: a} deriving (Show)
 
 
-new :: IO Gauge
+new :: (Num a) => IO (Gauge a)
 new = Gauge <$> newIORef 0
 
 
-modifyAndSample :: (Double -> Double) -> Gauge -> IO GaugeSample
+modifyAndSample :: (a -> a) -> Gauge a -> IO (GaugeSample a)
 modifyAndSample f = flip atomicModifyIORef' g . unGauge
   where
     g v = (f v, GaugeSample $ f v)
 
 
-add :: Double -> Gauge -> IO ()
+add :: (Num a) => a -> Gauge a -> IO ()
 add x g = modifyAndSample (+ x) g >> pure ()
 
 
-sub :: Double -> Gauge -> IO ()
+sub :: (Num a) => a -> Gauge a -> IO ()
 sub x g = modifyAndSample (subtract x) g >> pure ()
 
 
-inc :: Gauge -> IO ()
+inc :: (Num a) => Gauge a -> IO ()
 inc = add 1
 
 
-dec :: Gauge -> IO ()
+dec :: (Num a) => Gauge a -> IO ()
 dec = sub 1
 
 
-set :: Double -> Gauge -> IO ()
+set :: a -> Gauge a -> IO ()
 set x g = modifyAndSample (const x) g >> pure ()
 
 
-sample :: Gauge -> IO GaugeSample
+sample :: Gauge a -> IO (GaugeSample a)
 sample = modifyAndSample id
diff --git a/src/System/Metrics/Prometheus/Registry.hs b/src/System/Metrics/Prometheus/Registry.hs
index b39a5899b..6da2afdbb 100644
--- a/src/System/Metrics/Prometheus/Registry.hs
+++ b/src/System/Metrics/Prometheus/Registry.hs
@@ -59,7 +59,7 @@ registerCounter name labels registry = do
     collision k _ _ = throw (KeyError k)
 
 
-registerGauge :: Name -> Labels -> Registry -> IO (Gauge, Registry)
+registerGauge :: Name -> Labels -> Registry -> IO (Gauge Double, Registry)
 registerGauge name labels registry = do
     gauge <- Gauge.new
     return (gauge, Registry $ Map.insertWithKey collision mid (GaugeMetric gauge) (unRegistry registry))
diff --git a/src/System/Metrics/Prometheus/RegistryT.hs b/src/System/Metrics/Prometheus/RegistryT.hs
index 5f34cbe5c..61784e72b 100644
--- a/src/System/Metrics/Prometheus/RegistryT.hs
+++ b/src/System/Metrics/Prometheus/RegistryT.hs
@@ -53,7 +53,7 @@ registerCounter :: MonadIO m => Name -> Labels -> RegistryT m Counter
 registerCounter n l = withRegistry (liftIO . R.registerCounter n l)
 
 
-registerGauge :: MonadIO m => Name -> Labels -> RegistryT m Gauge
+registerGauge :: MonadIO m => Name -> Labels -> RegistryT m (Gauge Double)
 registerGauge n l = withRegistry (liftIO . R.registerGauge n l)
 
 

From b64b0e711a5b9bf225775cd84855bfa3187885e1 Mon Sep 17 00:00:00 2001
From: Brandon Chinn <brandonchinn178@gmail.com>
Date: Fri, 26 Jun 2026 13:03:08 -0700
Subject: [PATCH 3/4] Make Counter polymorphic

---
 src/Prometheus/V3/Metric/Counter.hs           | 49 ++++++++----
 src/System/Metrics/Prometheus/Encode/Text.hs  |  2 +-
 src/System/Metrics/Prometheus/Metric.hs       |  4 +-
 .../Metrics/Prometheus/Metric/Counter.hs      | 78 ++++++++++++++++---
 4 files changed, 107 insertions(+), 26 deletions(-)

diff --git a/src/Prometheus/V3/Metric/Counter.hs b/src/Prometheus/V3/Metric/Counter.hs
index ba322855b..cea43e707 100644
--- a/src/Prometheus/V3/Metric/Counter.hs
+++ b/src/Prometheus/V3/Metric/Counter.hs
@@ -1,18 +1,25 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE NoFieldSelectors #-}
 -- Remove after inlining V2.Counter
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module Prometheus.V3.Metric.Counter (
     V2.Counter,
+    V2.Counter',
     register,
     new,
 
     -- * Methods
     IsCounter,
+    IsNumCounter,
     inc,
     add,
     reset,
@@ -39,12 +46,16 @@ import UnliftIO.Exception (Exception, withException)
 
 
 -- | An alias for @'Registry.register' (new ...)@.
-register :: MetricName -> Description -> V2.Counter
+register ::
+    (Num a, Ord a, ToSampleValue a, V2.HasCounterBackend a) =>
+    MetricName -> Description -> (V2.Counter' a)
 register name description = Registry.register $ new name description
 {-# INLINE register #-}
 
 
-new :: MetricName -> Description -> Metric V2.Counter
+new ::
+    (Num a, V2.HasCounterBackend a) =>
+    MetricName -> Description -> Metric (V2.Counter' a)
 new name description =
     Metric
         { name
@@ -53,7 +64,7 @@ new name description =
         }
 
 
-instance IsMetric V2.Counter where
+instance (SampleValueNum a, Ord a, V2.HasCounterBackend a) => IsMetric (V2.Counter' a) where
     getMetricType _ = MetricTypeCounter
     getMetricSamples counter = do
         n <- sample counter
@@ -61,34 +72,46 @@ instance IsMetric V2.Counter where
 
 
 class IsCounter c where
-    getCounter :: c -> IO V2.Counter
-instance IsCounter V2.Counter where
+    type CounterElem c
+    getCounter :: c -> IO (V2.Counter' (CounterElem c))
+instance IsCounter (V2.Counter' a) where
+    type CounterElem (V2.Counter' a) = a
     getCounter = pure
-instance IsCounter (IO V2.Counter) where
+instance IsCounter (IO (V2.Counter' a)) where
+    type CounterElem (IO (V2.Counter' a)) = a
     getCounter = id
 
 
-inc :: (IsCounter c, MonadIO m) => c -> m ()
+type IsNumCounter c a =
+    ( IsCounter c
+    , a ~ CounterElem c
+    , V2.HasCounterBackend a
+    , Num a
+    , Ord a
+    )
+
+
+inc :: (IsNumCounter c a, MonadIO m) => c -> m ()
 inc c = liftIO $ V2.inc =<< getCounter c
 {-# INLINE inc #-}
 
 
-add :: (IsCounter c, MonadIO m) => c -> Int -> m ()
+add :: (IsNumCounter c a, MonadIO m) => c -> a -> m ()
 add c n = liftIO $ V2.add n =<< getCounter c
 {-# INLINE add #-}
 
 
-reset :: (IsCounter c, MonadIO m) => c -> m ()
+reset :: (IsNumCounter c a, MonadIO m) => c -> m ()
 reset c = liftIO $ V2.set 0 =<< getCounter c
 {-# INLINE reset #-}
 
 
-sample :: (IsCounter c, MonadIO m) => c -> m Int
+sample :: (IsNumCounter c a, MonadIO m) => c -> m a
 sample c = liftIO $ fmap V2.unCounterSample . V2.sample =<< getCounter c
 {-# INLINE sample #-}
 
 
-addAndSample :: (IsCounter c, MonadIO m) => c -> Int -> m Int
+addAndSample :: (IsNumCounter c a, MonadIO m) => c -> a -> m a
 addAndSample c n = liftIO $ fmap V2.unCounterSample . V2.addAndSample n =<< getCounter c
 {-# INLINE addAndSample #-}
 
@@ -98,7 +121,7 @@ addAndSample c n = liftIO $ fmap V2.unCounterSample . V2.addAndSample n =<< getC
 -- | Count the number of times a particular exception is thrown.
 countExceptions ::
     forall e c m a.
-    (IsCounter c, Exception e, MonadUnliftIO m) =>
+    (IsNumCounter c a, Exception e, MonadUnliftIO m) =>
     c -> m a -> m a
 countExceptions c = countExceptionsWhere c (\(_ :: e) -> True)
 {-# INLINE countExceptions #-}
@@ -108,7 +131,7 @@ countExceptions c = countExceptionsWhere c (\(_ :: e) -> True)
 -- include the exception in the count.
 countExceptionsWhere ::
     forall e c m a.
-    (IsCounter c, Exception e, MonadUnliftIO m) =>
+    (IsNumCounter c a, Exception e, MonadUnliftIO m) =>
     c -> (e -> Bool) -> m a -> m a
 countExceptionsWhere c f io = io `withException` \e -> when (f e) (inc c)
 {-# INLINE countExceptionsWhere #-}
diff --git a/src/System/Metrics/Prometheus/Encode/Text.hs b/src/System/Metrics/Prometheus/Encode/Text.hs
index f31271ab6..33b18690b 100644
--- a/src/System/Metrics/Prometheus/Encode/Text.hs
+++ b/src/System/Metrics/Prometheus/Encode/Text.hs
@@ -60,7 +60,7 @@ encodeMetric (mid, sample) =
     encodeSummary = undefined
 
 
-encodeCounter :: MetricId -> CounterSample -> Builder
+encodeCounter :: MetricId -> CounterSample Int -> Builder
 encodeCounter mid counter = encodeMetricId mid <> space <> encodeInt (unCounterSample counter)
 
 
diff --git a/src/System/Metrics/Prometheus/Metric.hs b/src/System/Metrics/Prometheus/Metric.hs
index 1252f3519..db9501c3c 100644
--- a/src/System/Metrics/Prometheus/Metric.hs
+++ b/src/System/Metrics/Prometheus/Metric.hs
@@ -19,14 +19,14 @@ data Metric
 
 
 data MetricSample
-    = CounterMetricSample CounterSample
+    = CounterMetricSample (CounterSample Int)
     | GaugeMetricSample (GaugeSample Double)
     | HistogramMetricSample HistogramSample
     | SummaryMetricSample SummarySample
 
 
 metricSample ::
-    (CounterSample -> a) ->
+    (CounterSample Int -> a) ->
     (GaugeSample Double -> a) ->
     (HistogramSample -> a) ->
     (SummarySample -> a) ->
diff --git a/src/System/Metrics/Prometheus/Metric/Counter.hs b/src/System/Metrics/Prometheus/Metric/Counter.hs
index 70d8148f4..d3082835b 100644
--- a/src/System/Metrics/Prometheus/Metric/Counter.hs
+++ b/src/System/Metrics/Prometheus/Metric/Counter.hs
@@ -1,5 +1,11 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+
 module System.Metrics.Prometheus.Metric.Counter (
     Counter,
+    Counter',
     CounterSample (..),
     new,
     add,
@@ -7,36 +13,88 @@ module System.Metrics.Prometheus.Metric.Counter (
     sample,
     addAndSample,
     set,
+
+    -- * Backends
+    HasCounterBackend,
+    CounterBackend,
+    IsCounterBackend,
 ) where
 
 import Control.Applicative ((<$>))
 import Control.Monad (when)
-import Data.Atomics.Counter (AtomicCounter, incrCounter, newCounter, writeCounter)
+import Data.Atomics.Counter (AtomicCounter)
+import qualified Data.Atomics.Counter as Atomic
+import Data.IORef (IORef, atomicModifyIORef', newIORef, writeIORef)
+
+
+-- | The default Counter tracking an Int.
+type Counter = Counter' Int
+
+
+-- | A Counter that works for any type, but with worse performance.
+newtype Counter' a = Counter {unCounter :: CounterBackend a}
+
+
+newtype CounterSample a = CounterSample {unCounterSample :: a} deriving (Show)
+
+
+type family CounterBackend a where
+    CounterBackend Int = AtomicCounter
+    CounterBackend a = IORef a
+
+
+class IsCounterBackend a where
+    type CounterElem a
+    newCounter :: CounterElem a -> IO a
+    incrCounter :: CounterElem a -> a -> IO (CounterElem a)
+    writeCounter :: a -> CounterElem a -> IO ()
+instance IsCounterBackend AtomicCounter where
+    type CounterElem AtomicCounter = Int
+    newCounter = Atomic.newCounter
+    incrCounter = Atomic.incrCounter
+    writeCounter = Atomic.writeCounter
+instance (Num a) => IsCounterBackend (IORef a) where
+    type CounterElem (IORef a) = a
+    newCounter = newIORef
+    incrCounter x ref = atomicModifyIORef' ref $ \a -> (a + x, a + x)
+    writeCounter = writeIORef
 
 
-newtype Counter = Counter {unCounter :: AtomicCounter}
-newtype CounterSample = CounterSample {unCounterSample :: Int} deriving Show
+type HasCounterBackend a =
+    ( IsCounterBackend (CounterBackend a)
+    , a ~ CounterElem (CounterBackend a)
+    )
 
 
-new :: IO Counter
+new ::
+    (Num a, HasCounterBackend a) =>
+    IO (Counter' a)
 new = Counter <$> newCounter 0
 
 
-addAndSample :: Int -> Counter -> IO CounterSample
+addAndSample ::
+    (Num a, Ord a, HasCounterBackend a) =>
+    a -> Counter' a -> IO (CounterSample a)
 addAndSample by
     | by >= 0 = fmap CounterSample . incrCounter by . unCounter
     | otherwise = error "must be >= 0"
 
 
-add :: Int -> Counter -> IO ()
+add ::
+    (Num a, Ord a, HasCounterBackend a) =>
+    a -> Counter' a -> IO ()
 add by c = addAndSample by c >> pure ()
 
 
-inc :: Counter -> IO ()
+inc ::
+    (Num a, Ord a, HasCounterBackend a) =>
+    Counter' a -> IO ()
 inc = add 1
 
 
-sample :: Counter -> IO CounterSample
+sample ::
+    (Num a, Ord a, HasCounterBackend a) =>
+    Counter' a -> IO (CounterSample a)
 sample = addAndSample 0
 
 
@@ -46,7 +104,7 @@ sample = addAndSample 0
 --
 -- WARNING: For multiple writers, the most recent one wins, which may not
 -- preserve the increasing property. If you have stronger requirements than this,
--- please check with the maintainers. 
+-- please check with the maintainers.
 -- See <https://github.com/bitnomial/prometheus/pull/44> for discussion.
-set :: Int -> Counter -> IO ()
+set :: (HasCounterBackend a) => a -> Counter' a -> IO ()
 set i (Counter c) = writeCounter c i

From 21c1f98c4ea5ec9f5120158af4b26f67ece80b02 Mon Sep 17 00:00:00 2001
From: Brandon Chinn <brandonchinn178@gmail.com>
Date: Mon, 29 Jun 2026 15:19:19 -0700
Subject: [PATCH 4/4] Fix histogram updating all buckets

---
 src/System/Metrics/Prometheus/Metric/Histogram.hs | 15 ++++++++++-----
 1 file changed, 10 insertions(+), 5 deletions(-)

diff --git a/src/System/Metrics/Prometheus/Metric/Histogram.hs b/src/System/Metrics/Prometheus/Metric/Histogram.hs
index d1db1649f..07a8f3eb0 100644
--- a/src/System/Metrics/Prometheus/Metric/Histogram.hs
+++ b/src/System/Metrics/Prometheus/Metric/Histogram.hs
@@ -14,13 +14,14 @@ module System.Metrics.Prometheus.Metric.Histogram (
 
 import Control.Applicative ((<$>))
 import Control.Monad (void)
-import Data.Bool (bool)
+import qualified Data.Foldable1 as Foldable1
 import Data.IORef (
     IORef,
     atomicModifyIORef',
     newIORef,
     readIORef,
  )
+import qualified Data.List.NonEmpty as NonEmpty
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 
@@ -37,7 +38,7 @@ data HistogramSample = HistogramSample
     , histSum :: !Double
     , histCount :: !Int
     }
-    deriving Show
+    deriving (Show)
 
 
 new :: [UpperBound] -> IO Histogram
@@ -65,9 +66,13 @@ observe x = void . observeAndSample x
 
 
 updateBuckets :: Double -> Buckets -> Buckets
-updateBuckets x = Map.mapWithKey updateBucket
-  where
-    updateBucket key val = bool val (val + 1) (x <= key)
+updateBuckets x buckets =
+    let matchingBuckets = filter (x <=) $ Map.keys buckets
+        bucketKey =
+            case NonEmpty.nonEmpty matchingBuckets of
+                Just bs -> Foldable1.minimum bs
+                Nothing -> error "Unexpectedly found zero matching buckets; at least the +Inf bucket should've been found."
+     in Map.adjust (+ 1) bucketKey buckets
 
 
 sample :: Histogram -> IO HistogramSample