"
- <> timestamp
- <> " [ "
- <> indicator
- <> " ] "
- <> source
- <> " event "
- <> T.pack (show index)
- <> "
"
-
-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}
diff --git a/examples/Examples/HeapView.hs b/examples/Examples/HeapView.hs
deleted file mode 100644
--- a/examples/Examples/HeapView.hs
+++ /dev/null
@@ -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 =
- ""
- <> "
"
- <> "
GHC Heap Visualizer
"
- <> "
"
- <> runButton
- <> ""
- <> ""
- <> ""
- <> "
"
- <> "
Expression: "
- <> exprDesc
- <> ""
- <> " · Root: "
- <> cleanAddr rootAddr
- <> ""
- <> " · "
- <> T.pack (show (Map.size nodes))
- <> " nodes
"
- <> "
"
- <> "
"
- <> ""
- <> "| Address | "
- <> "Type | "
- <> "Value | "
- <> "Pointers | "
- <> "Actions | "
- <> "
"
- <> mconcat (map renderRow orderedNodes)
- <> "
highlight
- <> ">"
- <> "| "
- <> ca
- <> (if isRoot then " (root)" else "")
- <> " | "
- <> ""
- <> typeBadge (nodeType node)
- <> " | "
- <> ""
- <> maybe "-" (\v -> "" <> v <> "") (nodeValue node)
- <> " | "
- <> ""
- <> renderPointers (nodePointers node)
- <> " | "
- <> ""
- <> renderActions addr node
- <> " | "
- <> "
"
-
- 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 =
- " [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"
diff --git a/examples/Examples/HelloWorldChannel.hs b/examples/Examples/HelloWorldChannel.hs
deleted file mode 100644
--- a/examples/Examples/HelloWorldChannel.hs
+++ /dev/null
@@ -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 = "" <> T.pack (take i message) <> "
"
- 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
diff --git a/examples/Examples/HelloWorldServant.hs b/examples/Examples/HelloWorldServant.hs
deleted file mode 100644
--- a/examples/Examples/HelloWorldServant.hs
+++ /dev/null
@@ -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 = "" <> T.pack (take i message) <> "
"
- 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)
diff --git a/examples/Examples/HelloWorldWarp.hs b/examples/Examples/HelloWorldWarp.hs
deleted file mode 100644
--- a/examples/Examples/HelloWorldWarp.hs
+++ /dev/null
@@ -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 = "" <> T.pack (take i message) <> "
"
- sendPatchElements gen (patchElements html)
- threadDelay (delay signals * 1000)
- )
- [1 .. length message]
diff --git a/examples/activity-feed.hs b/examples/activity-feed.hs
new file mode 100644
--- /dev/null
+++ b/examples/activity-feed.hs
@@ -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 $
+ ""
+ <> timestamp
+ <> " [ "
+ <> indicator
+ <> " ] "
+ <> source
+ <> " event "
+ <> T.pack (show index)
+ <> "
"
+
+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}
diff --git a/examples/exe/activity-feed.hs b/examples/exe/activity-feed.hs
deleted file mode 100644
--- a/examples/exe/activity-feed.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-module Main (main) where
-
-import Examples.ActivityFeed (runExample)
-
-main :: IO ()
-main = runExample
diff --git a/examples/exe/heap-view.hs b/examples/exe/heap-view.hs
deleted file mode 100644
--- a/examples/exe/heap-view.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-module Main (main) where
-
-import Examples.HeapView (runExample)
-
-main :: IO ()
-main = runExample
diff --git a/examples/exe/hello-world-channel.hs b/examples/exe/hello-world-channel.hs
deleted file mode 100644
--- a/examples/exe/hello-world-channel.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-module Main (main) where
-
-import Examples.HelloWorldChannel (runExample)
-
-main :: IO ()
-main = runExample
diff --git a/examples/exe/hello-world-servant.hs b/examples/exe/hello-world-servant.hs
deleted file mode 100644
--- a/examples/exe/hello-world-servant.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-module Main (main) where
-
-import Examples.HelloWorldServant (runExample)
-
-main :: IO ()
-main = runExample
diff --git a/examples/exe/hello-world-warp.hs b/examples/exe/hello-world-warp.hs
deleted file mode 100644
--- a/examples/exe/hello-world-warp.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-module Main (main) where
-
-import Examples.HelloWorldWarp (runExample)
-
-main :: IO ()
-main = runExample
diff --git a/examples/heap-view.hs b/examples/heap-view.hs
new file mode 100644
--- /dev/null
+++ b/examples/heap-view.hs
@@ -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 =
+ ""
+ <> "
"
+ <> "
GHC Heap Visualizer
"
+ <> "
"
+ <> runButton
+ <> ""
+ <> ""
+ <> ""
+ <> "
"
+ <> "
Expression: "
+ <> exprDesc
+ <> ""
+ <> " · Root: "
+ <> cleanAddr rootAddr
+ <> ""
+ <> " · "
+ <> T.pack (show (Map.size nodes))
+ <> " nodes
"
+ <> "
"
+ <> "
"
+ <> ""
+ <> "| Address | "
+ <> "Type | "
+ <> "Value | "
+ <> "Pointers | "
+ <> "Actions | "
+ <> "
"
+ <> mconcat (map renderRow orderedNodes)
+ <> "
highlight
+ <> ">"
+ <> "| "
+ <> ca
+ <> (if isRoot then " (root)" else "")
+ <> " | "
+ <> ""
+ <> typeBadge (nodeType node)
+ <> " | "
+ <> ""
+ <> maybe "-" (\v -> "" <> v <> "") (nodeValue node)
+ <> " | "
+ <> ""
+ <> renderPointers (nodePointers node)
+ <> " | "
+ <> ""
+ <> renderActions addr node
+ <> " | "
+ <> "
"
+
+ 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 =
+ ""
+ <> label
+ <> ""
+
+ renderPointers [] = "-"
+ renderPointers ptrs = T.intercalate " " (map renderPtr ptrs)
+
+ renderPtr p =
+ let cp = cleanAddr p
+ in " " data-on:mouseenter=\"$highlight = '"
+ <> cp
+ <> "'\""
+ <> " data-on:mouseleave=\"$highlight = ''\""
+ <> " class='text-cyan-700 dark:text-cyan-600 hover:underline cursor-pointer'>"
+ <> cp
+ <> ""
+
+ renderActions addr node
+ | nodeType node == "thunk" || nodeType node == "ap" || nodeType node == "selector" =
+ ""
+ | 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 [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"
diff --git a/examples/hello-world-channel.hs b/examples/hello-world-channel.hs
new file mode 100644
--- /dev/null
+++ b/examples/hello-world-channel.hs
@@ -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 = "" <> T.pack (take i message) <> "
"
+ 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
diff --git a/examples/hello-world-servant.hs b/examples/hello-world-servant.hs
new file mode 100644
--- /dev/null
+++ b/examples/hello-world-servant.hs
@@ -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 = "" <> T.pack (take i message) <> "
"
+ 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)
diff --git a/examples/hello-world-warp.hs b/examples/hello-world-warp.hs
new file mode 100644
--- /dev/null
+++ b/examples/hello-world-warp.hs
@@ -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 = "" <> T.pack (take i message) <> "
"
+ sendPatchElements gen (patchElements html)
+ threadDelay (delay signals * 1000)
+ )
+ [1 .. length message]