datastar-hs 1.0.0.0 → 1.0.1.0
raw patch · 18 files changed
+1524/−998 lines, 18 filesdep ~aesondep ~bytestringdep ~http-types
Dependency ranges changed: aeson, bytestring, http-types, text, wai
Files
- CHANGELOG.md +5/−0
- datastar-hs.cabal +52/−73
- examples/Examples/ActivityFeed.hs +152/−0
- examples/Examples/HeapView.hs +564/−0
- examples/Examples/HelloWorldChannel.hs +95/−0
- examples/Examples/HelloWorldServant.hs +77/−0
- examples/Examples/HelloWorldWarp.hs +59/−0
- examples/activity-feed.hs +0/−148
- examples/exe/activity-feed.hs +6/−0
- examples/exe/heap-view.hs +6/−0
- examples/exe/hello-world-channel.hs +6/−0
- examples/exe/hello-world-servant.hs +6/−0
- examples/exe/hello-world-warp.hs +6/−0
- examples/heap-view.hs +0/−558
- examples/hello-world-channel.hs +0/−92
- examples/hello-world-servant.hs +0/−71
- examples/hello-world-warp.hs +0/−56
- src/Hypermedia/Datastar/Attributes.hs +490/−0
CHANGELOG.md view
@@ -1,5 +1,10 @@ # Changelog +## 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 * Bump to Datastar 1.0.0
datastar-hs.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: datastar-hs-version: 1.0.0.0+version: 1.0.1.0 synopsis: Haskell bindings for Datastar description: Server-side SDK for building real-time hypermedia applications with@@ -25,6 +25,7 @@ library exposed-modules: Hypermedia.Datastar+ Hypermedia.Datastar.Attributes Hypermedia.Datastar.ExecuteScript Hypermedia.Datastar.Logger Hypermedia.Datastar.PatchElements@@ -44,6 +45,41 @@ , 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@@ -90,103 +126,46 @@ OverloadedStrings executable hello-world-warp- main-is: hello-world-warp.hs- hs-source-dirs: examples+ main-is: hello-world-warp.hs+ hs-source-dirs: examples/exe default-language: Haskell2010- default-extensions:- ImportQualifiedPost- OverloadedStrings build-depends: , base >= 4.7- , aeson- , bytestring- , http-types- , text- , wai- , warp >= 3.2 && < 4- , datastar-hs+ , datastar-hs:examples ghc-options: -threaded executable hello-world-servant- main-is: hello-world-servant.hs- hs-source-dirs: examples+ main-is: hello-world-servant.hs+ hs-source-dirs: examples/exe default-language: Haskell2010- default-extensions:- DataKinds- ImportQualifiedPost- MultiParamTypeClasses- OverloadedStrings- TypeOperators build-depends: , base >= 4.7- , aeson- , bytestring- , http-media >= 0.8 && < 1- , http-types- , servant-server >= 0.19 && < 1- , tagged >= 0.8 && < 1- , text- , wai- , warp >= 3.2 && < 4- , datastar-hs+ , datastar-hs:examples ghc-options: -threaded executable hello-world-channel- main-is: hello-world-channel.hs- hs-source-dirs: examples+ main-is: hello-world-channel.hs+ hs-source-dirs: examples/exe default-language: Haskell2010- default-extensions:- ImportQualifiedPost- OverloadedStrings build-depends: , base >= 4.7- , aeson- , bytestring- , http-types- , stm >= 2.4 && < 3- , text- , wai- , warp >= 3.2 && < 4- , datastar-hs+ , datastar-hs:examples ghc-options: -threaded executable activity-feed- main-is: activity-feed.hs- hs-source-dirs: examples+ main-is: activity-feed.hs+ hs-source-dirs: examples/exe default-language: Haskell2010- default-extensions:- ImportQualifiedPost- OverloadedStrings build-depends: , base >= 4.7- , aeson- , bytestring- , text- , time >= 1.9 && < 2- , http-types- , wai- , warp >= 3.2 && < 4- , datastar-hs+ , datastar-hs:examples ghc-options: -threaded executable heap-view- main-is: heap-view.hs- hs-source-dirs: examples+ main-is: heap-view.hs+ hs-source-dirs: examples/exe default-language: Haskell2010- default-extensions:- ImportQualifiedPost- OverloadedStrings- ScopedTypeVariables build-depends: , base >= 4.7- , bytestring- , containers >= 0.6 && < 1- , ghc-heap >= 9.0 && < 10- , http-types- , stm >= 2.4 && < 3- , text- , uuid >= 1.3 && < 2- , wai- , warp >= 3.2 && < 4- , datastar-hs+ , datastar-hs:examples ghc-options: -threaded -O0
+ examples/Examples/ActivityFeed.hs view
@@ -0,0 +1,152 @@+-- | 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 view
@@ -0,0 +1,564 @@+{-# 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 view
@@ -0,0 +1,95 @@+-- | "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 view
@@ -0,0 +1,77 @@+{-# 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 view
@@ -0,0 +1,59 @@+-- | 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
@@ -1,148 +0,0 @@-module Main (main) where--import Control.Concurrent (threadDelay)-import Data.Aeson (FromJSON (..), withObject, (.:))-import Data.ByteString qualified as BS-import Data.ByteString.Char8 qualified as BS8-import Data.ByteString.Lazy qualified as LBS-import Data.Text (Text)-import Data.Text qualified as T-import Data.Time.Clock (getCurrentTime)-import Data.Time.Format (defaultTimeLocale, formatTime)-import Hypermedia.Datastar-import 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 view
@@ -0,0 +1,6 @@+module Main (main) where++import Examples.ActivityFeed (runExample)++main :: IO ()+main = runExample
+ examples/exe/heap-view.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import Examples.HeapView (runExample)++main :: IO ()+main = runExample
+ examples/exe/hello-world-channel.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import Examples.HelloWorldChannel (runExample)++main :: IO ()+main = runExample
+ examples/exe/hello-world-servant.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import Examples.HelloWorldServant (runExample)++main :: IO ()+main = runExample
+ examples/exe/hello-world-warp.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import Examples.HelloWorldWarp (runExample)++main :: IO ()+main = runExample
− examples/heap-view.hs
@@ -1,558 +0,0 @@-{- HLINT ignore "Use head" -}-{- HLINT ignore "Use void" -}-module Main (main) where--import Control.Concurrent (forkIO, threadDelay)-import Control.Concurrent.STM (TVar, atomically, modifyTVar', newTVarIO, readTVarIO, writeTVar)-import Control.Exception (SomeException, catch, evaluate)-import Control.Monad (replicateM_)-import Data.ByteString qualified as BS-import Data.ByteString.Lazy qualified as LBS-import Data.Map.Strict (Map)-import Data.Map.Strict qualified as Map-import Data.Set (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 (* 2) [1 .. 10]-{-# 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 (*2) [1..10]"- , modeSetup = \sess -> do- let expr = mkMapExpr ()- atomically $ do- writeTVar (sessExpression sess) (asBox expr)- writeTVar (sessExprDesc sess) "map (*2) [1..10]"- , modeRun = Just $ \sess -> do- let expr = mkMapExpr ()- atomically $ do- writeTVar (sessExpression sess) (asBox expr)- writeTVar (sessExprDesc sess) "map (*2) [1..10]"- _ <- 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
@@ -1,92 +0,0 @@-module Main (main) where--import Control.Concurrent.STM (TVar, atomically, newTVarIO, readTVar, readTVarIO, registerDelay, retry, writeTVar)-import Control.Monad (forever)-import Data.Aeson (FromJSON (..), withObject, (.:))-import Data.ByteString qualified as BS-import Data.ByteString.Lazy qualified as LBS-import Data.Text qualified as T-import Hypermedia.Datastar-import 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
@@ -1,71 +0,0 @@-module Main (main) where--import Control.Concurrent (threadDelay)-import Data.Aeson (FromJSON (..), withObject, (.:))-import Data.ByteString qualified as BS-import Data.ByteString.Lazy qualified as LBS-import Data.Text qualified as T-import Hypermedia.Datastar-import 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
@@ -1,56 +0,0 @@-module Main (main) where--import Control.Concurrent (threadDelay)-import Data.Aeson (FromJSON (..), withObject, (.:))-import Data.ByteString qualified as BS-import Data.ByteString.Lazy qualified as LBS-import Data.Text qualified as T-import Hypermedia.Datastar-import 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]
+ src/Hypermedia/Datastar/Attributes.hs view
@@ -0,0 +1,490 @@+-- | Smart constructors and modifier combinators for Datastar HTML attributes.+--+-- Every Datastar attribute is a @(name, value)@ pair — the value of the+-- 'Attribute' type alias. Pair it with whatever HTML library you use:+--+-- > -- lucid2:+-- > button_ [ uncurry makeAttributes (onClick "$count++") ] "Inc"+--+-- Modifiers (the @__suffix@ parts of an attribute name) are plain+-- @Attribute -> Attribute@ functions you compose with '(.)' or '(&)':+--+-- > import Data.Function ((&))+-- > onInput "@get('/search')"+-- > & debounce 200+-- > & prevent+-- > -- => ("data-on:input__debounce.200ms__prevent", "@get('/search')")+--+-- For an event the library doesn't have a shortcut for, 'dataOn' takes any+-- 'Text':+--+-- > dataOn "my-custom-event" "..."+module Hypermedia.Datastar.Attributes+ ( -- * The attribute pair+ Attribute++ -- * Event handlers+ , dataOn+ -- ** Common event shortcuts+ , onClick+ , onSubmit+ , onInput+ , onChange+ , onFocus+ , onBlur+ , onKeyDown+ , onKeyUp+ , onKeyPress+ , onMouseDown+ , onMouseUp+ , onMouseMove+ , onMouseEnter+ , onMouseLeave+ , onMouseOver+ , onMouseOut+ , onWheel+ , onScroll+ , onResize+ , onContextMenu+ , onTouchStart+ , onTouchEnd+ , onTouchMove+ , onDragStart+ , onDragEnd+ , onDrop+ , onCopy+ , onCut+ , onPaste+ , onLoad+ , onAnimationStart+ , onAnimationEnd+ , onTransitionEnd++ -- * Reactive attributes+ , dataAttr+ , dataAttrs+ , dataClass+ , dataClasses+ , dataStyle+ , dataStyles+ , dataText+ , dataShow++ -- * Signals+ , dataSignals+ , dataSignalsJson+ , dataComputed+ , dataBind+ , dataBindValue+ , dataJsonSignals++ -- * Lifecycle / refs+ , dataInit+ , dataEffect+ , dataRef+ , dataRefValue+ , dataIndicator+ , dataIndicatorValue++ -- * Lifecycle events+ , dataOnIntersect+ , dataOnInterval+ , dataOnSignalPatch+ , dataOnSignalPatchFilter++ -- * Morph / ignore controls+ , dataIgnore+ , dataIgnoreMorph+ , dataPreserveAttr++ -- * Modifier combinators+ -- ** Event flags+ , prevent+ , stop+ , once+ , capture+ , passive+ , window+ , document_+ , outside+ , viewTransition+ -- ** Timing+ , debounce+ , debounceWith+ , throttle+ , throttleWith+ , delay+ -- ** Casing+ , camelCase+ , kebabCase+ , snakeCase+ , pascalCase+ -- ** on-intersect+ , full+ , half+ , threshold+ , exit+ -- ** on-interval+ , duration+ , durationWith+ -- ** bind+ , bindProp+ , bindEvents+ -- ** signals \/ json-signals \/ ignore+ , ifMissing+ , terse+ , self++ -- * Modifier tag constants+ -- $tags+ , leading+ , noTrailing+ , noLeading+ , trailing++ -- * Escape hatches+ , withModifier+ , withModifierTags+ , rawAttr+ ) where++import Data.Text (Text)+import Data.Text qualified as T++-- | A @(name, value)@ pair ready to feed into any HTML library.+type Attribute = (Text, Text)++-- ---------------------------------------------------------------------------+-- Event handlers+-- ---------------------------------------------------------------------------++-- | @data-on:\<event\>="\<expr\>"@. Use the shortcuts below for common events,+-- or call directly for custom events (e.g. @dataOn \"my-custom-event\" ...@).+dataOn :: Text -> Text -> Attribute+dataOn ev expr = ("data-on:" <> ev, expr)++onClick, onSubmit, onInput, onChange, onFocus, onBlur :: Text -> Attribute+onClick = dataOn "click"+onSubmit = dataOn "submit"+onInput = dataOn "input"+onChange = dataOn "change"+onFocus = dataOn "focus"+onBlur = dataOn "blur"++onKeyDown, onKeyUp, onKeyPress :: Text -> Attribute+onKeyDown = dataOn "keydown"+onKeyUp = dataOn "keyup"+onKeyPress = dataOn "keypress"++onMouseDown, onMouseUp, onMouseMove,+ onMouseEnter, onMouseLeave, onMouseOver, onMouseOut :: Text -> Attribute+onMouseDown = dataOn "mousedown"+onMouseUp = dataOn "mouseup"+onMouseMove = dataOn "mousemove"+onMouseEnter = dataOn "mouseenter"+onMouseLeave = dataOn "mouseleave"+onMouseOver = dataOn "mouseover"+onMouseOut = dataOn "mouseout"++onWheel, onScroll, onResize, onContextMenu :: Text -> Attribute+onWheel = dataOn "wheel"+onScroll = dataOn "scroll"+onResize = dataOn "resize"+onContextMenu = dataOn "contextmenu"++onTouchStart, onTouchEnd, onTouchMove :: Text -> Attribute+onTouchStart = dataOn "touchstart"+onTouchEnd = dataOn "touchend"+onTouchMove = dataOn "touchmove"++onDragStart, onDragEnd, onDrop :: Text -> Attribute+onDragStart = dataOn "dragstart"+onDragEnd = dataOn "dragend"+onDrop = dataOn "drop"++onCopy, onCut, onPaste :: Text -> Attribute+onCopy = dataOn "copy"+onCut = dataOn "cut"+onPaste = dataOn "paste"++onLoad :: Text -> Attribute+onLoad = dataOn "load"++onAnimationStart, onAnimationEnd, onTransitionEnd :: Text -> Attribute+onAnimationStart = dataOn "animationstart"+onAnimationEnd = dataOn "animationend"+onTransitionEnd = dataOn "transitionend"++-- ---------------------------------------------------------------------------+-- Reactive attributes+-- ---------------------------------------------------------------------------++-- | @data-attr:\<name\>="\<expr\>"@+dataAttr :: Text -> Text -> Attribute+dataAttr name expr = ("data-attr:" <> name, expr)++-- | @data-attr="\<jsObject\>"@ — set multiple attributes at once.+dataAttrs :: Text -> Attribute+dataAttrs jsObj = ("data-attr", jsObj)++-- | @data-class:\<name\>="\<expr\>"@+dataClass :: Text -> Text -> Attribute+dataClass name expr = ("data-class:" <> name, expr)++-- | @data-class="\<jsObject\>"@ — toggle several classes from one expression.+dataClasses :: Text -> Attribute+dataClasses jsObj = ("data-class", jsObj)++-- | @data-style:\<property\>="\<expr\>"@+dataStyle :: Text -> Text -> Attribute+dataStyle prop expr = ("data-style:" <> prop, expr)++-- | @data-style="\<jsObject\>"@ — set several style properties at once.+dataStyles :: Text -> Attribute+dataStyles jsObj = ("data-style", jsObj)++-- | @data-text="\<expr\>"@+dataText :: Text -> Attribute+dataText expr = ("data-text", expr)++-- | @data-show="\<expr\>"@+dataShow :: Text -> Attribute+dataShow expr = ("data-show", expr)++-- ---------------------------------------------------------------------------+-- Signals+-- ---------------------------------------------------------------------------++-- | @data-signals:\<name\>="\<expr\>"@+dataSignals :: Text -> Text -> Attribute+dataSignals name expr = ("data-signals:" <> name, expr)++-- | @data-signals="\<jsObject\>"@+dataSignalsJson :: Text -> Attribute+dataSignalsJson jsObj = ("data-signals", jsObj)++-- | @data-computed:\<name\>="\<expr\>"@+dataComputed :: Text -> Text -> Attribute+dataComputed name expr = ("data-computed:" <> name, expr)++-- | @data-bind:\<signal\>@+dataBind :: Text -> Attribute+dataBind signal = ("data-bind:" <> signal, "")++-- | @data-bind="\<signal\>"@+dataBindValue :: Text -> Attribute+dataBindValue signal = ("data-bind", signal)++-- | @data-json-signals@. Wrap with 'terse' for compact output.+dataJsonSignals :: Attribute+dataJsonSignals = ("data-json-signals", "")++-- ---------------------------------------------------------------------------+-- Lifecycle / refs+-- ---------------------------------------------------------------------------++-- | @data-init="\<expr\>"@+dataInit :: Text -> Attribute+dataInit expr = ("data-init", expr)++-- | @data-effect="\<expr\>"@+dataEffect :: Text -> Attribute+dataEffect expr = ("data-effect", expr)++-- | @data-ref:\<name\>@+dataRef :: Text -> Attribute+dataRef name = ("data-ref:" <> name, "")++-- | @data-ref="\<name\>"@+dataRefValue :: Text -> Attribute+dataRefValue name = ("data-ref", name)++-- | @data-indicator:\<signal\>@+dataIndicator :: Text -> Attribute+dataIndicator signal = ("data-indicator:" <> signal, "")++-- | @data-indicator="\<signal\>"@+dataIndicatorValue :: Text -> Attribute+dataIndicatorValue signal = ("data-indicator", signal)++-- ---------------------------------------------------------------------------+-- Lifecycle events+-- ---------------------------------------------------------------------------++-- | @data-on-intersect="\<expr\>"@. Combine with 'full', 'half', 'threshold',+-- 'once', 'exit'.+dataOnIntersect :: Text -> Attribute+dataOnIntersect expr = ("data-on-intersect", expr)++-- | @data-on-interval="\<expr\>"@. Combine with 'duration'.+dataOnInterval :: Text -> Attribute+dataOnInterval expr = ("data-on-interval", expr)++-- | @data-on-signal-patch="\<expr\>"@. Pair with 'dataOnSignalPatchFilter'.+dataOnSignalPatch :: Text -> Attribute+dataOnSignalPatch expr = ("data-on-signal-patch", expr)++-- | @data-on-signal-patch-filter="\<jsObject\>"@+dataOnSignalPatchFilter :: Text -> Attribute+dataOnSignalPatchFilter v = ("data-on-signal-patch-filter", v)++-- ---------------------------------------------------------------------------+-- Morph / ignore controls+-- ---------------------------------------------------------------------------++-- | @data-ignore@. Wrap with 'self' for the self-only variant.+dataIgnore :: Attribute+dataIgnore = ("data-ignore", "")++-- | @data-ignore-morph@+dataIgnoreMorph :: Attribute+dataIgnoreMorph = ("data-ignore-morph", "")++-- | @data-preserve-attr="\<comma-list\>"@+dataPreserveAttr :: Text -> Attribute+dataPreserveAttr names = ("data-preserve-attr", names)++-- ---------------------------------------------------------------------------+-- Modifier combinators+-- ---------------------------------------------------------------------------++-- | Append @__\<label\>@ to the attribute name.+withModifier :: Text -> Attribute -> Attribute+withModifier label (k, v) = (k <> "__" <> label, v)++-- | Append @__\<label\>.\<tag\>.\<tag\>...@ to the attribute name.+withModifierTags :: Text -> [Text] -> Attribute -> Attribute+withModifierTags label tags (k, v) =+ (k <> "__" <> label <> T.concat (map ("." <>) tags), v)++-- | Build any @(name, value)@ pair directly. Escape hatch for attributes or+-- modifiers this module doesn't model.+rawAttr :: Text -> Text -> Attribute+rawAttr = (,)++-- Event flags --------------------------------------------------------------++prevent, stop, once, capture, passive :: Attribute -> Attribute+prevent = withModifier "prevent"+stop = withModifier "stop"+once = withModifier "once"+capture = withModifier "capture"+passive = withModifier "passive"++-- | Attach the listener to @window@ instead of the element.+window :: Attribute -> Attribute+window = withModifier "window"++-- | Attach the listener to @document@ instead of the element.+document_ :: Attribute -> Attribute+document_ = withModifier "document"++-- | Fire only when the event target is outside the element.+outside :: Attribute -> Attribute+outside = withModifier "outside"++-- | Wrap the handler in a View Transition.+viewTransition :: Attribute -> Attribute+viewTransition = withModifier "viewtransition"++-- Timing -------------------------------------------------------------------++-- | @__debounce.\<ms\>ms@+debounce :: Int -> Attribute -> Attribute+debounce ms = withModifierTags "debounce" [renderMs ms]++-- | @__debounce.\<ms\>ms.\<tag\>...@ — pass 'leading' and\/or 'noTrailing'.+debounceWith :: Int -> [Text] -> Attribute -> Attribute+debounceWith ms tags = withModifierTags "debounce" (renderMs ms : tags)++-- | @__throttle.\<ms\>ms@+throttle :: Int -> Attribute -> Attribute+throttle ms = withModifierTags "throttle" [renderMs ms]++-- | @__throttle.\<ms\>ms.\<tag\>...@ — pass 'noLeading' and\/or 'trailing'.+throttleWith :: Int -> [Text] -> Attribute -> Attribute+throttleWith ms tags = withModifierTags "throttle" (renderMs ms : tags)++-- | @__delay.\<ms\>ms@+delay :: Int -> Attribute -> Attribute+delay ms = withModifierTags "delay" [renderMs ms]++-- Casing -------------------------------------------------------------------++camelCase, kebabCase, snakeCase, pascalCase :: Attribute -> Attribute+camelCase = withModifierTags "case" ["camel"]+kebabCase = withModifierTags "case" ["kebab"]+snakeCase = withModifierTags "case" ["snake"]+pascalCase = withModifierTags "case" ["pascal"]++-- on-intersect -------------------------------------------------------------++-- | Trigger only when 100% of the element is visible.+full :: Attribute -> Attribute+full = withModifier "full"++-- | Trigger when 50% of the element is visible.+half :: Attribute -> Attribute+half = withModifier "half"++-- | @__threshold.\<percent\>@ (0..100, clamped at runtime).+threshold :: Int -> Attribute -> Attribute+threshold pct = withModifierTags "threshold" [T.pack (show pct)]++-- | Trigger on exit rather than entry.+exit :: Attribute -> Attribute+exit = withModifier "exit"++-- on-interval --------------------------------------------------------------++-- | @__duration.\<ms\>ms@+duration :: Int -> Attribute -> Attribute+duration ms = withModifierTags "duration" [renderMs ms]++-- | @__duration.\<ms\>ms.\<tag\>...@ — pass 'leading' to fire immediately.+durationWith :: Int -> [Text] -> Attribute -> Attribute+durationWith ms tags = withModifierTags "duration" (renderMs ms : tags)++-- bind ---------------------------------------------------------------------++-- | @__prop.\<name\>@ — bind to an element property instead of an attribute.+bindProp :: Text -> Attribute -> Attribute+bindProp name = withModifierTags "prop" [name]++-- | @__event.\<ev\>.\<ev\>...@ — which DOM events trigger sync.+bindEvents :: [Text] -> Attribute -> Attribute+bindEvents events = withModifierTags "event" events++-- signals / json-signals / ignore -----------------------------------------++-- | @__ifmissing@ — only set the signal if it doesn't already exist.+ifMissing :: Attribute -> Attribute+ifMissing = withModifier "ifmissing"++-- | @__terse@ — emit JSON without indentation.+terse :: Attribute -> Attribute+terse = withModifier "terse"++-- | @__self@ — restrict @data-ignore@ to the element itself, not descendants.+self :: Attribute -> Attribute+self = withModifier "self"++-- ---------------------------------------------------------------------------+-- Tag constants+-- ---------------------------------------------------------------------------++-- $tags+-- Plain 'Text' values for use with the @*With@ combinators.++leading, noTrailing, noLeading, trailing :: Text+leading = "leading"+noTrailing = "notrailing"+noLeading = "noleading"+trailing = "trailing"++-- ---------------------------------------------------------------------------+-- Internal+-- ---------------------------------------------------------------------------++renderMs :: Int -> Text+renderMs n = T.pack (show n) <> "ms"