datastar-hs 1.0.1.0 → 1.0.1.1
raw patch · 17 files changed
+1002/−1029 lines, 17 filesdep ~aesondep ~bytestringdep ~http-types
Dependency ranges changed: aeson, bytestring, http-types, text, wai
Files
- CHANGELOG.md +4/−1
- datastar-hs.cabal +73/−51
- examples/Examples/ActivityFeed.hs +0/−152
- examples/Examples/HeapView.hs +0/−564
- examples/Examples/HelloWorldChannel.hs +0/−95
- examples/Examples/HelloWorldServant.hs +0/−77
- examples/Examples/HelloWorldWarp.hs +0/−59
- examples/activity-feed.hs +148/−0
- examples/exe/activity-feed.hs +0/−6
- examples/exe/heap-view.hs +0/−6
- examples/exe/hello-world-channel.hs +0/−6
- examples/exe/hello-world-servant.hs +0/−6
- examples/exe/hello-world-warp.hs +0/−6
- examples/heap-view.hs +558/−0
- examples/hello-world-channel.hs +92/−0
- examples/hello-world-servant.hs +71/−0
- examples/hello-world-warp.hs +56/−0
CHANGELOG.md view
@@ -1,9 +1,12 @@ # Changelog +## 1.0.1.1++* Revert experimental `examples` sub-library introduced in 1.0.1.0 — it broke Hackage doc uploads. Examples remain in the repo as runnable executables.+ ## 1.0.1.0 * Add `Hypermedia.Datastar.Attributes` with typed helpers for Datastar `data-*` attributes-* Refactor examples so they appear in Haddock docs ## 1.0.0.0
datastar-hs.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: datastar-hs-version: 1.0.1.0+version: 1.0.1.1 synopsis: Haskell bindings for Datastar description: Server-side SDK for building real-time hypermedia applications with@@ -45,41 +45,6 @@ , text >= 1.2 && < 3 , wai >= 3.2 && < 4 -library examples- visibility: public- hs-source-dirs: examples- exposed-modules:- Examples.ActivityFeed- Examples.HeapView- Examples.HelloWorldChannel- Examples.HelloWorldServant- Examples.HelloWorldWarp- default-language: Haskell2010- default-extensions:- ImportQualifiedPost- OverloadedStrings- -- heap-view relies on -O0 so each call to mkSimpleExpr/mkMapExpr/mkFibsExpr- -- allocates fresh thunks instead of being floated to a CAF. The other- -- examples are fine at -O0 too.- ghc-options: -O0- build-depends:- , base >= 4.14 && < 5- , aeson >= 2.0 && < 3- , bytestring >= 0.10 && < 1- , containers >= 0.6 && < 1- , datastar-hs- , ghc-heap >= 9.0 && < 10- , http-media >= 0.8 && < 1- , http-types >= 0.12 && < 1- , servant-server >= 0.19 && < 1- , stm >= 2.4 && < 3- , tagged >= 0.8 && < 1- , text >= 1.2 && < 3- , time >= 1.9 && < 2- , uuid >= 1.3 && < 2- , wai >= 3.2 && < 4- , warp >= 3.2 && < 4- executable e2e-server hs-source-dirs: e2e-server main-is: Main.hs@@ -126,46 +91,103 @@ OverloadedStrings executable hello-world-warp- main-is: hello-world-warp.hs- hs-source-dirs: examples/exe+ main-is: hello-world-warp.hs+ hs-source-dirs: examples default-language: Haskell2010+ default-extensions:+ ImportQualifiedPost+ OverloadedStrings build-depends: , base >= 4.7- , datastar-hs:examples+ , aeson+ , bytestring+ , http-types+ , text+ , wai+ , warp >= 3.2 && < 4+ , datastar-hs ghc-options: -threaded executable hello-world-servant- main-is: hello-world-servant.hs- hs-source-dirs: examples/exe+ 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- , datastar-hs:examples+ , aeson+ , bytestring+ , http-media >= 0.8 && < 1+ , http-types+ , servant-server >= 0.19 && < 1+ , tagged >= 0.8 && < 1+ , text+ , wai+ , warp >= 3.2 && < 4+ , datastar-hs ghc-options: -threaded executable hello-world-channel- main-is: hello-world-channel.hs- hs-source-dirs: examples/exe+ main-is: hello-world-channel.hs+ hs-source-dirs: examples default-language: Haskell2010+ default-extensions:+ ImportQualifiedPost+ OverloadedStrings build-depends: , base >= 4.7- , datastar-hs:examples+ , aeson+ , bytestring+ , http-types+ , stm >= 2.4 && < 3+ , text+ , wai+ , warp >= 3.2 && < 4+ , datastar-hs ghc-options: -threaded executable activity-feed- main-is: activity-feed.hs- hs-source-dirs: examples/exe+ main-is: activity-feed.hs+ hs-source-dirs: examples default-language: Haskell2010+ default-extensions:+ ImportQualifiedPost+ OverloadedStrings build-depends: , base >= 4.7- , datastar-hs:examples+ , aeson+ , bytestring+ , text+ , time >= 1.9 && < 2+ , http-types+ , wai+ , warp >= 3.2 && < 4+ , datastar-hs ghc-options: -threaded executable heap-view- main-is: heap-view.hs- hs-source-dirs: examples/exe+ main-is: heap-view.hs+ hs-source-dirs: examples default-language: Haskell2010+ default-extensions:+ ImportQualifiedPost+ OverloadedStrings+ ScopedTypeVariables build-depends: , base >= 4.7- , datastar-hs:examples+ , 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
− examples/Examples/ActivityFeed.hs
@@ -1,152 +0,0 @@--- | A multi-event activity feed: clients can post 'done'/'warn'/'fail'/'info'--- entries or kick off a generator that streams entries on an interval, all--- reflected back to every connected client via Datastar signal and element--- patches.-module Examples.ActivityFeed (runExample, app, Signals (..), Status (..)) 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 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>"--runExample :: IO ()-runExample = 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"--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 $ sseResponse nullLogger $ \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 $ sseResponse nullLogger $ \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}
− examples/Examples/HeapView.hs
@@ -1,564 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-{- HLINT ignore "Use head" -}-{- HLINT ignore "Use void" -}---- | A live visualizer of the GHC runtime heap: walks the heap from a chosen--- root expression, renders the nodes as an HTML table, and lets the user--- force individual thunks. Relies on @-O0@ so each example expression--- allocates fresh thunks instead of being floated to a CAF.-module Examples.HeapView (runExample, app, AppState (..), Mode (..), Session (..), allModes) 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 (Set)-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 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>"- <> " · Root: <code class='text-gray-600 dark:text-gray-400'>"- <> cleanAddr rootAddr- <> "</code>"- <> " · "- <> 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--runExample :: IO ()-runExample = 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 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 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)--handleHeap :: AppState -> Session -> (Response -> IO b) -> IO b-handleHeap appState sess respond =- respond $ sseResponse nullLogger $ \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 $ sseResponse nullLogger $ \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 $ sseResponse nullLogger $ \gen ->- sendHeapUpdate appState sess gen--handleRun :: AppState -> Session -> (Response -> IO b) -> IO b-handleRun appState sess respond = do- case modeRun (appMode appState) of- Just run -> do- run sess- respond $ sseResponse nullLogger $ \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"
− examples/Examples/HelloWorldChannel.hs
@@ -1,95 +0,0 @@--- | "Hello, world!" SSE animation where the delay is shared state held in a--- 'Control.Concurrent.STM.TVar'. Clicking Start bumps a version counter, which--- interrupts the in-flight animation so it restarts from the beginning.-module Examples.HelloWorldChannel (runExample, app, SharedState (..), Signals (..)) 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 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!"--runExample :: IO ()-runExample = 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 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 $ sseResponse nullLogger $ \_ -> pure ()--handleHelloWorld :: SharedState -> (Wai.Response -> IO b) -> IO b-handleHelloWorld state respond =- respond $ sseResponse nullLogger $ \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
− examples/Examples/HelloWorldServant.hs
@@ -1,77 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeOperators #-}---- | The same "Hello, world!" SSE animation as 'Examples.HelloWorldWarp', but--- served through a Servant API.-module Examples.HelloWorldServant (runExample, app, API, Signals (..), HTML) 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 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!"--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 $ sseResponse nullLogger $ \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)--runExample :: IO ()-runExample = 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)
− examples/Examples/HelloWorldWarp.hs
@@ -1,59 +0,0 @@--- | A minimal Datastar example using Warp directly: streams a "Hello, world!"--- message one character at a time over SSE, with the delay controlled by a--- client-side signal.-module Examples.HelloWorldWarp (runExample, app, Signals (..)) 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 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}--instance FromJSON Signals where- parseJSON = withObject "Signals" $ \o ->- Signals <$> o .: "delay"--message :: String-message = "Hello, world!"--runExample :: IO ()-runExample = 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 $ sseResponse nullLogger $ \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]
+ examples/activity-feed.hs view
@@ -0,0 +1,148 @@+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 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"++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 $ sseResponse nullLogger $ \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 $ sseResponse nullLogger $ \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}
− examples/exe/activity-feed.hs
@@ -1,6 +0,0 @@-module Main (main) where--import Examples.ActivityFeed (runExample)--main :: IO ()-main = runExample
− examples/exe/heap-view.hs
@@ -1,6 +0,0 @@-module Main (main) where--import Examples.HeapView (runExample)--main :: IO ()-main = runExample
− examples/exe/hello-world-channel.hs
@@ -1,6 +0,0 @@-module Main (main) where--import Examples.HelloWorldChannel (runExample)--main :: IO ()-main = runExample
− examples/exe/hello-world-servant.hs
@@ -1,6 +0,0 @@-module Main (main) where--import Examples.HelloWorldServant (runExample)--main :: IO ()-main = runExample
− examples/exe/hello-world-warp.hs
@@ -1,6 +0,0 @@-module Main (main) where--import Examples.HelloWorldWarp (runExample)--main :: IO ()-main = runExample
+ examples/heap-view.hs view
@@ -0,0 +1,558 @@+{- 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 (Set)+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 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>"+ <> " · Root: <code class='text-gray-600 dark:text-gray-400'>"+ <> cleanAddr rootAddr+ <> "</code>"+ <> " · "+ <> 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 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 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)++handleHeap :: AppState -> Session -> (Response -> IO b) -> IO b+handleHeap appState sess respond =+ respond $ sseResponse nullLogger $ \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 $ sseResponse nullLogger $ \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 $ sseResponse nullLogger $ \gen ->+ sendHeapUpdate appState sess gen++handleRun :: AppState -> Session -> (Response -> IO b) -> IO b+handleRun appState sess respond = do+ case modeRun (appMode appState) of+ Just run -> do+ run sess+ respond $ sseResponse nullLogger $ \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"
+ examples/hello-world-channel.hs view
@@ -0,0 +1,92 @@+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 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!"++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 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 $ sseResponse nullLogger $ \_ -> pure ()++handleHelloWorld :: SharedState -> (Wai.Response -> IO b) -> IO b+handleHelloWorld state respond =+ respond $ sseResponse nullLogger $ \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
+ examples/hello-world-servant.hs view
@@ -0,0 +1,71 @@+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 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!"++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 $ sseResponse nullLogger $ \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)
+ examples/hello-world-warp.hs view
@@ -0,0 +1,56 @@+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 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}++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 $ sseResponse nullLogger $ \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]