diff --git a/ghc-debug-brick/ghc-debug-brick.cabal b/ghc-debug-brick/ghc-debug-brick.cabal index fbbd0ada21aa932d274409b71efeb3684729b2e3..830c2d1cf7c55faa03cd545705c780d072d81acd 100644 --- a/ghc-debug-brick/ghc-debug-brick.cabal +++ b/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 diff --git a/ghc-debug-brick/src/Main.hs b/ghc-debug-brick/src/Main.hs index 223ed657ac62698b0f1f6ebece3d78c30e3d654b..6140c7a07c2deb481f71ada0338db2fc97536c75 100644 --- a/ghc-debug-brick/src/Main.hs +++ b/ghc-debug-brick/src/Main.hs @@ -1,57 +1,34 @@ {-# 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 ()