"
+ <> 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
new file mode 100644
--- /dev/null
+++ b/examples/Examples/HeapView.hs
@@ -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 =
+ ""
+ <> "
"
+ <> "
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
new file mode 100644
--- /dev/null
+++ b/examples/Examples/HelloWorldChannel.hs
@@ -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 = "" <> 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
new file mode 100644
--- /dev/null
+++ b/examples/Examples/HelloWorldServant.hs
@@ -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 = "" <> 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
new file mode 100644
--- /dev/null
+++ b/examples/Examples/HelloWorldWarp.hs
@@ -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 = "" <> 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
deleted file mode 100644
--- a/examples/activity-feed.hs
+++ /dev/null
@@ -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 $
- ""
- <> 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
new file mode 100644
--- /dev/null
+++ b/examples/exe/activity-feed.hs
@@ -0,0 +1,6 @@
+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
new file mode 100644
--- /dev/null
+++ b/examples/exe/heap-view.hs
@@ -0,0 +1,6 @@
+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
new file mode 100644
--- /dev/null
+++ b/examples/exe/hello-world-channel.hs
@@ -0,0 +1,6 @@
+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
new file mode 100644
--- /dev/null
+++ b/examples/exe/hello-world-servant.hs
@@ -0,0 +1,6 @@
+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
new file mode 100644
--- /dev/null
+++ b/examples/exe/hello-world-warp.hs
@@ -0,0 +1,6 @@
+module Main (main) where
+
+import Examples.HelloWorldWarp (runExample)
+
+main :: IO ()
+main = runExample
diff --git a/examples/heap-view.hs b/examples/heap-view.hs
deleted file mode 100644
--- a/examples/heap-view.hs
+++ /dev/null
@@ -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 =
- ""
- <> "
"
- <> "
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
deleted file mode 100644
--- a/examples/hello-world-channel.hs
+++ /dev/null
@@ -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 = "" <> 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
deleted file mode 100644
--- a/examples/hello-world-servant.hs
+++ /dev/null
@@ -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 = "" <> 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
deleted file mode 100644
--- a/examples/hello-world-warp.hs
+++ /dev/null
@@ -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 = "" <> T.pack (take i message) <> "
"
- sendPatchElements gen (patchElements html)
- threadDelay (delay signals * 1000)
- )
- [1 .. length message]
diff --git a/src/Hypermedia/Datastar/Attributes.hs b/src/Hypermedia/Datastar/Attributes.hs
new file mode 100644
--- /dev/null
+++ b/src/Hypermedia/Datastar/Attributes.hs
@@ -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:\="\"@. 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:\="\"@
+dataAttr :: Text -> Text -> Attribute
+dataAttr name expr = ("data-attr:" <> name, expr)
+
+-- | @data-attr="\"@ — set multiple attributes at once.
+dataAttrs :: Text -> Attribute
+dataAttrs jsObj = ("data-attr", jsObj)
+
+-- | @data-class:\="\"@
+dataClass :: Text -> Text -> Attribute
+dataClass name expr = ("data-class:" <> name, expr)
+
+-- | @data-class="\"@ — toggle several classes from one expression.
+dataClasses :: Text -> Attribute
+dataClasses jsObj = ("data-class", jsObj)
+
+-- | @data-style:\="\"@
+dataStyle :: Text -> Text -> Attribute
+dataStyle prop expr = ("data-style:" <> prop, expr)
+
+-- | @data-style="\"@ — set several style properties at once.
+dataStyles :: Text -> Attribute
+dataStyles jsObj = ("data-style", jsObj)
+
+-- | @data-text="\"@
+dataText :: Text -> Attribute
+dataText expr = ("data-text", expr)
+
+-- | @data-show="\"@
+dataShow :: Text -> Attribute
+dataShow expr = ("data-show", expr)
+
+-- ---------------------------------------------------------------------------
+-- Signals
+-- ---------------------------------------------------------------------------
+
+-- | @data-signals:\="\"@
+dataSignals :: Text -> Text -> Attribute
+dataSignals name expr = ("data-signals:" <> name, expr)
+
+-- | @data-signals="\"@
+dataSignalsJson :: Text -> Attribute
+dataSignalsJson jsObj = ("data-signals", jsObj)
+
+-- | @data-computed:\="\"@
+dataComputed :: Text -> Text -> Attribute
+dataComputed name expr = ("data-computed:" <> name, expr)
+
+-- | @data-bind:\@
+dataBind :: Text -> Attribute
+dataBind signal = ("data-bind:" <> signal, "")
+
+-- | @data-bind="\"@
+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="\"@
+dataInit :: Text -> Attribute
+dataInit expr = ("data-init", expr)
+
+-- | @data-effect="\"@
+dataEffect :: Text -> Attribute
+dataEffect expr = ("data-effect", expr)
+
+-- | @data-ref:\@
+dataRef :: Text -> Attribute
+dataRef name = ("data-ref:" <> name, "")
+
+-- | @data-ref="\"@
+dataRefValue :: Text -> Attribute
+dataRefValue name = ("data-ref", name)
+
+-- | @data-indicator:\@
+dataIndicator :: Text -> Attribute
+dataIndicator signal = ("data-indicator:" <> signal, "")
+
+-- | @data-indicator="\"@
+dataIndicatorValue :: Text -> Attribute
+dataIndicatorValue signal = ("data-indicator", signal)
+
+-- ---------------------------------------------------------------------------
+-- Lifecycle events
+-- ---------------------------------------------------------------------------
+
+-- | @data-on-intersect="\"@. Combine with 'full', 'half', 'threshold',
+-- 'once', 'exit'.
+dataOnIntersect :: Text -> Attribute
+dataOnIntersect expr = ("data-on-intersect", expr)
+
+-- | @data-on-interval="\"@. Combine with 'duration'.
+dataOnInterval :: Text -> Attribute
+dataOnInterval expr = ("data-on-interval", expr)
+
+-- | @data-on-signal-patch="\"@. Pair with 'dataOnSignalPatchFilter'.
+dataOnSignalPatch :: Text -> Attribute
+dataOnSignalPatch expr = ("data-on-signal-patch", expr)
+
+-- | @data-on-signal-patch-filter="\"@
+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="\"@
+dataPreserveAttr :: Text -> Attribute
+dataPreserveAttr names = ("data-preserve-attr", names)
+
+-- ---------------------------------------------------------------------------
+-- Modifier combinators
+-- ---------------------------------------------------------------------------
+
+-- | Append @__\@ to the attribute name.
+withModifier :: Text -> Attribute -> Attribute
+withModifier label (k, v) = (k <> "__" <> label, v)
+
+-- | Append @__\.\.\...@ 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@
+debounce :: Int -> Attribute -> Attribute
+debounce ms = withModifierTags "debounce" [renderMs ms]
+
+-- | @__debounce.\ms.\...@ — pass 'leading' and\/or 'noTrailing'.
+debounceWith :: Int -> [Text] -> Attribute -> Attribute
+debounceWith ms tags = withModifierTags "debounce" (renderMs ms : tags)
+
+-- | @__throttle.\ms@
+throttle :: Int -> Attribute -> Attribute
+throttle ms = withModifierTags "throttle" [renderMs ms]
+
+-- | @__throttle.\ms.\...@ — pass 'noLeading' and\/or 'trailing'.
+throttleWith :: Int -> [Text] -> Attribute -> Attribute
+throttleWith ms tags = withModifierTags "throttle" (renderMs ms : tags)
+
+-- | @__delay.\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.\@ (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@
+duration :: Int -> Attribute -> Attribute
+duration ms = withModifierTags "duration" [renderMs ms]
+
+-- | @__duration.\ms.\...@ — pass 'leading' to fire immediately.
+durationWith :: Int -> [Text] -> Attribute -> Attribute
+durationWith ms tags = withModifierTags "duration" (renderMs ms : tags)
+
+-- bind ---------------------------------------------------------------------
+
+-- | @__prop.\@ — bind to an element property instead of an attribute.
+bindProp :: Text -> Attribute -> Attribute
+bindProp name = withModifierTags "prop" [name]
+
+-- | @__event.\.\...@ — 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"