Update.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE GADTs #-}

module GHC.Debug.Brick.Update where

import Brick
import Brick.BChan
import Brick.Forms
import Brick.Widgets.List
import Control.Applicative
import Control.Concurrent.Async (cancel)
import Control.Monad.Catch (bracket)
import Control.Monad.IO.Class
import qualified Data.ByteString.Lazy as BS
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import Data.Ord (comparing)
import qualified Data.Ord as Ord
import qualified Data.Sequence as Seq
import Data.Text (Text)
import qualified Data.Text as T
import qualified Graphics.Vty as Vty
import Graphics.Vty.Input.Events (Key (..))
import Lens.Micro.Platform
import System.Directory
import System.FilePath
import Text.Read (readMaybe)

import GHC.Debug.Profile (writeCensusByClosureType)
import qualified GHC.Debug.Types.Closures as Debug
import GHC.Debug.Types.Ptr (arrWordsBS, readInfoTablePtr)

import Brick.Widgets.IOTree
import Brick.Widgets.ListPicker (ListPicker (..))
import qualified Brick.Widgets.ListPicker as ListPicker
import GHC.Debug.Brick.Action.ArrWords
import GHC.Debug.Brick.Action.Profile
import GHC.Debug.Brick.Action.Retainers
import GHC.Debug.Brick.Action.Strings
import GHC.Debug.Brick.Action.Thunk
import GHC.Debug.Brick.ClosureDetails
import GHC.Debug.Brick.IOTree
import GHC.Debug.Brick.Lib as GD
import GHC.Debug.Brick.Model as Model
import GHC.Debug.Brick.Render.Closure
import qualified GHC.Debug.Brick.Render.Command as Command
import GHC.Debug.Brick.Render.Footer
import qualified GHC.Debug.Brick.Render.HistoryPicker as History
import GHC.Debug.Brick.Render.Utils
import GHC.Debug.Brick.UI.Async
import GHC.Debug.Brick.UI.Filter

-- ----------------------------------------------------------------------------
-- Window Management
-- ----------------------------------------------------------------------------

handleMainWindowEvent :: Handler () OperationalState
handleMainWindowEvent brickEvent = do
  os <- get

  case brickEvent of
    VtyEvent (Vty.EvKey (KChar 'p') [Vty.MCtrl]) ->
      navigationDisabledOr $ do
        put $ os & keybindingsMode .~ CommandPicker (commandListPicker (os ^. Model.version))

    VtyEvent (Vty.EvKey (KChar 'r') [Vty.MCtrl]) -> do
      navigationDisabledOr $ do
        put $ os & keybindingsMode .~ HistoryPicker (historyListPicker (os ^. navigator))

    -- A generic event
    VtyEvent event
      | Just cmd <- findCommand event ->
        if isCmdDisabled (os ^. Model.version) cmd
          then return () -- Command is disabled, don't dispatch the command
          else dispatchCommand cmd

    -- Navigate the tree of closures
    VtyEvent event -> case os ^. treeMode of
      GcRoots r t-> do
        newTree <- handleIOTreeEvent event t
        put (os & treeMode .~ GcRoots r newTree)
      Retainer r t -> do
        newTree <- handleIOTreeEvent event t
        put (os & treeMode .~ Retainer r newTree)
      Profile r t -> do
        newTree <- handleIOTreeEvent event t
        put (os & treeMode .~ Profile r newTree)
      Strings r t -> do
        newTree <- handleIOTreeEvent event t
        put (os & treeMode .~ Strings r newTree)
      ArrWords r t -> do
        newTree <- handleIOTreeEvent event t
        put (os & treeMode .~ ArrWords r newTree)
      Thunk r t -> do
        newTree <- handleIOTreeEvent event t
        put (os & treeMode .~ Thunk r newTree)

    _ -> return ()

-- Event handling when the main window has focus

