TUI: periodically poll for debuggees

This uses the new convention of placing sockets in `socketDirectory`

ghc-debug-brick/ghc-debug-brick.cabal

@@ -23,10 +23,12 @@ executable tui
   build-depends:       base >=4.10 && <5
                      , brick
                      , containers
+                     , directory
+                     , filepath
+                     , ghc-debug-client
                      , microlens-platform
                      , text
                      , vty
-                     , ghc-debug-client
   hs-source-dirs:    src
   default-language:    Haskell2010
   ghc-options: -threaded

ghc-debug-brick/src/Main.hs

 {-# LANGUAGE OverloadedLabels  #-}
 {-# LANGUAGE OverloadedLists   #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE RecordWildCards   #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE TemplateHaskell #-}
 
 module Main where
-
-import Brick
-import Brick.BChan
-import Brick.Widgets.List
-import Data.Sequence
+import Control.Applicative
+import Control.Monad (forever)
+import Control.Monad.IO.Class
+import Control.Concurrent
+import qualified Data.List as List
+import Data.Sequence as Seq
 import Data.Text
 import Graphics.Vty(defaultConfig, mkVty, defAttr)
 import qualified Graphics.Vty.Input.Events as Vty
 import Graphics.Vty.Input.Events (Key(..))
 import Lens.Micro.Platform
+import System.Directory
+import System.FilePath
+
+import Brick
+import Brick.BChan
 import Brick.Widgets.Border
+import Brick.Widgets.List
 
 import GHC.Debug.Client
 
--- data AppState = AppState
---   -- | Known debuggees that we could connect to.
---   { stateKnownDebuggees :: [Debuggee]
---   , selectedDebuggee :: Maybe Debuggee
---   }
-
--- data Debuggee = Debuggee FilePath
-
--- data Event
---   = Closed
---   | SetKnownDebuggees [Debuggee]
---   -- | SetSelectedDebuggee Debuggee
---   | NoOp
-
--- view' :: AppState -> AppView Window Event
--- view' state
---   = bin Window
---       [ #title := "ghc-debug"
---       , on #deleteEvent (const (True, Closed))
---       , #widthRequest := 400
---       , #heightRequest := 300
---       ]
---       $ container Box []
---         [ -- widget ComboBox [#model := [("Hello ghc-debug World!" :: String)]]
---           NoOp <$ BoxChild defaultBoxChildProperties (CB.comboBox [] [(1 :: Int, "adsfadsf1"), (2, "2")])
---         ]
-
--- update' :: AppState -> Event -> Transition AppState Event
--- -- update' AppState {..} (Greet who) =
--- --   Transition AppState { greetings = greetings <> [who] } (pure Nothing)
--- update' _ Closed = Exit
-
 data Event
+  = PollTick  -- Used to perform arbitrary polling based tasks e.g. looking for new debuggees
 
 data Name
   = Main
@@ -59,36 +36,60 @@ data Name
   deriving (Eq, Ord, Show)
 
 data AppState = AppState
-  { _options :: GenericList Name Seq Text
+  { _knownDebuggees :: GenericList Name Seq (Text, FilePath) -- ^ File name and full path
   }
 
 makeLenses ''AppState
 
 myAppDraw :: AppState -> [Widget Name]
-myAppDraw (AppState options) =
+myAppDraw appState =
   [ borderWithLabel (txt "ghc-debug")
   $ padAll 1
   $ vBox
-    [ txt "Hello Brick World!"
+    [ txt $ "Select a process to debug (" <> pack (show nKnownDebuggees) <> " found):"
     , renderList
-        (\elIsSelected el -> hBox
+        (\elIsSelected (el, _) -> hBox
             [ txt $ if elIsSelected then "*" else " "
             , txt " "
             , txt el
             ]
         )
         True
-        options
+        (appState^.knownDebuggees)
     ]
   ]
+  where
+  nKnownDebuggees = Seq.length $ appState^.knownDebuggees.listElementsL
 
-myAppHandleEvent :: AppState -> BrickEvent Name e -> EventM Name (Next AppState)
+myAppHandleEvent :: AppState -> BrickEvent Name Event -> EventM Name (Next AppState)
 myAppHandleEvent appState brickEvent = case brickEvent of
   VtyEvent (Vty.EvKey KEsc []) -> halt appState
   VtyEvent event -> do
-    handleListEvent event (appState^.options)
-    newOptions <- handleListEvent event (appState^.options)
-    continue $ appState & options .~ newOptions
+    handleListEvent event (appState^.knownDebuggees)
+    newOptions <- handleListEvent event (appState^.knownDebuggees)
+    continue $ appState & knownDebuggees .~ newOptions
+  AppEvent event -> case event of
+    PollTick -> do
+      -- Poll for debuggees
+      knownDebuggees' <- liftIO $ do
+        dir :: FilePath <- socketDirectory
+        debuggeeSockets :: [FilePath] <- listDirectory dir <|> return []
+
+        let currentSelectedPathMay :: Maybe FilePath
+            currentSelectedPathMay = fmap (snd . snd) (listSelectedElement (appState^.knownDebuggees))
+
+            newSelection :: Maybe Int
+            newSelection = do
+              currentSelectedPath <- currentSelectedPathMay
+              List.findIndex (currentSelectedPath ==) debuggeeSockets
+
+        return $ listReplace
+                  (fromList [(pack (dir </> socket), socket) | socket <- debuggeeSockets])
+                  newSelection
+                  (appState^.knownDebuggees)
+
+      continue $ appState & knownDebuggees .~ knownDebuggees'
+
   _ -> do
     continue appState
 
@@ -101,6 +102,9 @@ myAppAttrMap _appState = attrMap defAttr []
 main :: IO ()
 main = do
   eventChan <- newBChan 10
+  forkIO $ forever $ do
+    writeBChan eventChan PollTick
+    threadDelay 2000000
   let buildVty = mkVty defaultConfig
   initialVty <- buildVty
   let app :: App AppState Event Name
@@ -112,6 +116,8 @@ main = do
         , appAttrMap = myAppAttrMap
         }
       initialState = AppState
+        { _knownDebuggees = list Main_FileList [] 1
+        }
   _finalState <- customMain initialVty buildVty
-                    (Just eventChan) app (initialState (list Main_FileList ["A", "BB", "CC"] 1))
+                    (Just eventChan) app initialState
   return ()