datastar-hs 1.0.2.1 → 1.1.0.0

raw patch · 22 files changed

+219/−1917 lines, 22 filesdep −brotlidep −containersdep −ghc-heapdep ~aesondep ~basedep ~bytestringPVP ok

version bump matches the API change (PVP)

Dependencies removed: brotli, containers, ghc-heap, http-media, servant-server, stm, streaming-commons, time, uuid, zlib, zstd

Dependency ranges changed: aeson, base, bytestring, http-types, text, wai, warp

API changes (from Hackage documentation)

Files

• CHANGELOG.md +15/−0
• README.md +17/−7
• bench/Main.hs +0/−122
• datastar-hs.cabal +9/−149
• examples/activity-feed.hs +0/−153
• examples/heap-view.hs +0/−562
• examples/hello-world-channel.hs +0/−97
• examples/hello-world-servant.hs +0/−76
• examples/hello-world-warp.hs +0/−61
• src/Hypermedia/Datastar.hs +17/−11
• src/Hypermedia/Datastar/Attributes.hs +80/−61
• src/Hypermedia/Datastar/Compression/Brotli.hs +0/−68
• src/Hypermedia/Datastar/Compression/Zlib.hs +0/−68
• src/Hypermedia/Datastar/Compression/Zstd.hs +0/−131
• src/Hypermedia/Datastar/WAI.hs +32/−31
• test/Hypermedia/Datastar/Compression/BrotliSpec.hs +0/−107
• test/Hypermedia/Datastar/Compression/ZlibSpec.hs +0/−109
• test/Hypermedia/Datastar/Compression/ZstdSpec.hs +0/−83
• test/Hypermedia/Datastar/NegotiationSpec.hs +41/−0
• test/Hypermedia/Datastar/PatchElementsSpec.hs +6/−6
• test/Hypermedia/Datastar/SSESpec.hs +0/−3
• test/Main.hs +2/−12

@@ -1,5 +1,20 @@ # Changelog +## 1.1.0.0++* **Breaking**: the compressor modules moved to add-on packages so that the+  core `datastar-hs` has no system-library dependencies.+  GHC builds it.+  * `Hypermedia.Datastar.Compression.Zlib` (`gzip`, `deflate`) →+    [`datastar-hs-zlib`](https://hackage.haskell.org/package/datastar-hs-zlib)+  * `Hypermedia.Datastar.Compression.Brotli` (`brotli`) →+    [`datastar-hs-brotli`](https://hackage.haskell.org/package/datastar-hs-brotli)+  * `Hypermedia.Datastar.Compression.Zstd` (`zstd`) → `datastar-hs-zstd`+    (not yet on Hackage; the `zstd` cabal flag is gone — build the add-on+    from this repository instead)+* `Compressor`, `CompressionStrategy`, `sseResponseWith`, and+  `sseResponseWithStrategy` are unchanged and stay in the core.+ ## 1.0.2.1  * Fix the `zstd` ratio in the `compression-bench` output (it reported brotli's