handleMain :: Debuggee -> Handler Event OperationalState
handleMain dbg e = do
  os <- get
  case e of
    AppEvent event -> case event of
      PollTick -> return ()
      ProgressMessage t -> do
        put $ footerMessage t os
      ProgressFinished desc runtime ->
        put $ os
              & running_task .~ Nothing
              & last_run_time .~ Just (desc, runtime)
              & footerMode .~ FooterInfo
      AsyncFinished action -> action
      AsyncAborted exc -> do
        -- As the running task was aborted for some reason
        -- remove it from the running_task field
        put $ os & running_task .~ Nothing
        put $ footerMessage (T.pack $ show exc) os

      NewSampleEvent sampleEv ->
        handleSampleEvent sampleEv

      NavigatorEvent navEv ->
        navigationDisabledOr $ do
          handleHistoryNavigatorEvent navEv

      DoSearchWithHistoryPush searchCmd -> do
        put (os & navigator %~ navPush searchCmd)
        -- We perform a full search if the cached results
        -- are partial.
        handleSearchEvent dbg True searchCmd

      DoSearch searchCmd ->
        -- This is a navigation event, show partial results if there are any.
        handleSearchEvent dbg False searchCmd

      CacheSearch cmd result ->
        cacheCompleteResult cmd result

      CachePartialSearch cmd result ->
        cachePartialResult cmd result

    _ ->
      case view keybindingsMode os of
        KeybindingsShown ->
          case e of
            VtyEvent (Vty.EvKey _ _) -> put $ os & keybindingsMode .~ NoOverlay
            _ -> put os

        HistoryPicker listPicker ->
          handleHistoryListPicker e listPicker

        CommandPicker listPicker ->
          handleCommandListPicker e listPicker

        NoOverlay -> case view footerMode os of
          FooterInput fm form -> inputFooterHandler dbg fm form handleMainWindowEvent (() <$ e)
          _ -> handleMainWindowEvent (() <$ e)

handleHistoryListPicker :: BrickEvent Name Event -> ListPicker Name OperationalState Event HistoryCommand -> EventM Name OperationalState ()
handleHistoryListPicker e picker = do
  ListPicker.handleListPicker e picker >>= \ case
    ListPicker.Unchanged -> pure ()
    ListPicker.Changed newPicker -> modify (keybindingsMode .~ HistoryPicker newPicker)
    ListPicker.Exit -> modify (keybindingsMode .~ NoOverlay)

handleCommandListPicker :: BrickEvent Name Event -> ListPicker Name OperationalState Event Command -> EventM Name OperationalState ()
handleCommandListPicker e picker = do
  ListPicker.handleListPicker e picker >>= \ case
    ListPicker.Unchanged -> pure ()
    ListPicker.Changed newPicker -> modify (keybindingsMode .~ CommandPicker newPicker)
    ListPicker.Exit -> modify (keybindingsMode .~ NoOverlay)

navigationDisabledOr :: EventM Name OperationalState () -> EventM Name OperationalState ()
navigationDisabledOr act = do
  os <- get
  case os ^. running_task of
    Nothing ->
      act
    Just _ ->
      modify (footerMessage "Navigation disabled during a running heap traversal, press ESC to cancel")

handleHistoryNavigatorEvent :: NavigatorEvent -> EventM Name OperationalState ()
handleHistoryNavigatorEvent navEv = do
  os <- get
  case navEv of
    GoOneBackwards -> do
      let
        nav = os ^. navigator
        (mEvent, newNav) = navBackwards nav

      put $
        os & navigator .~ newNav

      case mEvent of
        Nothing ->
          put (os & footerMessage "No previous view available")
        Just ev -> do
          sendEvent $ DoSearch ev

    GoOneForwards -> do
      let
        nav = os ^. navigator
        (mEvent, newNav) = navForward nav

      put $
        os & navigator .~ newNav

      case mEvent of
        Nothing ->
          put (os & footerMessage "No next view available")
        Just ev -> do
          sendEvent $ DoSearch ev

