feat(runtime): make debugger display log

src/runtime-prototype/src/Debugger.hs

@@ -1,6 +1,16 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 module Debugger where
 
+import Brick
+import Brick.Widgets.Border (borderWithLabel, vBorder)
+import Brick.Widgets.Border.Style (unicode)
+import Brick.Widgets.Center (center, hCenter)
+import qualified Brick.Widgets.List as L
+import qualified Data.Vector as Vector
 import Control.Concurrent.Async
+import Control.Monad
+import qualified Graphics.Vty as V
 import System.FilePath
 import System.IO
 import System.Posix.Files
@@ -19,7 +29,54 @@ readLog = do
   s <- wait a
   return (read s)
 
+drawUI :: AppState -> [Widget ()]
+drawUI (AppState l) = [ui]
+  where
+    ui = withBorderStyle unicode
+       $ borderWithLabel (str "Debugger")
+       $ (center (L.renderList listDrawElement True l) <+> vBorder <+> center (str "Right"))
+
+listDrawElement :: Bool -> Timestamped LogEntry -> Widget ()
+listDrawElement sel (Timestamped le lt pt) =
+  let selStr s = if sel
+                 then withAttr customAttr (str $ "<" <> s <> ">")
+                 else str s
+  in hCenter $ selStr $ show le ++ " " ++ show lt ++ " " ++ show pt
+
+customAttr :: AttrName
+customAttr = L.listSelectedAttr <> "custom"
+
+app :: App AppState e ()
+app = App
+  { appDraw = drawUI
+  , appHandleEvent = appEvent
+  , appStartEvent = return
+  , appAttrMap = const theMap
+  , appChooseCursor = neverShowCursor
+  }
+
+appEvent :: AppState -> BrickEvent () e -> EventM () (Next AppState)
+appEvent as (VtyEvent e) =
+  case e of
+    V.EvKey (V.KChar 'q') [] -> halt as
+    ev -> continue =<< fmap AppState (L.handleListEventVi L.handleListEvent ev (asLog as))
+appEvent as _ = continue as
+
+theMap :: AttrMap
+theMap = attrMap V.defAttr
+    [ (customAttr, fg V.cyan)
+    ]
+
+data AppState = AppState
+  { asLog :: L.List () (Timestamped LogEntry)
+  }
+
+initialState :: Log -> AppState
+initialState (Log es) = AppState
+  { asLog = L.list () (Vector.fromList es) 1
+  }
+
 main :: IO ()
 main = do
   l <- readLog
-  print l
+  void (defaultMain app (initialState l))

src/runtime-prototype/src/StuntDouble/Transport/Http.hs

@@ -34,7 +34,7 @@ httpTransport port = do
   let settings = setPort port
                . setBeforeMainLoop (atomically (putTMVar readyTMVar ()))
                $ defaultSettings
-  aServer <- async (runSettings settings (app queue))
+  aServer <- async (runSettings settings (waiApp queue))
   aReady  <- async (atomically (takeTMVar readyTMVar))
   ok <- waitEither aServer aReady
   case ok of
@@ -70,8 +70,8 @@ envelopeToRequest e = do
            , requestBody = body
            }
 
-app :: TBQueue Envelope -> Wai.Application
-app queue req respond = do
+waiApp :: TBQueue Envelope -> Wai.Application
+waiApp queue req respond = do
   eEnvelope <- waiRequestToEnvelope req
   case eEnvelope of
     Left err -> do

src/runtime-prototype/stunt-double.cabal

@@ -63,6 +63,7 @@ library
       aeson
     , async
     , atomic-primops
+    , brick
     , bytestring
     , hashable
     , heaps
@@ -73,6 +74,7 @@ library
     , sqlite-simple
     , unordered-containers
     , vector
+    , vty
     , wai
     , warp