@@ -21,8 +21,11 @@  Key design decisions: -- **Minimal dependencies** -- the library depends only on `aeson`, `bytestring`,-`http-types`, `text`, `wai`, and some compression libraries.+- **No system libraries** -- the core library depends only on `aeson`,+`bytestring`, `http-types`, `text`, and `wai`. A machine with just GHC (e.g. a+fresh [ghcup](https://www.haskell.org/ghcup/) install) builds it; no+`apt-get`/`brew` needed. Compressors that link against C libraries live in+add-on packages (see [Compression](#compression)). - **WAI streaming** -- SSE responses use WAI's native `responseStream`, giving you a `ServerSentEventGenerator` callback with `sendPatchElements`, `sendPatchSignals`, and `sendExecuteScript`.@@ -73,16 +76,23 @@ ## Compression  SSE streams can be compressed by negotiating `Content-Encoding` against the-request's `Accept-Encoding`. Pass one or more compressors to `sseResponseWith`+request's `Accept-Encoding`. The compressors live in add-on packages so that+the core `datastar-hs` has no system-library dependencies:++| Package | Encodings | System library |+|---|---|---|+| `datastar-hs-zlib` | `gzip`, `deflate` | zlib -- preinstalled on macOS; `zlib1g-dev` on Debian/Ubuntu, or build with the constraint `zlib +bundled-c-zlib` for no system library at all |+| `datastar-hs-brotli` | `br` | `brew install brotli` / `apt-get install libbrotli-dev pkg-config` |+| `datastar-hs-zstd` | `zstd` | `brew install zstd` / `apt-get install libzstd-dev` -- not yet on Hackage, see below |++Add one to `build-depends` and pass its compressors to `sseResponseWith` (or `sseResponseWithStrategy`) in preference order:  ```haskell import Hypermedia.Datastar-import Hypermedia.Datastar.Compression.Brotli (brotli)-import Hypermedia.Datastar.Compression.Zlib (deflate, gzip)-import Hypermedia.Datastar.Compression.Zstd (zstd)+import Hypermedia.Datastar.Compression.Zlib (deflate, gzip)  -- datastar-hs-zlib -respond $ sseResponseWith nullLogger [brotli, gzip, deflate] req $ \gen ->+respond $ sseResponseWith nullLogger [gzip, deflate] req $ \gen ->   sendPatchElements gen (patchElements "<div id=\"message\">Hello!</div>") ``` 

@@ -1,122 +0,0 @@-{-# LANGUAGE CPP #-}--{- |-A size benchmark for Datastar SSE compression.--It sends one @PatchElements@ event per "tick" over a single SSE connection and-measures the total bytes that go on the wire, uncompressed vs. gzip vs. brotli —-using the real SDK compressors and streaming path.--Run: @cabal run bench -- [numEvents] [tableRows]@ (defaults: 400 events, 2000 rows).--}-module Main (main) where--import Control.Concurrent.MVar-import Control.Monad-import Data.ByteString.Builder qualified as BSB-import Data.ByteString.Lazy qualified as BL-import Data.Text (Text)-import Data.Text qualified as T-import System.Environment (getArgs)-import Text.Printf (printf)--import Network.Wai (defaultRequest)-import Network.Wai.Internal (Response (..))--import Hypermedia.Datastar-import Hypermedia.Datastar.Compression.Brotli (brotli)-import Hypermedia.Datastar.Compression.Zlib (gzip)-#ifdef ZSTD-import Hypermedia.Datastar.Compression.Zstd (zstd)-#endif--wireBytes :: Response -> IO Int-wireBytes (ResponseStream _ _ body) = do-  nrBytes <- newMVar 0--  let chunkLen = fromIntegral . BL.length . BSB.toLazyByteString--  body-    (\chunk -> modifyMVar_ nrBytes $ \nr -> return $ nr + chunkLen chunk)-    (pure ())--  readMVar nrBytes--wireBytes _ = error "expected a streaming response"--sendAll :: [Text] -> ServerSentEventGenerator -> IO ()-sendAll frags gen = forM_ frags (sendPatchElements gen . patchElements) --rawBytes :: [Text] -> IO Int-rawBytes frags = wireBytes (sseResponse nullLogger (sendAll frags))--compressedBytes :: Compressor -> [Text] -> IO Int-compressedBytes c frags =-  wireBytes (sseResponseWithStrategy Forced nullLogger [c] defaultRequest (sendAll frags))--bench :: String -> [Text] -> IO ()-bench name frags = do-  let n = length frags-      perEvent = if n == 0 then 0 else T.length (head frags)-  rawN <- rawBytes frags-  gzN <- compressedBytes gzip frags-  brN <- compressedBytes brotli frags--  printf "\n=== %s ===\n" name-  printf "  %d events, ~%s uncompressed per fragment\n\n" n (human perEvent)-  printf "  none   : %12s\n" (human rawN)-  printf "  gzip   : %12s  (%7.1fx vs none)\n" (human gzN) (ratio rawN gzN)-  printf "  brotli : %12s  (%7.1fx vs none)\n" (human brN) (ratio rawN brN)-#ifdef ZSTD-  zstdN <- compressedBytes zstd frags-  printf "  zstd   : %12s  (%7.1fx vs none)\n" (human zstdN) (ratio rawN zstdN)-#endif--ratio :: Int -> Int -> Double-ratio a b = if b == 0 then 0 else fromIntegral a / fromIntegral b--human :: Int -> String-human n-  | n >= 1024 * 1024 = printf "%.1f MB" (fromIntegral n / (1024 * 1024) :: Double)-  | n >= 1024 = printf "%.1f KB" (fromIntegral n / 1024 :: Double)-  | otherwise = printf "%d B" n--tshow :: Int -> Text-tshow = T.pack . show---- A self-similar table row (lots of intra-fragment repetition).-gridRow :: Int -> Text-gridRow i =-  "<tr><td>" <> tshow i <> "</td><td>item-" <> tshow i <> "</td><td>active</td><td>0.00</td></tr>"---- A large grid (>32 KB for a couple thousand rows), optionally stamped with a--- per-tick caption so only a tiny part changes between events.-grid :: Int -> Maybe Int -> Text-grid rows mtick =-  "<table id=\"grid\">"-    <> maybe "" (\t -> "<caption>updated " <> tshow t <> "</caption>") mtick-    <> T.concat (map gridRow [1 .. rows])-    <> "</table>"--clock :: Int -> Text-clock tick = "<div id=\"clock\">" <> tshow tick <> "</div>"--main :: IO ()-main = do-  args <- getArgs-  let n = case args of (a : _) -> read a; _ -> 400-      rows = case args of (_ : b : _) -> read b; _ -> 2000--  putStrLn "Datastar SSE compression benchmark"--  bench-    "Identical large grid every tick"-    (replicate n (grid rows Nothing))--  bench-    "Fat update: large grid, only the caption changes each tick"-    (map (grid rows . Just) [1 .. n])--  bench-    "Small update: tiny clock div each tick"-    (map clock [1 .. n])

@@ -1,6 +1,6 @@ cabal-version:   3.0 name:            datastar-hs-version:         1.0.2.1+version:         1.1.0.0 synopsis:        Haskell bindings for Datastar description:   Server-side SDK for building real-time hypermedia applications with@@ -8,6 +8,13 @@   signal updates, and scripts to the browser over server-sent events   (SSE). Built on WAI so it works with Warp, Scotty, Servant, Yesod,   and any other WAI-compatible framework.+  .+  This core package has no system-library dependencies. @Content-Encoding@+  compressors for SSE streams live in the add-on packages+  <https://hackage.haskell.org/package/datastar-hs-zlib datastar-hs-zlib>+  (gzip, deflate),+  <https://hackage.haskell.org/package/datastar-hs-brotli datastar-hs-brotli>+  (br), and datastar-hs-zstd (zstd, not yet on Hackage). homepage:        https://github.com/starfederation/datastar-haskell bug-reports:     https://github.com/starfederation/datastar-haskell/issues license:         MIT@@ -22,15 +29,6 @@   type:     git   location: https://github.com/starfederation/datastar-haskell.git --- zstd compression depends on an unreleased hs-zstd (streaming flushStream FFI),--- so it is off by default to keep the Hackage build clean. Enable with -fzstd--- together with the source-repository-package pin in cabal.project.--- https://github.com/starfederation/datastar-haskell/issues/3-flag zstd-  description: zstd Content-Encoding compressor (needs unreleased hs-zstd)-  default:     False-  manual:      True- common warnings   ghc-options:     -Wall@@ -45,8 +43,6 @@   exposed-modules:     Hypermedia.Datastar     Hypermedia.Datastar.Attributes-    Hypermedia.Datastar.Compression.Brotli-    Hypermedia.Datastar.Compression.Zlib     Hypermedia.Datastar.ExecuteScript     Hypermedia.Datastar.Logger     Hypermedia.Datastar.PatchElements@@ -63,33 +59,10 @@     , base       >= 4.14  && < 5     , aeson      >= 2.0   && < 3     , bytestring >= 0.10.12 && < 1-    , brotli     >= 0.0.0.3 && < 1-    , streaming-commons >= 0.2.3.1 && < 1     , http-types >= 0.12  && < 1     , text       >= 1.2   && < 3     , wai        >= 3.2   && < 4-  if flag(zstd)-    exposed-modules: Hypermedia.Datastar.Compression.Zstd-    build-depends:   zstd >= 0.1.3 && < 1 -executable compression-bench-  import: warnings-  main-is:          Main.hs-  hs-source-dirs:   bench-  default-language: Haskell2010-  default-extensions:-    ImportQualifiedPost-    OverloadedStrings-  build-depends:-    , base-    , bytestring-    , datastar-hs-    , text-    , wai-  if flag(zstd)-    cpp-options: -DZSTD-  ghc-options: -O2- executable e2e-server   import: warnings   hs-source-dirs:   e2e-server@@ -121,132 +94,19 @@   hs-source-dirs:   test   main-is:          Main.hs   other-modules:-    Hypermedia.Datastar.Compression.BrotliSpec-    Hypermedia.Datastar.Compression.ZlibSpec     Hypermedia.Datastar.ExecuteScriptSpec+    Hypermedia.Datastar.NegotiationSpec     Hypermedia.Datastar.PatchElementsSpec     Hypermedia.Datastar.PatchSignalsSpec     Hypermedia.Datastar.SSESpec   build-depends:     , base-    , brotli     , bytestring     , datastar-hs     , hspec     , text     , wai-    , zlib-  if flag(zstd)-    other-modules: Hypermedia.Datastar.Compression.ZstdSpec-    build-depends: zstd-    cpp-options:   -DZSTD   default-language: Haskell2010   default-extensions:     ImportQualifiedPost     OverloadedStrings--executable hello-world-warp-  import: warnings-  main-is:          hello-world-warp.hs-  hs-source-dirs:   examples-  default-language:  Haskell2010-  default-extensions:-    ImportQualifiedPost-    OverloadedStrings-  build-depends:-    , base >= 4.7-    , aeson-    , bytestring-    , http-types-    , text-    , wai-    , warp              >= 3.2   && < 4-    , datastar-hs-  ghc-options: -threaded--executable hello-world-servant-  import: warnings-  main-is:          hello-world-servant.hs-  hs-source-dirs:   examples-  default-language:  Haskell2010-  default-extensions:-    DataKinds-    ImportQualifiedPost-    MultiParamTypeClasses-    OverloadedStrings-    TypeOperators-  build-depends:-    , base >= 4.7-    , aeson-    , bytestring-    , http-media        >= 0.8   && < 1-    , http-types-    , servant-server    >= 0.19  && < 1-    , text-    , wai-    , warp              >= 3.2   && < 4-    , datastar-hs-  ghc-options: -threaded--executable hello-world-channel-  import: warnings-  main-is:          hello-world-channel.hs-  hs-source-dirs:   examples-  default-language:  Haskell2010-  default-extensions:-    ImportQualifiedPost-    OverloadedStrings-  build-depends:-    , base >= 4.7-    , aeson-    , bytestring-    , http-types-    , stm               >= 2.4   && < 3-    , text-    , wai-    , warp              >= 3.2   && < 4-    , datastar-hs-  ghc-options: -threaded--executable activity-feed-  import: warnings-  main-is:          activity-feed.hs-  hs-source-dirs:   examples-  default-language:  Haskell2010-  default-extensions:-    ImportQualifiedPost-    OverloadedStrings-  build-depends:-    , base >= 4.7-    , aeson-    , bytestring-    , text-    , time              >= 1.9   && < 2-    , http-types-    , wai-    , warp              >= 3.2   && < 4-    , datastar-hs-  ghc-options: -threaded--executable heap-view-  import: warnings-  main-is:          heap-view.hs-  hs-source-dirs:   examples-  default-language:  Haskell2010-  default-extensions:-    ImportQualifiedPost-    OverloadedStrings-    ScopedTypeVariables-  build-depends:-    , base >= 4.7-    , bytestring-    , containers        >= 0.6   && < 1-    , ghc-heap          >= 9.0   && < 10-    , http-types-    , stm               >= 2.4   && < 3-    , text-    , uuid              >= 1.3   && < 2-    , wai-    , warp              >= 3.2   && < 4-    , datastar-hs-  ghc-options: -threaded -O0

@@ -1,153 +0,0 @@-module Main (main) where--import Control.Concurrent (threadDelay)-import Data.Aeson (FromJSON (..), withObject, (.:))-import Data.ByteString qualified as BS-import Data.ByteString.Char8 qualified as BS8-import Data.ByteString.Lazy qualified as LBS-import Data.Text (Text)-import Data.Text qualified as T-import Data.Time.Clock (getCurrentTime)-import Data.Time.Format (defaultTimeLocale, formatTime)-import Hypermedia.Datastar-import Hypermedia.Datastar.Compression.Brotli (brotli)-import Hypermedia.Datastar.Compression.Zlib (deflate, gzip)-import Network.HTTP.Types (status200, status404)-import Network.Wai (Application, pathInfo, requestMethod, responseLBS)-import Network.Wai qualified as Wai-import Network.Wai.Handler.Warp qualified as Warp-import System.Environment (getArgs)--data Signals = Signals-  { _sInterval :: Int-  , _sEvents :: Int-  , _sGenerating :: Bool-  , _sTotal :: Int-  , _sDone :: Int-  , _sWarn :: Int-  , _sFail :: Int-  , _sInfo :: Int-  }--instance FromJSON Signals where-  parseJSON = withObject "Signals" $ \o ->-    Signals-      <$> o .: "interval"-      <*> o .: "events"-      <*> o .: "generating"-      <*> o .: "total"-      <*> o .: "done"-      <*> o .: "warn"-      <*> o .: "fail"-      <*> o .: "info"--data Status = Done | Warn | Fail | Info--statusFromText :: Text -> Maybe Status-statusFromText "done" = Just Done-statusFromText "warn" = Just Warn-statusFromText "fail" = Just Fail-statusFromText "info" = Just Info-statusFromText _ = Nothing--statusColor :: Status -> Text-statusColor Done = "green"-statusColor Warn = "yellow"-statusColor Fail = "red"-statusColor Info = "blue"--statusIndicator :: Status -> Text-statusIndicator Done = "Done"-statusIndicator Warn = "Warn"-statusIndicator Fail = "Fail"-statusIndicator Info = "Info"--eventEntry :: Status -> Int -> Text -> IO Text-eventEntry status index source = do-  now <- getCurrentTime-  let timestamp = T.pack $ formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S%3Q" now-      color = statusColor status-      indicator = statusIndicator status-  pure $-    "<div id='event-"-      <> T.pack (show index)-      <> "' class='text-"-      <> color-      <> "-500'>"-      <> timestamp-      <> " [ "-      <> indicator-      <> " ] "-      <> source-      <> " event "-      <> T.pack (show index)-      <> "</div>"--main :: IO ()-main = do-  args <- getArgs-  let port = case args of-        (p : _) -> read p-        _ -> 3000-  htmlContent <- BS.readFile "examples/activity-feed.html"-  putStrLn $ "Listening on http://localhost:" <> show port-  Warp.run port (app htmlContent)--app :: BS.ByteString -> Application-app htmlContent req respond =-  case (requestMethod req, pathInfo req) of-    ("GET", []) ->-      respond $ responseLBS status200 [("Content-Type", "text/html")] (LBS.fromStrict htmlContent)-    ("POST", ["event", "generate"]) ->-      handleGenerate req respond-    ("POST", ["event", statusText])-      | Just status <- statusFromText statusText ->-          handleEvent status req respond-    _ ->-      respond $ responseLBS status404 [] "Not found"--compressors :: [Compressor]-compressors = [brotli, gzip, deflate]--handleGenerate :: Wai.Request -> (Wai.Response -> IO b) -> IO b-handleGenerate req respond = do-  signalsResult <- readSignals req :: IO (Either String Signals)-  case signalsResult of-    Left err -> respond $ responseLBS status404 [] (LBS.fromStrict $ BS8.pack $ "Bad signals: " <> err)-    Right signals -> respond $ sseResponseWith nullLogger compressors req $ \gen -> do-      sendPatchSignals gen (patchSignals "{\"generating\": true}")--      let loop 0 _ _ = pure ()-          loop n total' done' = do-            let newTotal = total' + 1-                newDone = done' + 1-            html <- eventEntry Done newTotal "Auto"-            sendPatchElements gen $-              (patchElements html){peSelector = Just "#feed", peMode = After}-            sendPatchSignals gen $-              patchSignals $-                "{\"total\": " <> T.pack (show newTotal) <> ", \"done\": " <> T.pack (show newDone) <> "}"-            threadDelay (_sInterval signals * 1000)-            loop (n - 1) newTotal newDone--      loop (_sEvents signals) (_sTotal signals) (_sDone signals)--      sendPatchSignals gen (patchSignals "{\"generating\": false}")--handleEvent :: Status -> Wai.Request -> (Wai.Response -> IO b) -> IO b-handleEvent status req respond = do-  signalsResult <- readSignals req :: IO (Either String Signals)-  case signalsResult of-    Left err -> respond $ responseLBS status404 [] (LBS.fromStrict $ BS8.pack $ "Bad signals: " <> err)-    Right signals -> respond $ sseResponseWith nullLogger compressors req $ \gen -> do-      let newTotal = _sTotal signals + 1-          counterSignals = case status of-            Done -> "{\"total\": " <> T.pack (show newTotal) <> ", \"done\": " <> T.pack (show (_sDone signals + 1)) <> "}"-            Warn -> "{\"total\": " <> T.pack (show newTotal) <> ", \"warn\": " <> T.pack (show (_sWarn signals + 1)) <> "}"-            Fail -> "{\"total\": " <> T.pack (show newTotal) <> ", \"fail\": " <> T.pack (show (_sFail signals + 1)) <> "}"-            Info -> "{\"total\": " <> T.pack (show newTotal) <> ", \"info\": " <> T.pack (show (_sInfo signals + 1)) <> "}"-      sendPatchSignals gen (patchSignals counterSignals)--      html <- eventEntry status newTotal "Manual"-      sendPatchElements gen $-        (patchElements html){peSelector = Just "#feed", peMode = After}

@@ -1,562 +0,0 @@-{- HLINT ignore "Use head" -}-{- HLINT ignore "Use void" -}-module Main (main) where--import Control.Concurrent (forkIO, threadDelay)-import Control.Concurrent.STM (TVar, atomically, modifyTVar', newTVarIO, readTVarIO, writeTVar)-import Control.Exception (SomeException, catch, evaluate)-import Control.Monad (replicateM_)-import Data.ByteString qualified as BS-import Data.ByteString.Lazy qualified as LBS-import Data.Map.Strict (Map)-import Data.Map.Strict qualified as Map-import Data.Set qualified as Set-import Data.Text (Text)-import Data.Text qualified as T-import Data.UUID (UUID)-import Data.UUID qualified as UUID-import Data.UUID.V4 qualified as UUID-import GHC.Exts.Heap (Box (..), GenClosure (..), asBox, getClosureData)-import Hypermedia.Datastar-import Hypermedia.Datastar.Compression.Brotli (brotli)-import Hypermedia.Datastar.Compression.Zlib (deflate, gzip)-import Network.HTTP.Types (queryToQueryText, status200, status400, status404)-import Network.Wai (Application, Request, Response, pathInfo, queryString, requestMethod, responseLBS)-import Network.Wai.Handler.Warp qualified as Warp-import System.Environment (getArgs)-import System.Exit (exitFailure)-import System.IO (hPutStrLn, stderr)-import System.Mem (performGC)---- Per-user session state-data Session = Session-  { sessId :: UUID-  , sessExpression :: TVar Box-  , sessExprDesc :: TVar Text-  , sessBoxMap :: TVar (Map Text Box)-  }---- Shared application state-data AppState = AppState-  { appSessions :: TVar (Map UUID Session)-  , appMode :: Mode-  , appHasRun :: Bool-  }---- Mode configuration-data Mode = Mode-  { modeName :: Text-  , modeDesc :: Text-  , modeSetup :: Session -> IO ()-  , modeRun :: Maybe (Session -> IO ())-  }---- Expression constructors - NOINLINE + () argument ensures each call--- allocates fresh thunks at -O0 (which heap-view uses). The () forces--- function entry, and at -O0 GHC doesn't float subexpressions out as CAFs.--- An IO [Int] with `pure $` does NOT work: the thunk is part of the CAF--- and shared across all calls, so forced thunks stay forced after reset.--mkSimpleExpr :: () -> [Int]-mkSimpleExpr () = [1, 2, 3, 4, 5] ++ map (* 10) [6, 7, 8]-{-# NOINLINE mkSimpleExpr #-}--mkMapExpr :: () -> [Int]-mkMapExpr () = map (+ 1) [10, 20, 30, 40, 50]-{-# NOINLINE mkMapExpr #-}--mkFibsExpr :: () -> [Int]-mkFibsExpr () = take 15 fibs- where-  fibs :: [Int]-  fibs = 0 : 1 : zipWith (+) fibs (tail fibs)-{-# NOINLINE mkFibsExpr #-}---- Available modes--simpleList :: Mode-simpleList =-  Mode-    { modeName = "simple-list"-    , modeDesc = "[1,2,3,4,5] ++ map (*10) [6,7,8]"-    , modeSetup = \sess -> do-        let expr = mkSimpleExpr ()-        _ <- evaluate expr-        atomically $ do-          writeTVar (sessExpression sess) (asBox expr)-          writeTVar (sessExprDesc sess) "[1,2,3,4,5] ++ map (*10) [6,7,8]"-    , modeRun = Nothing-    }--liveMap :: Mode-liveMap =-  Mode-    { modeName = "live-map"-    , modeDesc = "map (+ 1) [10, 20, 30, 40, 50]"-    , modeSetup = \sess -> do-        let expr = mkMapExpr ()-        atomically $ do-          writeTVar (sessExpression sess) (asBox expr)-          writeTVar (sessExprDesc sess) "map (+ 1) [10, 20, 30, 40, 50]"-    , modeRun = Just $ \sess -> do-        let expr = mkMapExpr ()-        atomically $ do-          writeTVar (sessExpression sess) (asBox expr)-          writeTVar (sessExprDesc sess) "map (+ 1) [10, 20, 30, 40, 50]"-        _ <- forkIO $ forceListSlowly expr-        pure ()-    }--liveFibs :: Mode-liveFibs =-  Mode-    { modeName = "live-fibs"-    , modeDesc = "take 15 fibs"-    , modeSetup = \sess -> do-        let expr = mkFibsExpr ()-        atomically $ do-          writeTVar (sessExpression sess) (asBox expr)-          writeTVar (sessExprDesc sess) "take 15 fibs"-    , modeRun = Just $ \sess -> do-        let expr = mkFibsExpr ()-        atomically $ do-          writeTVar (sessExpression sess) (asBox expr)-          writeTVar (sessExprDesc sess) "take 15 fibs"-        _ <- forkIO $ forceListSlowly expr-        pure ()-    }--allModes :: [(String, Mode)]-allModes =-  [ ("simple-list", simpleList)-  , ("live-map", liveMap)-  , ("live-fibs", liveFibs)-  ]---- Session management--newSession :: AppState -> IO Session-newSession appState = do-  sid <- UUID.nextRandom-  sess <--    Session sid-      <$> newTVarIO (asBox ())-      <*> newTVarIO ""-      <*> newTVarIO Map.empty-  atomically $ modifyTVar' (appSessions appState) (Map.insert sid sess)-  pure sess--lookupSession :: AppState -> UUID -> IO (Maybe Session)-lookupSession appState sid =-  Map.lookup sid <$> readTVarIO (appSessions appState)--getSessionId :: Request -> Maybe UUID-getSessionId req =-  case lookup "s" (queryToQueryText (queryString req)) of-    Just (Just s) -> UUID.fromText s-    _ -> Nothing--withSession :: AppState -> Request -> (Response -> IO b) -> (Session -> IO b) -> IO b-withSession appState req respond action =-  case getSessionId req of-    Just sid -> do-      msess <- lookupSession appState sid-      case msess of-        Just sess -> action sess-        Nothing -> respond $ responseLBS status404 [] "Session not found"-    Nothing -> respond $ responseLBS status400 [] "Missing session"---- Force a list spine + elements one by one with delay-forceListSlowly :: [Int] -> IO ()-forceListSlowly [] = pure ()-forceListSlowly (x : xs) = do-  _ <- evaluate x-  threadDelay 1000000-  forceListSlowly xs---- Heap node representation-data HeapNode = HeapNode-  { nodeType :: Text-  , nodeValue :: Maybe Text-  , nodePointers :: [Text]-  }---- Get closure data from a Box (unwrap the Box to see what's inside)-getBoxClosure :: Box -> IO (GenClosure Box)-getBoxClosure (Box a) = getClosureData a--boxAddr :: Box -> Text-boxAddr = T.pack . show---- Walk the heap from a root Box via DFS-walkHeap :: Session -> Box -> Int -> IO (Text, Map Text HeapNode)-walkHeap sess startBox maxDepth = do-  nodesRef <- newTVarIO Map.empty-  boxMapRef <- newTVarIO Map.empty-  visitedRef <- newTVarIO Set.empty--  walkNode nodesRef boxMapRef visitedRef startBox 0--  nodes <- readTVarIO nodesRef-  boxMap <- readTVarIO boxMapRef-  atomically $ writeTVar (sessBoxMap sess) boxMap--  pure (boxAddr startBox, nodes)- where-  walkNode nodesRef boxMapRef visitedRef box depth-    | depth > maxDepth = pure ()-    | otherwise = do-        let addr = boxAddr box-        visited <- readTVarIO visitedRef-        if Set.member addr visited-          then pure ()-          else do-            atomically $ do-              modifyTVar' visitedRef (Set.insert addr)-              modifyTVar' boxMapRef (Map.insert addr box)--            closure <- getBoxClosure box--            -- Follow indirections transparently-            closure' <- case closure of-              IndClosure{indirectee = ptr} -> getBoxClosure ptr-              BlackholeClosure{indirectee = ptr} -> getBoxClosure ptr-              _ -> pure closure--            case closure' of-              ConstrClosure{ptrArgs = ptrs, dataArgs = dargs, name = n, modl = m} -> do-                let fullName = T.pack m <> "." <> T.pack n-                    ptrAddrs = map boxAddr ptrs-                if length ptrs >= 2 && T.pack n == ":"-                  then do-                    -- Cons cell: first ptr is head, second is tail-                    let headBox = ptrs !! 0-                        tailBox = ptrs !! 1-                    headVal <- getHeadValue headBox-                    let node = HeapNode "cons" headVal [boxAddr tailBox]-                    atomically $ modifyTVar' nodesRef (Map.insert addr node)-                    walkNode nodesRef boxMapRef visitedRef headBox (depth + 1)-                    walkNode nodesRef boxMapRef visitedRef tailBox (depth + 1)-                  else-                    if null ptrs && (T.pack n == "[]")-                      then do-                        let node = HeapNode "nil" Nothing []-                        atomically $ modifyTVar' nodesRef (Map.insert addr node)-                      else do-                        let val = case dargs of-                              [] -> Nothing-                              [v] -> Just (T.pack (show v))-                              vs -> Just (T.pack (show vs))-                        let node = HeapNode ("constr:" <> fullName) val ptrAddrs-                        atomically $ modifyTVar' nodesRef (Map.insert addr node)-                        mapM_ (\p -> walkNode nodesRef boxMapRef visitedRef p (depth + 1)) ptrs-              ThunkClosure{ptrArgs = ptrs} -> do-                let ptrAddrs = map boxAddr ptrs-                    node = HeapNode "thunk" Nothing ptrAddrs-                atomically $ modifyTVar' nodesRef (Map.insert addr node)-                mapM_ (\p -> walkNode nodesRef boxMapRef visitedRef p (depth + 1)) ptrs-              FunClosure{ptrArgs = ptrs} -> do-                let ptrAddrs = map boxAddr ptrs-                    node = HeapNode "function" Nothing ptrAddrs-                atomically $ modifyTVar' nodesRef (Map.insert addr node)-                mapM_ (\p -> walkNode nodesRef boxMapRef visitedRef p (depth + 1)) ptrs-              PAPClosure{payload = ptrs} -> do-                let ptrAddrs = map boxAddr ptrs-                    node = HeapNode "pap" Nothing ptrAddrs-                atomically $ modifyTVar' nodesRef (Map.insert addr node)-                mapM_ (\p -> walkNode nodesRef boxMapRef visitedRef p (depth + 1)) ptrs-              APClosure{payload = ptrs} -> do-                let ptrAddrs = map boxAddr ptrs-                    node = HeapNode "ap" Nothing ptrAddrs-                atomically $ modifyTVar' nodesRef (Map.insert addr node)-                mapM_ (\p -> walkNode nodesRef boxMapRef visitedRef p (depth + 1)) ptrs-              SelectorClosure{selectee = ptr} -> do-                let node = HeapNode "selector" Nothing [boxAddr ptr]-                atomically $ modifyTVar' nodesRef (Map.insert addr node)-                walkNode nodesRef boxMapRef visitedRef ptr (depth + 1)-              MutVarClosure{var = ptr} -> do-                let node = HeapNode "mutvar" Nothing [boxAddr ptr]-                atomically $ modifyTVar' nodesRef (Map.insert addr node)-                walkNode nodesRef boxMapRef visitedRef ptr (depth + 1)-              _ -> do-                let node = HeapNode "other" (Just (T.pack (take 80 (show closure')))) []-                atomically $ modifyTVar' nodesRef (Map.insert addr node)--  -- Try to extract a displayable value from a cons head pointer-  getHeadValue :: Box -> IO (Maybe Text)-  getHeadValue box = do-    c <- getBoxClosure box-    pure $ case c of-      ConstrClosure{dataArgs = (v : _), name = n}-        | n == "I#" -> Just (T.pack (show v))-        | n == "W#" -> Just (T.pack (show v))-        | n == "C#" -> Just (T.pack (show (toEnum (fromIntegral v) :: Char)))-        | otherwise -> Just (T.pack n <> " " <> T.pack (show v))-      _ -> Nothing---- Force a thunk by its Box address-forceThunk :: Session -> Text -> IO ()-forceThunk sess addr = do-  boxMap <- readTVarIO (sessBoxMap sess)-  case Map.lookup addr boxMap of-    Nothing -> putStrLn $ "Box not found: " <> T.unpack addr-    Just (Box a) -> do-      _ <--        (evaluate a >> pure ())-          `catch` \(e :: SomeException) ->-            putStrLn $ "Exception while forcing: " <> show e-      pure ()---- Render the heap as an HTML table-renderHeapTable :: UUID -> Bool -> Text -> Text -> Map Text HeapNode -> Text-renderHeapTable sid showRunBtn exprDesc rootAddr nodes =-  "<div id='main' class='max-w-5xl mx-auto'>"-    <> "<div class='flex items-center justify-between mb-6'>"-    <> "<h1 class='text-2xl font-bold text-gray-900 dark:text-gray-100'>GHC Heap Visualizer</h1>"-    <> "<div class='flex gap-2'>"-    <> runButton-    <> "<button data-on:click=\"@get('reset?s="-    <> s-    <> "')\" "-    <> "class='px-4 py-2 bg-gray-200 dark:bg-gray-700 hover:bg-gray-300 dark:hover:bg-gray-600 text-gray-700 dark:text-gray-200 rounded-lg text-sm font-medium cursor-pointer'>"-    <> "Reset</button>"-    <> "<button data-on:click='$dark = !$dark' "-    <> "class='px-4 py-2 bg-gray-200 dark:bg-gray-700 hover:bg-gray-300 dark:hover:bg-gray-600 text-gray-700 dark:text-gray-200 rounded-lg text-sm font-medium cursor-pointer'>"-    <> "<span data-show='$dark'>Light</span>"-    <> "<span data-show='!$dark'>Dark</span>"-    <> "</button>"-    <> "<button data-on:click=\"@get('heap?s="-    <> s-    <> "')\" "-    <> "class='px-4 py-2 bg-gray-200 dark:bg-gray-700 hover:bg-gray-300 dark:hover:bg-gray-600 text-gray-700 dark:text-gray-200 rounded-lg text-sm font-medium cursor-pointer'>"-    <> "Refresh</button>"-    <> "</div></div>"-    <> "<div class='text-sm text-gray-500 mb-4'>Expression: <code class='text-gray-600 dark:text-gray-400'>"-    <> exprDesc-    <> "</code>"-    <> " &middot; Root: <code class='text-gray-600 dark:text-gray-400'>"-    <> cleanAddr rootAddr-    <> "</code>"-    <> " &middot; "-    <> T.pack (show (Map.size nodes))-    <> " nodes</div>"-    <> "<div class='overflow-x-auto rounded-xl border border-gray-200 dark:border-gray-800'>"-    <> "<table class='w-full text-sm'>"-    <> "<thead><tr class='bg-gray-100 dark:bg-gray-900 text-gray-500 dark:text-gray-400 text-left'>"-    <> "<th class='px-4 py-3 font-medium'>Address</th>"-    <> "<th class='px-4 py-3 font-medium'>Type</th>"-    <> "<th class='px-4 py-3 font-medium'>Value</th>"-    <> "<th class='px-4 py-3 font-medium'>Pointers</th>"-    <> "<th class='px-4 py-3 font-medium'>Actions</th>"-    <> "</tr></thead><tbody>"-    <> mconcat (map renderRow orderedNodes)-    <> "</tbody></table></div></div>"- where-  s = UUID.toText sid--  runButton-    | showRunBtn =-        "<button data-on:click=\"@get('run?s="-          <> s-          <> "')\" "-          <> "class='px-4 py-2 bg-emerald-600 hover:bg-emerald-700 text-white rounded-lg text-sm font-medium cursor-pointer'>"-          <> "Run Demo</button>"-    | otherwise = ""--  -- Root first, then the rest sorted by address-  orderedNodes =-    let rootNode = case Map.lookup rootAddr nodes of-          Just n -> [(rootAddr, n)]-          Nothing -> []-        rest = Map.toAscList (Map.delete rootAddr nodes)-     in rootNode <> rest--  renderRow (addr, node) =-    let isRoot = addr == rootAddr-        ca = cleanAddr addr-        rowClass =-          if isRoot-            then "bg-blue-50 dark:bg-gray-800/50 border-l-2 border-blue-500"-            else "border-b border-gray-200/50 dark:border-gray-800/50 hover:bg-gray-50 dark:hover:bg-gray-800/30"-        highlight =-          " data-class=\"{"-            <> "'ring-2 ring-inset ring-cyan-400 dark:ring-cyan-500 bg-cyan-50 dark:bg-cyan-900/30': $highlight === '"-            <> ca-            <> "'"-            <> "}\""-     in "<tr id='addr-"-          <> ca-          <> "' class='"-          <> rowClass-          <> "'"-          <> highlight-          <> ">"-          <> "<td class='px-4 py-2.5 font-mono text-xs text-gray-500'>"-          <> ca-          <> (if isRoot then " <span class='text-blue-500 dark:text-blue-400 text-xs font-sans'>(root)</span>" else "")-          <> "</td>"-          <> "<td class='px-4 py-2.5'>"-          <> typeBadge (nodeType node)-          <> "</td>"-          <> "<td class='px-4 py-2.5 font-mono'>"-          <> maybe "<span class='text-gray-400 dark:text-gray-600'>-</span>" (\v -> "<span class='text-gray-800 dark:text-gray-200'>" <> v <> "</span>") (nodeValue node)-          <> "</td>"-          <> "<td class='px-4 py-2.5 font-mono text-xs'>"-          <> renderPointers (nodePointers node)-          <> "</td>"-          <> "<td class='px-4 py-2.5'>"-          <> renderActions addr node-          <> "</td>"-          <> "</tr>"--  cleanAddr addr = T.replace "/1" "" (T.replace "/2" "" addr)--  typeBadge ty-    | ty == "cons" = badge "bg-blue-100 text-blue-700 dark:bg-blue-900 dark:text-blue-300" ":"-    | ty == "nil" = badge "bg-gray-100 text-gray-600 dark:bg-gray-700 dark:text-gray-400" "[]"-    | ty == "thunk" = badge "bg-amber-100 text-amber-700 dark:bg-amber-900 dark:text-amber-300" "thunk"-    | ty == "function" = badge "bg-red-100 text-red-700 dark:bg-red-900 dark:text-red-300" "fun"-    | ty == "pap" = badge "bg-orange-100 text-orange-700 dark:bg-orange-900 dark:text-orange-300" "PAP"-    | ty == "ap" = badge "bg-yellow-100 text-yellow-700 dark:bg-yellow-900 dark:text-yellow-300" "AP"-    | ty == "selector" = badge "bg-teal-100 text-teal-700 dark:bg-teal-900 dark:text-teal-300" "sel"-    | ty == "other" = badge "bg-gray-100 text-gray-600 dark:bg-gray-700 dark:text-gray-400" "other"-    | "constr:GHC.Types.I#" `T.isPrefixOf` ty = badge "bg-purple-100 text-purple-700 dark:bg-purple-900 dark:text-purple-300" "I#"-    | "constr:" `T.isPrefixOf` ty = badge "bg-emerald-100 text-emerald-700 dark:bg-emerald-900 dark:text-emerald-300" (T.drop 7 ty)-    | otherwise = badge "bg-gray-100 text-gray-600 dark:bg-gray-700 dark:text-gray-400" ty--  badge cls label =-    "<span class='inline-block px-2 py-0.5 rounded text-xs font-medium "-      <> cls-      <> "'>"-      <> label-      <> "</span>"--  renderPointers [] = "<span class='text-gray-400 dark:text-gray-600'>-</span>"-  renderPointers ptrs = T.intercalate " " (map renderPtr ptrs)--  renderPtr p =-    let cp = cleanAddr p-     in "<a href='#addr-"-          <> cp-          <> "'"-          <> " data-on:mouseenter=\"$highlight = '"-          <> cp-          <> "'\""-          <> " data-on:mouseleave=\"$highlight = ''\""-          <> " class='text-cyan-700 dark:text-cyan-600 hover:underline cursor-pointer'>"-          <> cp-          <> "</a>"--  renderActions addr node-    | nodeType node == "thunk" || nodeType node == "ap" || nodeType node == "selector" =-        "<button data-on:click=\"@get('force?s="-          <> s-          <> "&addr="-          <> addr-          <> "')\" "-          <> "class='px-3 py-1 bg-amber-200 hover:bg-amber-300 text-amber-800 dark:bg-amber-800 dark:hover:bg-amber-700 dark:text-amber-200 rounded text-xs font-medium cursor-pointer'>"-          <> "Force</button>"-    | otherwise = ""---- Application--main :: IO ()-main = do-  args <- getArgs-  case args of-    [name'] | Just mode <- lookup name' allModes -> startServer 3000 mode-    [name', portStr] | Just mode <- lookup name' allModes -> startServer (read portStr) mode-    _ -> do-      hPutStrLn stderr "Usage: heap-view <mode> [port]"-      hPutStrLn stderr ""-      hPutStrLn stderr "Modes:"-      mapM_ (\(name', mode) -> hPutStrLn stderr $ "  " <> name' <> replicate (16 - length name') ' ' <> T.unpack (modeDesc mode)) allModes-      exitFailure--startServer :: Int -> Mode -> IO ()-startServer port mode = do-  htmlContent <- BS.readFile "examples/heap-view.html"-  let hasRun = case modeRun mode of Just _ -> True; Nothing -> False-  appState <--    AppState-      <$> newTVarIO Map.empty-      <*> pure mode-      <*> pure hasRun-  putStrLn $ "GHC Heap Visualizer [" <> T.unpack (modeName mode) <> "]"-  putStrLn $ "Listening on http://localhost:" <> show port-  Warp.run port (app htmlContent appState)--app :: BS.ByteString -> AppState -> Application-app htmlContent appState req respond =-  case (requestMethod req, pathInfo req) of-    ("GET", []) ->-      respond $ responseLBS status200 [("Content-Type", "text/html")] (LBS.fromStrict htmlContent)-    ("GET", ["heap"]) ->-      withSession appState req respond $ \sess ->-        handleHeap appState sess req respond-    ("GET", ["force"]) ->-      withSession appState req respond $ \sess ->-        handleForce appState sess req respond-    ("GET", ["run"])-      | Just _ <- modeRun (appMode appState) ->-          withSession appState req respond $ \sess ->-            handleRun appState sess req respond-    ("GET", ["reset"]) ->-      handleReset appState req respond-    _ ->-      respond $ responseLBS status404 [] "Not found"--sendHeapUpdate :: AppState -> Session -> ServerSentEventGenerator -> IO ()-sendHeapUpdate appState sess gen = do-  box <- readTVarIO (sessExpression sess)-  desc <- readTVarIO (sessExprDesc sess)-  performGC-  (rootAddr, nodes) <- walkHeap sess box 20-  let html = renderHeapTable (sessId sess) (appHasRun appState) desc rootAddr nodes-  sendPatchElements gen (patchElements html)--compressors :: [Compressor]-compressors = [brotli, gzip, deflate]--handleHeap :: AppState -> Session -> Request -> (Response -> IO b) -> IO b-handleHeap appState sess req respond =-  respond $ sseResponseWith nullLogger compressors req $ \gen ->-    sendHeapUpdate appState sess gen--handleForce :: AppState -> Session -> Request -> (Response -> IO b) -> IO b-handleForce appState sess req respond = do-  let params = queryToQueryText (queryString req)-  case lookup "addr" params of-    Just (Just addr) -> do-      forceThunk sess addr-      respond $ sseResponseWith nullLogger compressors req $ \gen ->-        sendHeapUpdate appState sess gen-    _ ->-      respond $ responseLBS status400 [] "Missing addr parameter"--handleReset :: AppState -> Request -> (Response -> IO b) -> IO b-handleReset appState req respond = do-  -- Reuse existing session on explicit reset, create new on first page load-  sess <- case getSessionId req of-    Just sid -> do-      msess <- lookupSession appState sid-      case msess of-        Just s -> pure s-        Nothing -> newSession appState-    Nothing -> newSession appState-  modeSetup (appMode appState) sess-  respond $ sseResponseWith nullLogger compressors req $ \gen ->-    sendHeapUpdate appState sess gen--handleRun :: AppState -> Session -> Request -> (Response -> IO b) -> IO b-handleRun appState sess req respond = do-  case modeRun (appMode appState) of-    Just run -> do-      run sess-      respond $ sseResponseWith nullLogger compressors req $ \gen -> do-        -- Stream live updates every 200ms for ~12 seconds-        replicateM_ 60 $ do-          sendHeapUpdate appState sess gen-          threadDelay 200000-    Nothing ->-      respond $ responseLBS status404 [] "Not found"

@@ -1,97 +0,0 @@-module Main (main) where--import Control.Concurrent.STM (TVar, atomically, newTVarIO, readTVar, readTVarIO, registerDelay, retry, writeTVar)-import Control.Monad (forever)-import Data.Aeson (FromJSON (..), withObject, (.:))-import Data.ByteString qualified as BS-import Data.ByteString.Lazy qualified as LBS-import Data.Text qualified as T-import Hypermedia.Datastar-import Hypermedia.Datastar.Compression.Brotli (brotli)-import Hypermedia.Datastar.Compression.Zlib (deflate, gzip)-import Network.HTTP.Types (status200, status404)-import Network.Wai (Application, pathInfo, requestMethod, responseLBS)-import Network.Wai qualified as Wai-import Network.Wai.Handler.Warp qualified as Warp-import System.Environment (getArgs)--newtype Signals = Signals {_delay :: Int}-  deriving (Show)--instance FromJSON Signals where-  parseJSON = withObject "Signals" $ \o ->-    Signals <$> o .: "delay"--data SharedState = SharedState-  { _delayVar :: TVar Int-  , _versionVar :: TVar Int-  }--message :: String-message = "Hello, world!"--compressors :: [Compressor]-compressors = [brotli, gzip, deflate]--main :: IO ()-main = do-  args <- getArgs-  let port = case args of-        (p : _) -> read p-        _ -> 3000-  htmlContent <- BS.readFile "examples/hello-world-channel.html"-  state <- SharedState <$> newTVarIO 400 <*> newTVarIO 0-  putStrLn $ "Listening on http://localhost:" <> show port-  Warp.run port (app htmlContent state)--app :: BS.ByteString -> SharedState -> Application-app htmlContent state req respond =-  case (requestMethod req, pathInfo req) of-    ("GET", []) ->-      respond $ responseLBS status200 [("Content-Type", "text/html")] (LBS.fromStrict htmlContent)-    ("GET", ["set-delay"]) ->-      handleSetDelay state req respond-    ("GET", ["hello-world"]) ->-      handleHelloWorld state req respond-    _ ->-      respond $ responseLBS status404 [] "Not found"--handleSetDelay :: SharedState -> Wai.Request -> (Wai.Response -> IO b) -> IO b-handleSetDelay state req respond = do-  signalsResult <- readSignals req :: IO (Either String Signals)-  case signalsResult of-    Left _ -> respond $ responseLBS status404 [] "Bad signals"-    Right signals -> do-      atomically $ do-        writeTVar (_delayVar state) (_delay signals)-        v <- readTVar (_versionVar state)-        writeTVar (_versionVar state) (v + 1)-      respond $ sseResponseWith nullLogger compressors req $ \_ -> pure ()--handleHelloWorld :: SharedState -> Wai.Request -> (Wai.Response -> IO b) -> IO b-handleHelloWorld state req respond =-  respond $ sseResponseWith nullLogger compressors req $ \gen ->-    forever $ do-      version <- readTVarIO (_versionVar state)-      d <- readTVarIO (_delayVar state)-      animate gen state d version [0 .. length message]---- Animate character by character; breaks out early if the version changes--- (i.e. Start was clicked), letting `forever` restart from the beginning.-animate :: ServerSentEventGenerator -> SharedState -> Int -> Int -> [Int] -> IO ()-animate _ _ _ _ [] = pure ()-animate gen state d version (i : is) = do-  let html = "<div id='message'>" <> T.pack (take i message) <> "</div>"-  sendPatchElements gen (patchElements html)-  -- Race the delay against a version change-  timedOut <- registerDelay (d * 1000)-  interrupted <- atomically $ do-    timeout <- readTVar timedOut-    v <- readTVar (_versionVar state)-    case (timeout, v /= version) of-      (_, True) -> pure True -- version changed, interrupt-      (True, _) -> pure False -- delay elapsed, continue-      _ -> retry -- neither yet, keep waiting-  if interrupted-    then pure () -- break out; forever will restart-    else animate gen state d version is

@@ -1,76 +0,0 @@-module Main (main) where--import Control.Concurrent (threadDelay)-import Data.Aeson (FromJSON (..), withObject, (.:))-import Data.ByteString qualified as BS-import Data.ByteString.Lazy qualified as LBS-import Data.Text qualified as T-import Hypermedia.Datastar-import Hypermedia.Datastar.Compression.Brotli (brotli)-import Hypermedia.Datastar.Compression.Zlib (deflate, gzip)-import Network.HTTP.Media ((//))-import Network.HTTP.Types (status404)-import Network.Wai qualified as Wai-import Network.Wai.Handler.Warp qualified as Warp-import Servant-import System.Environment (getArgs)--data HTML--instance Accept HTML where-  contentType _ = "text" // "html"--instance MimeRender HTML LBS.ByteString where-  mimeRender _ = id--newtype Signals = Signals {delay :: Int}--instance FromJSON Signals where-  parseJSON = withObject "Signals" $ \o ->-    Signals <$> o .: "delay"--message :: String-message = "Hello, world!"--compressors :: [Compressor]-compressors = [brotli, gzip, deflate]--type API =-  Get '[HTML] LBS.ByteString-    :<|> "hello-world" :> Raw--server :: BS.ByteString -> Server API-server htmlContent =-  serveIndex htmlContent-    :<|> serveHelloWorld--serveIndex :: BS.ByteString -> Handler LBS.ByteString-serveIndex htmlContent =-  pure $ LBS.fromStrict htmlContent--serveHelloWorld :: Tagged Handler Application-serveHelloWorld = Tagged $ \req respond' -> do-  signalsResult <- readSignals req :: IO (Either String Signals)-  case signalsResult of-    Left _ -> respond' $ Wai.responseLBS status404 [] "Bad signals"-    Right signals -> respond' $ sseResponseWith nullLogger compressors req $ \gen ->-      mapM_-        ( \i -> do-            let html = "<div id='message'>" <> T.pack (take i message) <> "</div>"-            sendPatchElements gen (patchElements html)-            threadDelay (delay signals * 1000)-        )-        [1 .. length message]--app :: BS.ByteString -> Application-app htmlContent = serve (Proxy :: Proxy API) (server htmlContent)--main :: IO ()-main = do-  args <- getArgs-  let port = case args of-        (p : _) -> read p-        _ -> 3000-  htmlContent <- BS.readFile "examples/hello-world.html"-  putStrLn $ "Listening on http://localhost:" <> show port-  Warp.run port (app htmlContent)

@@ -1,61 +0,0 @@-module Main (main) where--import Control.Concurrent (threadDelay)-import Data.Aeson (FromJSON (..), withObject, (.:))-import Data.ByteString qualified as BS-import Data.ByteString.Lazy qualified as LBS-import Data.Text qualified as T-import Hypermedia.Datastar-import Hypermedia.Datastar.Compression.Brotli (brotli)-import Hypermedia.Datastar.Compression.Zlib (deflate, gzip)-import Network.HTTP.Types (status200, status404)-import Network.Wai (Application, pathInfo, requestMethod, responseLBS)-import Network.Wai qualified as Wai-import Network.Wai.Handler.Warp qualified as Warp-import System.Environment (getArgs)--compressors :: [Compressor]-compressors = [brotli, gzip, deflate]--newtype Signals = Signals {delay :: Int}--instance FromJSON Signals where-  parseJSON = withObject "Signals" $ \o ->-    Signals <$> o .: "delay"--message :: String-message = "Hello, world!"--main :: IO ()-main = do-  args <- getArgs-  let port = case args of-        (p : _) -> read p-        _ -> 3000-  htmlContent <- BS.readFile "examples/hello-world.html"-  putStrLn $ "Listening on http://localhost:" <> show port-  Warp.run port (app htmlContent)--app :: BS.ByteString -> Application-app htmlContent req respond =-  case (requestMethod req, pathInfo req) of-    ("GET", []) ->-      respond $ responseLBS status200 [("Content-Type", "text/html")] (LBS.fromStrict htmlContent)-    ("GET", ["hello-world"]) ->-      handleHelloWorld req respond-    _ ->-      respond $ responseLBS status404 [] "Not found"--handleHelloWorld :: Wai.Request -> (Wai.Response -> IO b) -> IO b-handleHelloWorld req respond = do-  signalsResult <- readSignals req :: IO (Either String Signals)-  case signalsResult of-    Left _ -> respond $ responseLBS status404 [] "Bad signals"-    Right signals -> respond $ sseResponseWith nullLogger compressors req $ \gen ->-      mapM_-        ( \i -> do-            let html = "<div id='message'>" <> T.pack (take i message) <> "</div>"-            sendPatchElements gen (patchElements html)-            threadDelay (delay signals * 1000)-        )-        [1 .. length message]

@@ -36,14 +36,17 @@  === With compression -Use 'sseResponseWith' to negotiate a @Content-Encoding@ from the request's-@Accept-Encoding@ header. Pass the compressors you want to offer, in-preference order — the first one the client accepts wins:+Compressors live in add-on packages so this core package needs no system C+libraries: @datastar-hs-zlib@ (gzip, deflate), @datastar-hs-brotli@ (br), and+@datastar-hs-zstd@ (zstd). Use 'sseResponseWith' to negotiate a+@Content-Encoding@ from the request's @Accept-Encoding@ header. Pass the+compressors you want to offer, in preference order — the first one the client+accepts wins:  @ import Hypermedia.Datastar-import Hypermedia.Datastar.Compression.Brotli (brotli)-import Hypermedia.Datastar.Compression.Zlib (deflate, gzip)+import Hypermedia.Datastar.Compression.Brotli (brotli)       -- datastar-hs-brotli+import Hypermedia.Datastar.Compression.Zlib (deflate, gzip)  -- datastar-hs-zlib  app req respond =   respond $ sseResponseWith nullLogger [brotli, gzip, deflate] req $ \\gen ->@@ -60,8 +63,8 @@ * "Hypermedia.Datastar.PatchSignals" — update the browser's reactive signals * "Hypermedia.Datastar.ExecuteScript" — run JavaScript in the browser * "Hypermedia.Datastar.WAI" — SSE streaming, signal decoding, request helpers-* "Hypermedia.Datastar.Compression.Brotli", "Hypermedia.Datastar.Compression.Zlib" — @Content-Encoding@ compressors * "Hypermedia.Datastar.Types" — protocol types and defaults+* @Hypermedia.Datastar.Compression.*@ — @Content-Encoding@ compressors, in the add-on packages @datastar-hs-zlib@, @datastar-hs-brotli@, and @datastar-hs-zstd@  === Further reading @@ -97,11 +100,14 @@   , isDatastarRequest      -- * Compression-    ---    -- | Negotiate @Content-Encoding@ for an SSE stream. Pass one or more-    -- compressors from "Hypermedia.Datastar.Compression.Brotli" or-    -- "Hypermedia.Datastar.Compression.Zlib". 'sseResponseWith' uses-    -- 'ServerPriority'; 'sseResponseWithStrategy' lets you choose.++  --++    {- | Negotiate @Content-Encoding@ for an SSE stream. Pass one or more+    compressors from the add-on packages @datastar-hs-zlib@,+    @datastar-hs-brotli@, or @datastar-hs-zstd@. 'sseResponseWith' uses+    'ServerPriority'; 'sseResponseWithStrategy' lets you choose.+    -}   , Compressor   , CompressionStrategy (..)   , sseResponseWith

@@ -1,30 +1,32 @@--- | Smart constructors and modifier combinators for Datastar HTML attributes.------ Every Datastar attribute is a @(name, value)@ pair — the value of the--- 'Attribute' type alias. Pair it with whatever HTML library you use:------ > -- lucid2:--- > button_ [ uncurry makeAttributes (onClick "$count++") ] "Inc"------ Modifiers (the @__suffix@ parts of an attribute name) are plain--- @Attribute -> Attribute@ functions you compose with '(.)' or '(&)':------ > import Data.Function ((&))--- > onInput "@get('/search')"--- >   & debounce 200--- >   & prevent--- > -- => ("data-on:input__debounce.200ms__prevent", "@get('/search')")------ For an event the library doesn't have a shortcut for, 'dataOn' takes any--- 'Text':------ > dataOn "my-custom-event" "..."+{- | Smart constructors and modifier combinators for Datastar HTML attributes.++Every Datastar attribute is a @(name, value)@ pair — the value of the+'Attribute' type alias. Pair it with whatever HTML library you use:++> -- lucid2:+> button_ [ uncurry makeAttributes (onClick "$count++") ] "Inc"++Modifiers (the @__suffix@ parts of an attribute name) are plain+@Attribute -> Attribute@ functions you compose with '(.)' or '(&)':++> import Data.Function ((&))+> onInput "@get('/search')"+>   & debounce 200+>   & prevent+> -- => ("data-on:input__debounce.200ms__prevent", "@get('/search')")++For an event the library doesn't have a shortcut for, 'dataOn' takes any+'Text':++> dataOn "my-custom-event" "..."+-} module Hypermedia.Datastar.Attributes   ( -- * The attribute pair     Attribute      -- * Event handlers   , dataOn+     -- ** Common event shortcuts   , onClick   , onSubmit@@ -98,6 +100,7 @@   , dataPreserveAttr      -- * Modifier combinators+     -- ** Event flags   , prevent   , stop@@ -108,28 +111,34 @@   , document_   , outside   , viewTransition+     -- ** Timing   , debounce   , debounceWith   , throttle   , throttleWith   , delay+     -- ** Casing   , camelCase   , kebabCase   , snakeCase   , pascalCase+     -- ** on-intersect   , full   , half   , threshold   , exit+     -- ** on-interval   , duration   , durationWith+     -- ** bind   , bindProp   , bindEvents+     -- ** signals \/ json-signals \/ ignore   , ifMissing   , terse@@ -158,53 +167,60 @@ -- Event handlers -- --------------------------------------------------------------------------- --- | @data-on:\<event\>="\<expr\>"@. Use the shortcuts below for common events,--- or call directly for custom events (e.g. @dataOn \"my-custom-event\" ...@).+{- | @data-on:\<event\>="\<expr\>"@. Use the shortcuts below for common events,+or call directly for custom events (e.g. @dataOn \"my-custom-event\" ...@).+-} dataOn :: Text -> Text -> Attribute dataOn ev expr = ("data-on:" <> ev, expr)  onClick, onSubmit, onInput, onChange, onFocus, onBlur :: Text -> Attribute-onClick  = dataOn "click"+onClick = dataOn "click" onSubmit = dataOn "submit"-onInput  = dataOn "input"+onInput = dataOn "input" onChange = dataOn "change"-onFocus  = dataOn "focus"-onBlur   = dataOn "blur"+onFocus = dataOn "focus"+onBlur = dataOn "blur"  onKeyDown, onKeyUp, onKeyPress :: Text -> Attribute-onKeyDown  = dataOn "keydown"-onKeyUp    = dataOn "keyup"+onKeyDown = dataOn "keydown"+onKeyUp = dataOn "keyup" onKeyPress = dataOn "keypress" -onMouseDown, onMouseUp, onMouseMove,-  onMouseEnter, onMouseLeave, onMouseOver, onMouseOut :: Text -> Attribute-onMouseDown  = dataOn "mousedown"-onMouseUp    = dataOn "mouseup"-onMouseMove  = dataOn "mousemove"+onMouseDown+  , onMouseUp+  , onMouseMove+  , onMouseEnter+  , onMouseLeave+  , onMouseOver+  , onMouseOut+    :: Text -> Attribute+onMouseDown = dataOn "mousedown"+onMouseUp = dataOn "mouseup"+onMouseMove = dataOn "mousemove" onMouseEnter = dataOn "mouseenter" onMouseLeave = dataOn "mouseleave"-onMouseOver  = dataOn "mouseover"-onMouseOut   = dataOn "mouseout"+onMouseOver = dataOn "mouseover"+onMouseOut = dataOn "mouseout"  onWheel, onScroll, onResize, onContextMenu :: Text -> Attribute-onWheel       = dataOn "wheel"-onScroll      = dataOn "scroll"-onResize      = dataOn "resize"+onWheel = dataOn "wheel"+onScroll = dataOn "scroll"+onResize = dataOn "resize" onContextMenu = dataOn "contextmenu"  onTouchStart, onTouchEnd, onTouchMove :: Text -> Attribute onTouchStart = dataOn "touchstart"-onTouchEnd   = dataOn "touchend"-onTouchMove  = dataOn "touchmove"+onTouchEnd = dataOn "touchend"+onTouchMove = dataOn "touchmove"  onDragStart, onDragEnd, onDrop :: Text -> Attribute onDragStart = dataOn "dragstart"-onDragEnd   = dataOn "dragend"-onDrop      = dataOn "drop"+onDragEnd = dataOn "dragend"+onDrop = dataOn "drop"  onCopy, onCut, onPaste :: Text -> Attribute-onCopy  = dataOn "copy"-onCut   = dataOn "cut"+onCopy = dataOn "copy"+onCut = dataOn "cut" onPaste = dataOn "paste"  onLoad :: Text -> Attribute@@ -212,8 +228,8 @@  onAnimationStart, onAnimationEnd, onTransitionEnd :: Text -> Attribute onAnimationStart = dataOn "animationstart"-onAnimationEnd   = dataOn "animationend"-onTransitionEnd  = dataOn "transitionend"+onAnimationEnd = dataOn "animationend"+onTransitionEnd = dataOn "transitionend"  -- --------------------------------------------------------------------------- -- Reactive attributes@@ -311,8 +327,9 @@ -- Lifecycle events -- --------------------------------------------------------------------------- --- | @data-on-intersect="\<expr\>"@. Combine with 'full', 'half', 'threshold',--- 'once', 'exit'.+{- | @data-on-intersect="\<expr\>"@. Combine with 'full', 'half', 'threshold',+'once', 'exit'.+-} dataOnIntersect :: Text -> Attribute dataOnIntersect expr = ("data-on-intersect", expr) @@ -357,8 +374,9 @@ withModifierTags label tags (k, v) =   (k <> "__" <> label <> T.concat (map ("." <>) tags), v) --- | Build any @(name, value)@ pair directly. Escape hatch for attributes or--- modifiers this module doesn't model.+{- | Build any @(name, value)@ pair directly. Escape hatch for attributes or+modifiers this module doesn't model.+-} rawAttr :: Text -> Text -> Attribute rawAttr = (,) @@ -366,8 +384,8 @@  prevent, stop, once, capture, passive :: Attribute -> Attribute prevent = withModifier "prevent"-stop    = withModifier "stop"-once    = withModifier "once"+stop = withModifier "stop"+once = withModifier "once" capture = withModifier "capture" passive = withModifier "passive" @@ -412,9 +430,9 @@ -- Casing -------------------------------------------------------------------  camelCase, kebabCase, snakeCase, pascalCase :: Attribute -> Attribute-camelCase  = withModifierTags "case" ["camel"]-kebabCase  = withModifierTags "case" ["kebab"]-snakeCase  = withModifierTags "case" ["snake"]+camelCase = withModifierTags "case" ["camel"]+kebabCase = withModifierTags "case" ["kebab"]+snakeCase = withModifierTags "case" ["snake"] pascalCase = withModifierTags "case" ["pascal"]  -- on-intersect -------------------------------------------------------------@@ -473,14 +491,15 @@ -- Tag constants -- --------------------------------------------------------------------------- --- $tags--- Plain 'Text' values for use with the @*With@ combinators.+{- $tags+Plain 'Text' values for use with the @*With@ combinators.+-}  leading, noTrailing, noLeading, trailing :: Text-leading    = "leading"+leading = "leading" noTrailing = "notrailing"-noLeading  = "noleading"-trailing   = "trailing"+noLeading = "noleading"+trailing = "trailing"  -- --------------------------------------------------------------------------- -- Internal

@@ -1,68 +0,0 @@-module Hypermedia.Datastar.Compression.Brotli-  ( brotli-  , brotliWith-  , defaultBrotliParams-  )-where--import Codec.Compression.Brotli qualified as B-import Data.ByteString qualified as BS-import Data.ByteString.Builder qualified as BSB-import Data.ByteString.Lazy qualified as BL-import Control.Concurrent.MVar--import Hypermedia.Datastar.WAI (Compressor (..))--brotli :: Compressor-brotli = brotliWith defaultBrotliParams--brotliWith :: B.CompressParams -> Compressor-brotliWith params = Compressor "br" wrap-  where-    wrap rawWrite rawFlush = do-      csM <- B.compressIO params >>= newMVar--      let write builder = do-            let bs = BL.toStrict $ BSB.toLazyByteString builder-            if BS.null bs-              then pure ()-              else modifyMVar_ csM $ \case -                     B.CompressInputRequired _ supply ->-                       supply bs >>= doRawWrites rawWrite-                     other -> pure other--          flush = do-            modifyMVar_ csM $ \case-              B.CompressInputRequired doFlush _ ->-                doFlush >>= doRawWrites rawWrite-              other -> pure other-            rawFlush--          finish = do-            modifyMVar_ csM $ \case-              B.CompressInputRequired _ supply ->-                supply BS.empty >>= doRawWrites rawWrite-              other -> pure other-            rawFlush--      return (write, flush, finish)--doRawWrites-  :: (BSB.Builder -> IO ())-  -> B.CompressStream IO-  -> IO (B.CompressStream IO)-doRawWrites rawWrite cs = case cs of-  B.CompressOutputAvailable chunk nextAction -> do-    rawWrite $ BSB.byteString chunk-    cs' <- nextAction-    doRawWrites rawWrite cs'-  _ -> pure cs--defaultBrotliParams :: B.CompressParams-defaultBrotliParams =-  B.defaultCompressParams-    { B.compressMode = B.CompressionModeText-    , B.compressLevel = B.CompressionLevel5-    , B.compressWindowSize = B.CompressionWindowBits24-    }-

@@ -1,68 +0,0 @@-module Hypermedia.Datastar.Compression.Zlib-  ( gzip-  , gzipWith-  , deflate-  , deflateWith-  , defaultCompressionLevel-  )-where--import Control.Exception (throwIO)--import Data.ByteString qualified as BS-import Data.ByteString.Builder qualified as BSB-import Data.ByteString.Lazy qualified as BL--import Data.Streaming.Zlib-  ( PopperRes (..)-  , WindowBits (..)-  , feedDeflate-  , finishDeflate-  , flushDeflate-  , initDeflate-  )--import Hypermedia.Datastar.WAI (Compressor (..))--defaultCompressionLevel :: Int-defaultCompressionLevel = 6---- | A gzip 'Compressor' (@Content-Encoding: gzip@) at 'defaultCompressionLevel'.-gzip :: Compressor-gzip = gzipWith defaultCompressionLevel---- | A gzip 'Compressor' at an explicit zlib level (0–9).-gzipWith :: Int -> Compressor-gzipWith level = zlibCompressor "gzip" level (WindowBits 31)---- | A zlib/deflate 'Compressor' (@Content-Encoding: deflate@) at 'defaultCompressionLevel'.-deflate :: Compressor-deflate = deflateWith defaultCompressionLevel---- | A zlib/deflate 'Compressor' at an explicit zlib level (0–9).-deflateWith :: Int -> Compressor-deflateWith level = zlibCompressor "deflate" level (WindowBits 15)---- WindowBits 31 selects gzip framing, 15 selects zlib/deflate framing.-zlibCompressor :: BS.ByteString -> Int -> WindowBits -> Compressor-zlibCompressor enc level wbits = Compressor enc wrap-  where -    wrap rawWrite rawFlush = do-        def <- initDeflate level wbits--        let drain popper = do-              res <- popper-              case res of-                PRDone -> pure ()-                PRNext bs -> rawWrite (BSB.byteString bs) >> drain popper-                PRError e -> throwIO e--            write builder = do-              popper <- feedDeflate def $ BL.toStrict $ BSB.toLazyByteString builder-              drain popper--            flush = drain (flushDeflate def) >> rawFlush--            finish = drain (finishDeflate def) >> rawFlush--        pure (write, flush, finish)

@@ -1,131 +0,0 @@-{- |-A 'Compressor' that compresses an SSE stream with zstd (@Content-Encoding: zstd@),-driving libzstd's streaming API directly so each event can be flushed.--}-module Hypermedia.Datastar.Compression.Zstd-  ( zstd-  , zstdWith-  , defaultZstdLevel-  )-where--import Control.Exception (Exception, throwIO)-import Control.Monad (unless, when)--import Data.ByteString qualified as BS-import Data.ByteString.Builder qualified as BSB-import Data.ByteString.Lazy qualified as BL-import Data.ByteString.Unsafe qualified as BU-import Data.Word (Word8)--import Foreign.ForeignPtr-  ( ForeignPtr-  , finalizeForeignPtr-  , mallocForeignPtrBytes-  , newForeignPtr-  , withForeignPtr-  )-import Foreign.Marshal.Alloc (finalizerFree, malloc)-import Foreign.Ptr (Ptr, castPtr, nullPtr)-import Foreign.Storable (peek, poke)--import Codec.Compression.Zstd.FFI-  ( Buffer (..)-  , In-  , Out-  , compressStream-  , createCStream-  , cstreamOutSize-  , endStream-  , flushStream-  , getErrorName-  , initCStream-  , isError-  , p_freeCStream-  )--import Hypermedia.Datastar.WAI (Compressor (..))--newtype ZstdError = ZstdError String-  deriving (Show)--instance Exception ZstdError---- | zstd's default compression level (3).-defaultZstdLevel :: Int-defaultZstdLevel = 3---- | A zstd 'Compressor' (@Content-Encoding: zstd@) at 'defaultZstdLevel'.-zstd :: Compressor-zstd = zstdWith defaultZstdLevel---- | A zstd 'Compressor' at an explicit compression level (1–22).-zstdWith :: Int -> Compressor-zstdWith level =-  Compressor-    { compressorEncoding = "zstd"-    , compressorWrap = \rawWrite rawFlush -> do-        let out = rawWrite . BSB.byteString-            outSize = fromIntegral cstreamOutSize :: Int--        csPtr <- createCStream-        when (csPtr == nullPtr) $ throwIO (ZstdError "ZSTD_createCStream returned NULL")-        initRet <- initCStream csPtr (fromIntegral level)-        when (isError initRet) $-          throwIO (ZstdError ("ZSTD_initCStream: " <> getErrorName initRet))-        csFp <- newForeignPtr p_freeCStream csPtr--        inFp <- newForeignPtr finalizerFree =<< (malloc :: IO (Ptr (Buffer In)))-        outFp <- newForeignPtr finalizerFree =<< (malloc :: IO (Ptr (Buffer Out)))-        scratchFp <- mallocForeignPtrBytes outSize :: IO (ForeignPtr Word8)--        let-          drainOut outBuf scratch = do-            produced <- fromIntegral . bufPos <$> peek outBuf-            when (produced > 0) $-              out =<< BS.packCStringLen (castPtr scratch, produced)--          resetOut outBuf scratch =-            poke outBuf (Buffer scratch (fromIntegral outSize) 0)--          checkRet ctx ret =-            when (isError ret) $ throwIO (ZstdError (ctx <> ": " <> getErrorName ret))--          write builder =-            let bs = BL.toStrict (BSB.toLazyByteString builder)-             in unless (BS.null bs) $-                  BU.unsafeUseAsCStringLen bs $ \(srcPtr, len) ->-                    withForeignPtr csFp $ \cs ->-                      withForeignPtr inFp $ \inBuf ->-                        withForeignPtr outFp $ \outBuf ->-                          withForeignPtr scratchFp $ \scratch -> do-                            poke inBuf (Buffer (castPtr srcPtr) (fromIntegral len) 0)-                            let loop = do-                                  resetOut outBuf scratch-                                  checkRet "ZSTD_compressStream" =<< compressStream cs outBuf inBuf-                                  drainOut outBuf scratch-                                  consumed <- fromIntegral . bufPos <$> peek inBuf-                                  when (consumed < len) loop-                            loop--          pump name op =-            withForeignPtr csFp $ \cs ->-              withForeignPtr outFp $ \outBuf ->-                withForeignPtr scratchFp $ \scratch -> do-                  let loop = do-                        resetOut outBuf scratch-                        remaining <- op cs outBuf-                        checkRet name remaining-                        drainOut outBuf scratch-                        when (remaining > 0) loop-                  loop--          flush = pump "ZSTD_flushStream" flushStream >> rawFlush--          finish = do-            pump "ZSTD_endStream" endStream-            finalizeForeignPtr csFp-            rawFlush--        pure (write, flush, finish)-    }

@@ -51,9 +51,8 @@ import Data.ByteString.Builder qualified as BSB import Data.ByteString.Char8 qualified as BS8 -import           Data.List  (find)-import           Data.Maybe (listToMaybe)-+import Data.List (find)+import Data.Maybe (listToMaybe)  import Network.HTTP.Types qualified as WAI import Network.Wai qualified as WAI@@ -64,18 +63,20 @@ import Hypermedia.Datastar.Logger qualified as Logger import Hypermedia.Datastar.PatchElements qualified as PE import Hypermedia.Datastar.PatchSignals qualified as PS-data Compressor = Compressor ++data Compressor = Compressor   { compressorEncoding :: BS.ByteString   -- ^ The @Content-Encoding@ token, e.g. @"br"@ for Brotli compression.+  , compressorWrap+      :: (BSB.Builder -> IO ())+      -> IO ()+      -> IO (BSB.Builder -> IO (), IO (), IO ())+  {- ^ @compressorWrap rawWrite rawFlush@ returns @(write, flush, finish)@. -  , compressorWrap :: (BSB.Builder -> IO ())-                   -> IO ()-                   -> IO (BSB.Builder -> IO (), IO (), IO ())-  -- ^ @compressorWrap rawWrite rawFlush@ returns @(write, flush, finish)@.-  ---  -- * @write@ compresses and forwards bytes for an event;-  -- * @flush@ flushes the compression encoded and then the underlying raw transport;-  -- * @finish@ closes the compression stream.+  * @write@ compresses and forwards bytes for an event;+  * @flush@ flushes the compression encoded and then the underlying raw transport;+  * @finish@ closes the compression stream.+  -}   }  data CompressionStrategy@@ -84,9 +85,10 @@   | Forced   deriving (Eq, Show) --- | Faithful port of the Go reference parser: split on ',', trim surrounding--- whitespace, take the token before ';', drop empties. No q-value handling,--- no case folding, no wildcard logic.+{- | Faithful port of the Go reference parser: split on ',', trim surrounding+whitespace, take the token before ';', drop empties. No q-value handling,+no case folding, no wildcard logic.+-} parseEncodings :: BS.ByteString -> [BS.ByteString] parseEncodings header =   [ token@@ -94,18 +96,19 @@   , let token = BS8.takeWhile (/= ';') (strip part)   , not (BS8.null token)   ]-  where-    strip   = BS8.dropWhile isOWS . BS8.dropWhileEnd isOWS-    isOWS c = c == ' ' || c == '\t'+ where+  strip = BS8.dropWhile isOWS . BS8.dropWhileEnd isOWS+  isOWS c = c == ' ' || c == '\t' --- | The encoding tokens of a request's @Accept-Encoding@ header, in order.--- An absent or empty header yields [].+{- | The encoding tokens of a request's @Accept-Encoding@ header, in order.+An absent or empty header yields [].+-} clientEncodings :: WAI.Request -> [BS.ByteString]-clientEncodings req -  = maybe-     [] -     parseEncodings-     (lookup WAI.hAcceptEncoding $ WAI.requestHeaders req)+clientEncodings req =+  maybe+    []+    parseEncodings+    (lookup WAI.hAcceptEncoding $ WAI.requestHeaders req)  {- | Pick a compressor for a request's @Accept-Encoding@ header using the given 'CompressionStrategy', or 'Nothing' if none applies. Token matching is exact@@ -117,21 +120,19 @@     ServerPriority ->       -- first server compressor whose token the client sent       find (\c -> compressorEncoding c `elem` accepted) compressors-     ClientPriority ->       -- first client token (header order) that the server offers       listToMaybe         [ c         | enc <- accepted-        , c   <- compressors+        , c <- compressors         , compressorEncoding c == enc         ]-     Forced ->       -- first configured compressor, regardless of Accept-Encoding       listToMaybe compressors-  where-    accepted = clientEncodings req+ where+  accepted = clientEncodings req  {- | An opaque handle for sending SSE events to the browser. @@ -266,7 +267,7 @@ readSignals req   | WAI.requestMethod req == "GET"       || WAI.requestMethod req == "DELETE" =-          pure $ parseFromQuery req+      pure $ parseFromQuery req   | otherwise =       parseFromBody req 

@@ -1,107 +0,0 @@-module Hypermedia.Datastar.Compression.BrotliSpec (spec) where--import Test.Hspec--import Codec.Compression.Brotli qualified as B-import Data.ByteString.Builder qualified as BSB-import Data.ByteString.Lazy qualified as BL-import Data.IORef--import Network.Wai (defaultRequest, requestHeaders)-import Network.Wai.Internal (Response (..))--import Hypermedia.Datastar-import Hypermedia.Datastar.Compression.Brotli (brotli)-import Hypermedia.Datastar.Logger (nullLogger)-import Hypermedia.Datastar.WAI (Compressor (..), compressorWrap, negotiateWith)---- | Drive a streaming WAI response to completion, returning its response headers--- and the full raw body.-runStream (ResponseStream _status headers body) = do-  ref <- newIORef mempty-  body (\chunk -> modifyIORef' ref (<> chunk)) (pure ())-  bytes <- BSB.toLazyByteString <$> readIORef ref-  pure (headers, bytes)-runStream _ = error "expected a streaming response"---- | A compressor that only carries an encoding token, for negotiation tests.--- Its 'compressorWrap' is never invoked by 'negotiateWith'.-fakeCompressor :: BL.ByteString -> Compressor-fakeCompressor enc = Compressor (BL.toStrict enc) (\_ _ -> error "unused")--spec :: Spec-spec = describe "Hypermedia.Datastar.Compression.Brotli" $ do-  let sendEvents gen = do-        sendPatchElements gen (patchElements "<div id=\"a\">1</div>")-        sendPatchElements gen (patchElements "<div id=\"b\">2</div>")-        sendPatchSignals gen (patchSignals "{\"count\":42}")-      withAccept enc = defaultRequest {requestHeaders = [("Accept-Encoding", enc)]}--  it "round-trips: the br stream decompresses to the uncompressed stream" $ do-    (_, reference) <- runStream (sseResponse nullLogger sendEvents)-    (headers, compressed) <--      runStream (sseResponseWith nullLogger [brotli] (withAccept "br") sendEvents)--    headers `shouldSatisfy` elem ("Content-Encoding", "br")-    B.decompress compressed `shouldBe` reference--  it "declines compression when the client does not accept br" $ do-    (_, reference) <- runStream (sseResponse nullLogger sendEvents)-    (headers, body) <--      runStream (sseResponseWith nullLogger [brotli] (withAccept "gzip") sendEvents)--    filter ((== "Content-Encoding") . fst) headers `shouldBe` []-    body `shouldBe` reference--  it "emits output incrementally on flush, not buffered until finish" $ do-    ref <- newIORef mempty-    let rawWrite c = modifyIORef' ref (<> c)-        sizeSoFar = fromIntegral . BL.length . BSB.toLazyByteString <$> readIORef ref-    (write, flush, finish) <- compressorWrap brotli rawWrite (pure ())--    write (BSB.byteString "event: datastar-patch-elements\ndata: elements <div>1</div>\n\n")-    flush-    afterFirst <- sizeSoFar--    write (BSB.byteString "event: datastar-patch-elements\ndata: elements <div>2</div>\n\n")-    flush-    afterSecond <- sizeSoFar--    finish-    afterFinish <- sizeSoFar--    -- Each flush must push bytes onto the wire; a compressor that buffered-    -- everything until finish would leave afterFirst == afterSecond == 0.-    afterFirst `shouldSatisfy` (> (0 :: Int))-    afterSecond `shouldSatisfy` (> afterFirst)-    afterFinish `shouldSatisfy` (>= afterSecond)--    -- And the accumulated stream is still a valid, complete brotli stream.-    whole <- BSB.toLazyByteString <$> readIORef ref-    B.decompress whole-      `shouldBe` "event: datastar-patch-elements\ndata: elements <div>1</div>\n\n\-                 \event: datastar-patch-elements\ndata: elements <div>2</div>\n\n"--  describe "negotiateWith" $ do-    let br = fakeCompressor "br"-        gz = fakeCompressor "gzip"-        enc = fmap compressorEncoding-        req h = defaultRequest {requestHeaders = [("Accept-Encoding", h)]}--    it "ServerPriority picks the first server compressor the client accepts" $-      enc (negotiateWith ServerPriority [br, gz] (req "gzip, br")) `shouldBe` Just "br"--    it "ClientPriority picks the client's most-preferred offered encoding" $-      enc (negotiateWith ClientPriority [br, gz] (req "gzip, br")) `shouldBe` Just "gzip"--    it "Forced ignores Accept-Encoding entirely" $-      enc (negotiateWith Forced [br, gz] (req "identity")) `shouldBe` Just "br"--    it "ignores q-value params and whitespace around each token" $-      enc (negotiateWith ClientPriority [br, gz] (req "  gzip;q=0.1 , br ")) `shouldBe` Just "gzip"--    it "returns Nothing when no server encoding is accepted" $-      enc (negotiateWith ServerPriority [br, gz] (req "deflate")) `shouldBe` Nothing--    it "returns Nothing when the Accept-Encoding header is absent" $-      enc (negotiateWith ServerPriority [br, gz] defaultRequest) `shouldBe` Nothing

@@ -1,109 +0,0 @@-module Hypermedia.Datastar.Compression.ZlibSpec (spec) where--import Test.Hspec--import Control.Monad (forM_)--import Codec.Compression.GZip qualified as GZip-import Codec.Compression.Zlib qualified as Zlib-import Data.ByteString qualified as BS-import Data.ByteString.Builder qualified as BSB-import Data.ByteString.Char8 qualified as BS8-import Data.ByteString.Lazy qualified as BL-import Data.IORef--import Network.Wai (defaultRequest, requestHeaders)-import Network.Wai.Internal (Response (..))--import Hypermedia.Datastar-import Hypermedia.Datastar.Compression.Zlib (deflate, gzip)-import Hypermedia.Datastar.Logger (nullLogger)-import Hypermedia.Datastar.WAI (compressorWrap)---- | Drive a streaming WAI response to completion, returning its response headers--- and the full raw body.-runStream (ResponseStream _status headers body) = do-  ref <- newIORef mempty-  body (\chunk -> modifyIORef' ref (<> chunk)) (pure ())-  bytes <- BSB.toLazyByteString <$> readIORef ref-  pure (headers, bytes)-runStream _ = error "expected a streaming response"--spec :: Spec-spec = describe "Hypermedia.Datastar.Compression.Zlib" $ do-  let sendEvents gen = do-        sendPatchElements gen (patchElements "<div id=\"a\">1</div>")-        sendPatchElements gen (patchElements "<div id=\"b\">2</div>")-        sendPatchSignals gen (patchSignals "{\"count\":42}")-      withAccept enc = defaultRequest {requestHeaders = [("Accept-Encoding", enc)]}--      -- (encoding token, compressor, matching decompressor)-      codecs :: [(BS.ByteString, Compressor, BL.ByteString -> BL.ByteString)]-      codecs =-        [ ("gzip", gzip, GZip.decompress)-        , ("deflate", deflate, Zlib.decompress)-        ]--  forM_ codecs $ \(enc, comp, decompress) -> do-    let name = BS8.unpack enc--    it (name <> ": round-trips to the uncompressed stream") $ do-      (_, reference) <- runStream (sseResponse nullLogger sendEvents)-      (headers, compressed) <--        runStream (sseResponseWith nullLogger [comp] (withAccept enc) sendEvents)-      headers `shouldSatisfy` elem ("Content-Encoding", enc)-      decompress compressed `shouldBe` reference--    it (name <> ": emits output incrementally on flush, not buffered until finish") $ do-      ref <- newIORef mempty-      let rawWrite c = modifyIORef' ref (<> c)-          sizeSoFar = fromIntegral . BL.length . BSB.toLazyByteString <$> readIORef ref-      (write, flush, finish) <- compressorWrap comp rawWrite (pure ())--      write (BSB.byteString "event: datastar-patch-elements\ndata: elements <div>1</div>\n\n")-      flush-      afterFirst <- sizeSoFar--      write (BSB.byteString "event: datastar-patch-elements\ndata: elements <div>2</div>\n\n")-      flush-      afterSecond <- sizeSoFar--      finish-      afterFinish <- sizeSoFar--      -- Each flush must push bytes onto the wire; a compressor that buffered-      -- everything until finish would leave afterFirst == afterSecond == 0.-      afterFirst `shouldSatisfy` (> (0 :: Int))-      afterSecond `shouldSatisfy` (> afterFirst)-      afterFinish `shouldSatisfy` (>= afterSecond)--      -- And the accumulated stream is still a valid, complete stream.-      whole <- BSB.toLazyByteString <$> readIORef ref-      decompress whole-        `shouldBe` "event: datastar-patch-elements\ndata: elements <div>1</div>\n\n\-                   \event: datastar-patch-elements\ndata: elements <div>2</div>\n\n"--  it "declines when the client accepts neither" $ do-    (_, reference) <- runStream (sseResponse nullLogger sendEvents)-    (headers, body) <--      runStream (sseResponseWith nullLogger [gzip, deflate] (withAccept "br") sendEvents)-    filter ((== "Content-Encoding") . fst) headers `shouldBe` []-    body `shouldBe` reference--  -- With several server compressors offered and a client that accepts all of-  -- them, ServerPriority (the default for sseResponseWith) picks the *server's*-  -- first — so list order, not header order, decides. Verified end-to-end via-  -- the chosen Content-Encoding and that the matching codec decompresses it.-  it "picks the server's first compressor when the client accepts several (gzip first)" $ do-    (_, reference) <- runStream (sseResponse nullLogger sendEvents)-    (headers, compressed) <--      runStream (sseResponseWith nullLogger [gzip, deflate] (withAccept "deflate, gzip") sendEvents)-    headers `shouldSatisfy` elem ("Content-Encoding", "gzip")-    GZip.decompress compressed `shouldBe` reference--  it "picks the server's first compressor when the client accepts several (deflate first)" $ do-    (_, reference) <- runStream (sseResponse nullLogger sendEvents)-    (headers, compressed) <--      runStream (sseResponseWith nullLogger [deflate, gzip] (withAccept "deflate, gzip") sendEvents)-    headers `shouldSatisfy` elem ("Content-Encoding", "deflate")-    Zlib.decompress compressed `shouldBe` reference

@@ -1,83 +0,0 @@-module Hypermedia.Datastar.Compression.ZstdSpec (spec) where--import Test.Hspec--import Codec.Compression.Zstd.Lazy qualified as Zstd-import Data.ByteString.Builder qualified as BSB-import Data.ByteString.Lazy qualified as BL-import Data.IORef--import Network.Wai (defaultRequest, requestHeaders)-import Network.Wai.Internal (Response (..))--import Hypermedia.Datastar-import Hypermedia.Datastar.Compression.Zlib (gzip)-import Hypermedia.Datastar.Compression.Zstd (zstd)-import Hypermedia.Datastar.Logger (nullLogger)-import Hypermedia.Datastar.WAI (compressorWrap)---- | Drive a streaming WAI response to completion, returning its response headers--- and the full raw body.-runStream (ResponseStream _status headers body) = do-  ref <- newIORef mempty-  body (\chunk -> modifyIORef' ref (<> chunk)) (pure ())-  bytes <- BSB.toLazyByteString <$> readIORef ref-  pure (headers, bytes)-runStream _ = error "expected a streaming response"--spec :: Spec-spec = describe "Hypermedia.Datastar.Compression.Zstd" $ do-  let sendEvents gen = do-        sendPatchElements gen (patchElements "<div id=\"a\">1</div>")-        sendPatchElements gen (patchElements "<div id=\"b\">2</div>")-        sendPatchSignals gen (patchSignals "{\"count\":42}")-      withAccept enc = defaultRequest {requestHeaders = [("Accept-Encoding", enc)]}--  it "round-trips to the uncompressed stream" $ do-    (_, reference) <- runStream (sseResponse nullLogger sendEvents)-    (headers, compressed) <--      runStream (sseResponseWith nullLogger [zstd] (withAccept "zstd") sendEvents)-    headers `shouldSatisfy` elem ("Content-Encoding", "zstd")-    Zstd.decompress compressed `shouldBe` reference--  it "declines when the client does not accept zstd" $ do-    (_, reference) <- runStream (sseResponse nullLogger sendEvents)-    (headers, body) <--      runStream (sseResponseWith nullLogger [zstd] (withAccept "gzip") sendEvents)-    filter ((== "Content-Encoding") . fst) headers `shouldBe` []-    body `shouldBe` reference--  it "is chosen ahead of gzip when offered first and both are accepted" $ do-    (_, reference) <- runStream (sseResponse nullLogger sendEvents)-    (headers, compressed) <--      runStream (sseResponseWith nullLogger [zstd, gzip] (withAccept "gzip, zstd") sendEvents)-    headers `shouldSatisfy` elem ("Content-Encoding", "zstd")-    Zstd.decompress compressed `shouldBe` reference--  it "emits output incrementally on flush, not buffered until finish" $ do-    ref <- newIORef mempty-    let rawWrite c = modifyIORef' ref (<> c)-        sizeSoFar = fromIntegral . BL.length . BSB.toLazyByteString <$> readIORef ref-    (write, flush, finish) <- compressorWrap zstd rawWrite (pure ())--    write (BSB.byteString "event: datastar-patch-elements\ndata: elements <div>1</div>\n\n")-    flush-    afterFirst <- sizeSoFar--    write (BSB.byteString "event: datastar-patch-elements\ndata: elements <div>2</div>\n\n")-    flush-    afterSecond <- sizeSoFar--    finish-    afterFinish <- sizeSoFar--    -- Each flush must push bytes onto the wire; a compressor that buffered-    -- everything until finish would leave afterFirst == afterSecond == 0.-    afterFirst `shouldSatisfy` (> (0 :: Int))-    afterSecond `shouldSatisfy` (> afterFirst)-    afterFinish `shouldSatisfy` (>= afterSecond)--    whole <- BSB.toLazyByteString <$> readIORef ref-    Zstd.decompress whole-      `shouldBe` "event: datastar-patch-elements\ndata: elements <div>1</div>\n\n\-                 \event: datastar-patch-elements\ndata: elements <div>2</div>\n\n"

@@ -0,0 +1,41 @@+module Hypermedia.Datastar.NegotiationSpec (spec) where++import Test.Hspec++import Data.ByteString.Lazy qualified as BL++import Network.Wai (defaultRequest, requestHeaders)++import Hypermedia.Datastar+import Hypermedia.Datastar.WAI (Compressor (..), negotiateWith)++{- | A compressor that only carries an encoding token, for negotiation tests.+Its 'compressorWrap' is never invoked by 'negotiateWith'.+-}+fakeCompressor :: BL.ByteString -> Compressor+fakeCompressor enc = Compressor (BL.toStrict enc) (\_ _ -> error "unused")++spec :: Spec+spec = describe "negotiateWith" $ do+  let br = fakeCompressor "br"+      gz = fakeCompressor "gzip"+      enc = fmap compressorEncoding+      req h = defaultRequest{requestHeaders = [("Accept-Encoding", h)]}++  it "ServerPriority picks the first server compressor the client accepts" $+    enc (negotiateWith ServerPriority [br, gz] (req "gzip, br")) `shouldBe` Just "br"++  it "ClientPriority picks the client's most-preferred offered encoding" $+    enc (negotiateWith ClientPriority [br, gz] (req "gzip, br")) `shouldBe` Just "gzip"++  it "Forced ignores Accept-Encoding entirely" $+    enc (negotiateWith Forced [br, gz] (req "identity")) `shouldBe` Just "br"++  it "ignores q-value params and whitespace around each token" $+    enc (negotiateWith ClientPriority [br, gz] (req "  gzip;q=0.1 , br ")) `shouldBe` Just "gzip"++  it "returns Nothing when no server encoding is accepted" $+    enc (negotiateWith ServerPriority [br, gz] (req "deflate")) `shouldBe` Nothing++  it "returns Nothing when the Accept-Encoding header is absent" $+    enc (negotiateWith ServerPriority [br, gz] defaultRequest) `shouldBe` Nothing

@@ -82,22 +82,22 @@                  ]    it "omits namespace when html (default)" $ do-    let lines =+    let lines' =           dataLines $             toDatastarEvent $               patchElements "<p>hello</p>" -    any (T.isPrefixOf "namespace") lines `shouldBe` False+    any (T.isPrefixOf "namespace") lines' `shouldBe` False    it "omits mode when Outer (default)" $ do     let pe = patchElements "<p>hello</p>"         event = toDatastarEvent pe-        lines = dataLines event-    any (T.isPrefixOf "mode") lines `shouldBe` False+        lines' = dataLines event+    any (T.isPrefixOf "mode") lines' `shouldBe` False    it "politely ignores empty element strings" $ do-    let lines =+    let lines' =           dataLines $             toDatastarEvent $               patchElements ""-    lines `shouldBe` []+    lines' `shouldBe` []

@@ -9,9 +9,6 @@ import Data.List (isInfixOf)  import Hypermedia.Datastar-import Hypermedia.Datastar.Logger (nullLogger)-import Hypermedia.Datastar.PatchElements-import Hypermedia.Datastar.PatchSignals import Hypermedia.Datastar.Types import Hypermedia.Datastar.WAI (renderEvent) import Network.Wai.Internal (Response (..))

@@ -1,27 +1,17 @@-{-# LANGUAGE CPP #-}- module Main where  import Test.Hspec -import Hypermedia.Datastar.Compression.BrotliSpec qualified-import Hypermedia.Datastar.Compression.ZlibSpec qualified-#ifdef ZSTD-import Hypermedia.Datastar.Compression.ZstdSpec qualified-#endif import Hypermedia.Datastar.ExecuteScriptSpec qualified+import Hypermedia.Datastar.NegotiationSpec qualified import Hypermedia.Datastar.PatchElementsSpec qualified import Hypermedia.Datastar.PatchSignalsSpec qualified import Hypermedia.Datastar.SSESpec qualified  main :: IO () main = hspec $ do-  Hypermedia.Datastar.Compression.BrotliSpec.spec-  Hypermedia.Datastar.Compression.ZlibSpec.spec-#ifdef ZSTD-  Hypermedia.Datastar.Compression.ZstdSpec.spec-#endif   Hypermedia.Datastar.ExecuteScriptSpec.spec+  Hypermedia.Datastar.NegotiationSpec.spec   Hypermedia.Datastar.PatchElementsSpec.spec   Hypermedia.Datastar.PatchSignalsSpec.spec   Hypermedia.Datastar.SSESpec.spec