handleSearchEvent :: Debuggee -> Bool -> SomeSearchCmd -> EventM Name OperationalState ()
handleSearchEvent dbg fullSearch (SomeSearchCmd searchCmd) = do
  os <- get
  case searchCmd of
    DoGcRootsSearch ->
      cachedOrRun
        fullSearch
        DoGcRootsSearch
        (\ gcRoots ->
          put (os & treeMode .~ gcRootsTreeMode (gcRootsIOTree dbg gcRoots))
        )
        (do
          -- TODO: This logic belongs in GHC.Debug.Brick.GcRoots
          -- TODO: introduce event to set the 'rootsFrom'
          (closures, roots) <- liftIO $ gcRootsAction dbg
          modify (\ o -> o & rootsFrom .~ DefaultRoots roots)
          -- TODO: This is awkward, but this makes sure the view is updated.
          -- Rather, we should have two types of events, one that changes the
          -- view and one that sends values.
          sendEvent $ NewSampleEvent $ GcRootsSample closures
          sendEvent $ CacheSearch DoGcRootsSearch closures
        )

    DoRetainerSearch limit uifilters ->
      cachedOrRun
        fullSearch
        (DoRetainerSearch limit uifilters)
        (\ retainers ->
          put (os & treeMode .~ retainerTreeMode (os ^. resultSize) (retainerTree dbg retainers) (topRetainersFromRetainerMap retainers))
        )
        (searchWithCurrentFiltersIncremental dbg uifilters)

    DoProfileSearch lvl ->
      cachedOrRun
        fullSearch
        (DoProfileSearch lvl)
        (\ census ->
          put (os & treeMode .~ profileTreeMode (os ^. resultSize) (profileTree dbg) census)
        )
        (profileAction dbg lvl)

    DoStringSearch ->
      cachedOrRun
        fullSearch
        DoStringSearch
        (\ census ->
          put (os & treeMode .~ stringTreeMode (os ^. resultSize) (stringTree dbg) census)
        )
        (stringsAction dbg)

    DoArrWordsSearch ->
      cachedOrRun
        fullSearch
        DoArrWordsSearch
        (\ census ->
          put (os & treeMode .~ arrWordsTreeMode (os ^. resultSize) (arrWordsTree dbg) census)
        )
        (arrWordsAction dbg)

    DoThunkSearch ->
      cachedOrRun
        fullSearch
        DoThunkSearch
        (\ census ->
          put (os & treeMode .~ thunkTreeMode (os ^. resultSize) (thunkTree dbg) census)
        )
        (thunkAnalysisActionAsync dbg)

handleSampleEvent :: SampleEvent -> EventM Name OperationalState ()
handleSampleEvent ev = do
  os <- get
  case ev of
    GcRootsSample closures -> do
      case os ^. treeMode of
        GcRoots render t -> do
          put $ os & treeMode .~ GcRoots render (setIOTreeRoots closures t)
          -- TODO: support partial results
        _ ->
          -- If a sample is received but not displaying a gcRoots view in the tree for some reason, just ignore it.
          return ()

    RetainerSample closure_retainer_stack_sample -> do
      case os ^. treeMode of
        Retainer render t -> do
          case closure_retainer_stack_sample of
            [] -> pure () -- Theoretically, this should never occur.
            (new_sample_clos_detail:_) -> do
              -- Why do we only need the first element?
              -- Because the first element of the 'new_closure_stack_sample'
              -- is the closure of interest (or Leaf closure), while the tail
              -- is the retainer stack of closures.
              let root = RetainerStackRoot new_sample_clos_detail
              put $ os & treeMode .~ Retainer render (addIOTreeRoots [root] t)
              -- TODO: support partial results
        _ ->
          -- If a sample is received but not displaying a retainer view in the tree for some reason, just ignore it.
          return ()

    ProfileSample lvl census -> do
      case os ^. treeMode of
        Profile _ t -> do
          put $ os & treeMode .~ profileTreeMode (os ^. resultSize) t census
          sendEvent $ CachePartialSearch (DoProfileSearch lvl) census
        _ ->
          -- If a sample is received but not displaying a profile view in the tree for some reason, just ignore it.
          return ()

    StringSample census -> do
      case os ^. treeMode of
        Strings _render t -> do
          put $ os & treeMode .~ stringTreeMode (os ^. resultSize) t census
          sendEvent $ CachePartialSearch DoStringSearch census
        _ ->
          -- If a sample is received but not displaying a strings view in the tree for some reason, just ignore it.
          return ()

    ArrWordsSample census -> do
      case os ^. treeMode of
        ArrWords _render t -> do
          put $ os & treeMode .~ arrWordsTreeMode (os ^. resultSize) t census
          sendEvent $ CachePartialSearch DoArrWordsSearch census
        _ ->
          -- If a sample is received but not displaying a arr words view in the tree for some reason, just ignore it.
          return ()

    ThunkSample census -> do
      case os ^. treeMode of
        Thunk _render t -> do
          put $ os & treeMode .~ thunkTreeMode (os ^. resultSize) t census
          sendEvent $ CachePartialSearch DoThunkSearch census
        _ ->
          -- If a sample is received but not displaying a thunk view in the tree for some reason, just ignore it.
          return ()

inputFooterHandler :: Debuggee
                   -> FooterInputMode
                   -> Form Text () Name
                   -> Handler () OperationalState
                   -> Handler () OperationalState
inputFooterHandler dbg m form _k re@(VtyEvent e) =
  case e of
    Vty.EvKey KEsc [] -> do
      modify resetFooter
    Vty.EvKey KEnter [] -> do
      dispatchFooterInput dbg m form
    _
      | isInvertFilterEvent e ->
          let m' = invertInput m in
          modify (footerMode .~ (FooterInput m' (updateFormState (formState form) $ footerInputForm m')))
      | otherwise -> do
          zoom (lens (const form) (\ os form' -> set footerMode (FooterInput m form') os)) (handleFormEvent re)
inputFooterHandler _ _ _ k re = k re

-- | What happens when we press enter in footer input mode
dispatchFooterInput :: Debuggee
                    -> FooterInputMode
                    -> Form Text () n
                    -> EventM n OperationalState ()
dispatchFooterInput _ (FClosureAddress runf invert) form   = addOrSendUiFilter form runf readClosurePtr (pure . UIAddressFilter invert)
dispatchFooterInput _ (FInfoTableAddress runf invert) form = addOrSendUiFilter form runf readInfoTablePtr (pure . UIInfoAddressFilter invert)
dispatchFooterInput _ (FConstructorName runf invert) form = addOrSendUiFilter form runf Just (pure . UIConstructorFilter invert)
dispatchFooterInput _ (FClosureName runf invert) form = addOrSendUiFilter form runf Just (pure . UIInfoNameFilter invert)
dispatchFooterInput _ FArrWordsSize form = addOrSendUiFilter form True readMaybe (\size -> [UIClosureTypeFilter False Debug.ARR_WORDS, UISizeFilter False size])
dispatchFooterInput _ (FFilterEras runf invert) form = addOrSendUiFilter form runf (parseEraRange . T.pack) (pure . UIEraFilter invert)
dispatchFooterInput _ (FFilterClosureSize invert) form = addOrSendUiFilter form False readMaybe (pure . UISizeFilter invert)
dispatchFooterInput _ (FFilterClosureType invert) form = addOrSendUiFilter form False readMaybe (pure . UIClosureTypeFilter invert)
dispatchFooterInput _ (FFilterCcId runf invert) form = addOrSendUiFilter form runf readMaybe (pure . UICcId invert)
dispatchFooterInput _ FDumpArrWords form = do
  os <- get
  let
    act node = asyncAction_ "dumping ARR_WORDS payload" $
      case node of
        Just ClosureDetails{_closure = Closure{_closureSized = Debug.unDCS -> Debug.ArrWordsClosure{bytes, arrWords}}} ->
            BS.writeFile (T.unpack $ formState form) $ arrWordsBS (take (fromIntegral bytes) arrWords)
        _ -> pure ()
  case view treeMode os of
    Retainer _ iotree -> act (fmap retainerNodeClosure $ ioTreeSelection iotree)
    Profile _ _ -> put (os & footerMessage "Dump for profile mode not implemented yet")
    Strings _ iotree -> act (stringLineClosureDetails =<< ioTreeSelection iotree)
    Thunk _ _ -> put (os & footerMessage "Dump for thunk mode not implemented yet")
    ArrWords _ iotree ->  act (arrWordLineClosureDetails =<< ioTreeSelection iotree)
    GcRoots _ iotree -> act (ioTreeSelection iotree)
dispatchFooterInput _ FSetResultSize form = do
   asyncAction "setting result size" (pure ()) $ \() -> do
     os <- get
     case readMaybe $ T.unpack (formState form) of
       Just n
         | n <= 0 -> put (os & resultSize .~ Nothing)
         | otherwise -> put (os & resultSize .~ (Just n))
       Nothing -> pure ()
dispatchFooterInput dbg FSnapshot form = do
   asyncAction_ "Taking snapshot" $ snapshot dbg (T.unpack (formState form))
dispatchFooterInput _ FSaveTree form = do
  os <- get
  case os ^. treeMode of
    Profile _ t -> do
      let
        profLineToCensusByClosure = \ case
          ProfileLine key args stats -> Just ((key, args), stats)
          ClosureLine _ -> Nothing

        census = Map.fromList $ Maybe.mapMaybe profLineToCensusByClosure (getIOTreeRoots t)
      liftIO $ writeCensusByClosureType (T.unpack $ formState form) census

    _ ->
      put (os & footerMessage "Saving to file only supported for Profile views")

addOrSendUiFilter :: Form Text e n -> Bool -> (String -> Maybe t) -> (t -> [UIFilter]) -> EventM n OperationalState ()
addOrSendUiFilter form doRun parse newFilter = do
  os <- get
  addFilterOrSendEvent form doRun parse newFilter (DoRetainerSearch (os ^. resultSize))

addFilterOrSendEvent :: Form Text e n -> Bool -> (String -> Maybe t) -> (t -> [UIFilter]) -> ([UIFilter] -> SearchCmd RetainerMap) -> EventM n OperationalState ()
addFilterOrSendEvent form doRun parse createFilterM mkEvent = do
  case parse (T.unpack (formState form)) of
    Just x
      | doRun -> do
        let newFilter = createFilterM x
        let searchCmd = SomeSearchCmd $ mkEvent newFilter
        sendEvent (DoSearchWithHistoryPush searchCmd)
      | otherwise -> do
        let newFilter = createFilterM x
        modify (resetFooter . addFilters newFilter)
    Nothing ->
      pure ()

myAppHandleEvent :: BrickEvent Name Event -> EventM Name AppState ()
myAppHandleEvent brickEvent = do
  appState@(AppState majorState' eventChan) <- get
  case brickEvent of
    _ -> case majorState' of
      Setup st knownDebuggees' knownSnapshots' -> case brickEvent of

        VtyEvent (Vty.EvKey KEsc _) -> halt
        VtyEvent event -> case event of
          -- Connect to the selected debuggee
          Vty.EvKey (KChar '\t') [] -> do
            put $ appState & majorState . setupKind %~ toggleSetup
          Vty.EvKey KEnter _ ->
            case st of
              Snapshot
                | Just (_debuggeeIx, socket) <- listSelectedElement knownSnapshots'
                -> do
                  debuggee' <- liftIO $ snapshotConnect (writeBChan eventChan . ProgressMessage) (view socketLocation socket)
                  put $ appState & majorState .~ Connected
                        { _debuggeeSocket = socket
                        , _debuggee = debuggee'
                        , _mode     = RunningMode  -- TODO should we query the debuggee for this?
                    }
              Socket
                | Just (_debuggeeIx, socket) <- listSelectedElement knownDebuggees'
                -> do
                  bracket
                    (liftIO $ debuggeeConnect (writeBChan eventChan . ProgressMessage) (view socketLocation socket))
                    (\debuggee' -> liftIO $ resume debuggee')
                    (\debuggee' ->
                      put $ appState & majorState .~ Connected
                        { _debuggeeSocket = socket
                        , _debuggee = debuggee'
                        , _mode     = RunningMode  -- TODO should we query the debuggee for this?
                        })
              _ -> return ()

          -- Navigate through the list.
          _ -> do
            case st of
              Snapshot -> do
                zoom (majorState . knownSnapshots) (handleListEventVi handleListEvent event)
              Socket -> do
                zoom (majorState . knownDebuggees) (handleListEventVi handleListEvent event)

        AppEvent event -> case event of
          PollTick -> do
            -- Poll for debuggees
            knownDebuggees'' <- updateListFrom socketDirectory knownDebuggees'
            knownSnapshots'' <- updateListFrom snapshotDirectory knownSnapshots'
            put $ appState & majorState . knownDebuggees .~ knownDebuggees''
                                & majorState . knownSnapshots .~ knownSnapshots''
          _ -> return ()
        _ -> return ()

      Connected _socket' debuggee' mode' -> case mode' of

        RunningMode -> case brickEvent of
          -- Exit
          VtyEvent (Vty.EvKey KEsc _) ->
            halt
          -- Pause the debuggee
          VtyEvent (Vty.EvKey (KChar 'p') []) -> do
            liftIO $ pause debuggee'
            ver <- liftIO $ GD.version debuggee'
            put (appState & majorState . mode .~
                PausedMode
                  OperationalState
                    { _running_task = Nothing
                    , _last_run_time = Nothing
                    , _treeMode = gcRootsTreeMode (gcRootsIOTree debuggee' [])
                    , _keybindingsMode = NoOverlay
                    , _footerMode = FooterInfo
                    , _rootsFrom = DefaultRoots []
                    , _event_chan = eventChan
                    , _resultSize = Just 100
                    , _filters = []
                    , _asyncSamplingInterval = 1_000_000 {- 1 Second -}
                    , _version = ver
                    , _viewCache = emptyCache
                    , _navigator = newHistoryNavigator $ SomeSearchCmd DoGcRootsSearch
                    }
                )

            liftIO $ writeBChan eventChan $ DoSearch $ SomeSearchCmd DoGcRootsSearch

          _ -> return ()

        PausedMode os -> case brickEvent of
          _ -> case brickEvent of
              VtyEvent (Vty.EvKey (KEsc) _) | NoOverlay <- view keybindingsMode os
                                            , not (isFocusedFooter (view footerMode os)) -> do
                  case view running_task os of
                    Just task -> do
                      liftIO $ cancel task
                      put $ appState & majorState . mode . pausedMode . running_task .~ Nothing
                                     & majorState . mode . pausedMode %~ resetFooter
                    Nothing -> do
                      liftIO $ resume debuggee'
                      put $ initialAppState (_appChan appState)

              -- handle any other more local events; mostly key events
              _ -> liftHandler (majorState . mode) os PausedMode (handleMain debuggee') brickEvent

gcRootsTreeMode :: IOTree ClosureDetails Name -> TreeMode
gcRootsTreeMode = GcRoots renderClosureDetails

gcRootsIOTree :: Debuggee -> [ClosureDetails] -> IOTree ClosureDetails Name
gcRootsIOTree dbg closures =
  mkIOTree dbg closures getChildren renderInlineClosureDesc id

gcRootsAction :: Debuggee -> IO ([ClosureDetails], [(Text, Ptr)])
gcRootsAction dbg = do
  raw_roots <- take 1000 . map ("GC Roots",) <$> GD.rootClosures dbg
  rootClosures' <- mapM (completeClosureDetails dbg) raw_roots
  raw_saved <- map ("Saved Object",) <$> GD.savedClosures dbg
  savedClosures' <- mapM (completeClosureDetails dbg) raw_saved
  pure (savedClosures' <> rootClosures', fmap toPtr <$> (raw_roots ++ raw_saved))

updateListFrom :: MonadIO m =>
                        IO FilePath
                        -> GenericList n Seq.Seq SocketInfo
                        -> m (GenericList n Seq.Seq SocketInfo)
updateListFrom dirIO llist = liftIO $ do
            dir :: FilePath <- dirIO
            debuggeeSocketFiles :: [FilePath] <- listDirectory dir <|> return []

            -- Sort the sockets by the time they have been created, newest
            -- first.
            debuggeeSockets <- List.sortBy (comparing Ord.Down)
                                  <$> mapM (mkSocketInfo . (dir </>)) debuggeeSocketFiles

            let currentSelectedPathMay :: Maybe SocketInfo
                currentSelectedPathMay = fmap snd (listSelectedElement llist)

                newSelection :: Maybe Int
                newSelection = do
                  currentSelectedPath <- currentSelectedPathMay
                  List.findIndex ((currentSelectedPath ==)) debuggeeSockets

            return $ listReplace
                      (Seq.fromList debuggeeSockets)
                      (newSelection <|> (if Prelude.null debuggeeSockets then Nothing else Just 0))
                      llist

-- ----------------------------------------------------------------------------
-- Command & History ListPicker
-- ----------------------------------------------------------------------------

commandListPicker :: GD.Version -> ListPicker Name OperationalState Event Command
commandListPicker ver =
  ListPicker
    { _listPickerInput = newForm [(\w -> forceAttr inputAttr w) @@= editTextField id Overlay (Just 1)] ""
    , _listPickerElements = list CommandPicker_List commandList 1
    , _listPickerAllElements = commandList
    , _listPickerSelect = \ case
        cmd
          | isCmdDisabled ver cmd ->
            pure ListPicker.Unchanged
          | otherwise -> do
            dispatchCommand cmd
            pure ListPicker.Exit
    , _listPickerDescription = commandDescription
    , _listPickerRenderRow = Command.renderCommand ver
    , _listPickerLabel = "Command Picker"
    , _listPickerHighlightAttrName = highlightAttr
    }

historyListPicker :: HistoryNavigator SomeSearchCmd -> ListPicker Name OperationalState Event HistoryCommand
historyListPicker historyNav =
  ListPicker
    { _listPickerInput = newForm [(\w -> forceAttr inputAttr w) @@= editTextField id Overlay (Just 1)] ""
    , _listPickerElements = list HistoryPicker_List historyCommands 1
    , _listPickerAllElements = historyCommands
    , _listPickerSelect = \ cmd -> do
        historyCommandDispatch cmd
        pure ListPicker.Exit
    , _listPickerDescription = History.commandDescription
    , _listPickerRenderRow = History.commandWidget
    , _listPickerLabel = "History Picker"
    , _listPickerHighlightAttrName = highlightAttr
    }
  where
    historyCommands = Seq.fromList $ map HistoryCommand navStack
    navStack = navList historyNav

-- ----------------------------------------------------------------------------
-- Commands and Shortcut constants
-- ----------------------------------------------------------------------------

invertFilterEvent :: Vty.Event
invertFilterEvent = Vty.EvKey (KChar 'g') [Vty.MCtrl]

isInvertFilterEvent :: Vty.Event -> Bool
isInvertFilterEvent = (invertFilterEvent ==)

-- All the commands which we support, these show up in keybindings and also the command picker
commandList :: Seq.Seq Command
commandList = Seq.fromList
  [ mkCommand  "Show key bindings"            (Vty.EvKey (KChar '?') []) (modify $ keybindingsMode .~ KeybindingsShown)
  , mkCommand  "Clear filters"                     (withCtrlKey 'w') (modify clearFilters)
  , Command   "Search with current filters" (Just $ withCtrlKey 'f') doRetainerSearch NoReq
  , mkCommand  "Set search limit (default 100)"    (withCtrlKey 'l') (setFooterInputMode FSetResultSize)
  , mkCommand  "GC Roots"                          (withCtrlKey 's') (doSearch DoGcRootsSearch)
  , mkCommand  "Find Address"                      (withCtrlKey 'a') (setFooterInputMode (FClosureAddress True False))
  , mkCommand  "Find Info Table"                   (withCtrlKey 't') (setFooterInputMode (FInfoTableAddress True False))
  , mkCommand  "Find Retainers"                    (withCtrlKey 'e') (setFooterInputMode (FConstructorName True False))
  , mkCommand' "Find Retainers (Exact)"                              (setFooterInputMode (FClosureName True False))
  , mkFilterCmd "Find closures by era"             (withCtrlKey 'v') (setFooterInputMode (FFilterEras True False)) ReqErasProfiling
  , mkCommand  "Find Retainers of large ARR_WORDS" (withCtrlKey 'u') (setFooterInputMode FArrWordsSize)
  , mkCommand  "Dump ARR_WORDS payload"            (withCtrlKey 'j') (setFooterInputMode FDumpArrWords)
  , mkCommand  "Profile"                           (withCtrlKey 'b') (doSearch (DoProfileSearch OneLevel))
  , mkCommand' "Profile (2 level)"                                   (doSearch (DoProfileSearch TwoLevel))
  , Command    "Thunk Analysis"                    Nothing           (doSearch DoThunkSearch) NoReq
  , mkCommand  "Take Snapshot"                     (withCtrlKey 'x') (setFooterInputMode FSnapshot)
  , Command    "ARR_WORDS Count"                   Nothing           (doSearch DoArrWordsSearch) NoReq
  , Command    "Strings Count"                     Nothing           (doSearch DoStringSearch) NoReq
  , mkCommand' "Save View to file"                                   (setFooterInputMode FSaveTree)
  , mkCommand "Go to previous view"              (withAltKey KLeft)  (sendEvent $ NavigatorEvent GoOneBackwards)
  , mkCommand "Go to next view"                  (withAltKey KRight) (sendEvent $ NavigatorEvent GoOneForwards)
  , mkCommand "Show History"                     (withCtrlKey 'r')   (sendEvent $ NavigatorEvent GoOneForwards)
  ] <> addFilterCommands
  where
    doSearch = sendEvent . DoSearchWithHistoryPush . SomeSearchCmd

    doRetainerSearch = do
      os <- get
      doSearch $ DoRetainerSearch (os ^. resultSize) (os ^. filters)

    setFooterInputMode m = modify $ footerMode .~ footerInput m

    addFilterCommands ::  Seq.Seq Command
    addFilterCommands = Seq.fromList
      [ mkCommand'   "Add filter for address"             (setFooterInputMode (FClosureAddress False False))
      , mkCommand'   "Add filter for info table ptr"      (setFooterInputMode (FInfoTableAddress False False))
      , mkCommand'   "Add filter for constructor name"    (setFooterInputMode (FConstructorName False False))
      , mkCommand'   "Add filter for closure name"        (setFooterInputMode (FClosureName False False))
      , mkFilterCmd' "Add filter for era"                 (setFooterInputMode (FFilterEras False False)) ReqErasProfiling
      , mkFilterCmd' "Add filter for cost centre id"      (setFooterInputMode (FFilterCcId False False)) ReqSomeProfiling
      , mkCommand'   "Add filter for closure size"        (setFooterInputMode (FFilterClosureSize False))
      , mkCommand'   "Add filter for closure type"        (setFooterInputMode (FFilterClosureType False))
      , mkCommand'   "Add exclusion for address"          (setFooterInputMode (FClosureAddress False True))
      , mkCommand'   "Add exclusion for info table ptr"   (setFooterInputMode (FInfoTableAddress False True))
      , mkCommand'   "Add exclusion for constructor name" (setFooterInputMode (FConstructorName False True))
      , mkCommand'   "Add exclusion for closure name"     (setFooterInputMode (FClosureName False True))
      , mkFilterCmd' "Add exclusion for era"              (setFooterInputMode (FFilterEras False True)) ReqErasProfiling
      , mkFilterCmd' "Add exclusion for cost centre id"   (setFooterInputMode (FFilterCcId False True)) ReqSomeProfiling
      , mkCommand'   "Add exclusion for closure size"     (setFooterInputMode (FFilterClosureSize True))
      , mkCommand'   "Add exclusion for closure type"     (setFooterInputMode (FFilterClosureType True))
      ]

    withCtrlKey char = Vty.EvKey (KChar char) [Vty.MCtrl]
    withAltKey key = Vty.EvKey key [Vty.MMeta]

findCommand :: Vty.Event -> Maybe Command
findCommand event = do
  i <- Seq.findIndexL (\cmd -> commandKey cmd == Just event) commandList
  Seq.lookup i commandList