Render.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE GADTs #-}

module GHC.Debug.Brick.Render where

import Brick
import Brick.Widgets.Border
import Brick.Widgets.Center (centerLayer, hCenter)
import Brick.Widgets.List
import qualified Data.Foldable as F
import qualified Data.Sequence as Seq
import Data.Text (Text, pack)
import qualified Data.Text as T
import Data.Time.Format
import qualified Graphics.Vty as Vty
import Graphics.Vty.Input.Events (Key (..))
import Lens.Micro.Platform

import Brick.Widgets.IOTree
import GHC.Debug.Brick.Model as Model
import GHC.Debug.Brick.Render.Footer
import GHC.Debug.Brick.Render.Utils
import GHC.Debug.Brick.Update
import qualified Brick.Widgets.ListPicker as ListPicker
import GHC.Debug.Brick.Render.Command (renderCommandDesc)
import GHC.Debug.Brick.Render.Filter (renderUIFilter)

drawSetup :: Text -> Text -> GenericList Name Seq.Seq SocketInfo -> Widget Name
drawSetup herald other_herald vals =
      let nKnownDebuggees = Seq.length $ (vals ^. listElementsL)
      in mainBorder "ghc-debug" $ vBox
        [ hBox
          [ txt $ "Select a " <> herald <> " to debug (" <> pack (show nKnownDebuggees) <> " found):"
          ]
        , renderList
            (\elIsSelected socketPath -> (if elIsSelected then highlighted else id) $ hBox
                [ txt (socketName socketPath)
                , txt " - "
                , txt (renderSocketTime socketPath)
                ]
            )
            True
            vals
        , vLimit 1 $ withAttr menuAttr $ hBox [txt $ "(ESC): exit | (TAB): toggle " <> other_herald <> " view", fill ' ']
        ]

mainBorder :: Text -> Widget a -> Widget a
mainBorder title w = -- borderWithLabel (txt title) . padAll 1
  vLimit 1 (withAttr menuAttr $ hCenter $ fill ' ' <+> txt title <+> fill ' ') <=> w

myAppDraw :: AppState -> [Widget Name]
myAppDraw (AppState majorState' _) =
    case majorState' of

    Setup setupKind' dbgs snaps ->
      case setupKind' of
        Socket -> [drawSetup "process" "snapshots" dbgs]
        Snapshot -> [drawSetup "snapshot" "processes" snaps]


    Connected socket _debuggee mode' -> case mode' of

      RunningMode -> [mainBorder ("ghc-debug - Running - " <> socketName socket) $ vBox
        [ txtWrap "There is nothing you can do until the process is paused by pressing (p) ..."
        , fill ' '
        , withAttr menuAttr $ vLimit 1 $ hBox [txt "(p): Pause | (ESC): Exit", fill ' ']
        ]]

      PausedMode os -> let
           last_task_string =
            case os ^. last_run_time of
              Nothing -> ""
              Just (d,t) -> " - " <> d <> " (" <> T.pack (formatTime defaultTimeLocale "%2Es" t) <> "s)"

        in kbOverlay (os ^. keybindingsMode)
          $ [mainBorder ("ghc-debug - Paused - " <> socketName socket <> last_task_string) $ vBox
          [ -- Current closure details
              joinBorders $ (borderWithLabel (txt "Closure Details") $
              (vLimit 9 $
                pauseModeTree (\r io -> maybe emptyWidget r (ioTreeSelection io)) os
                <=> fill ' '))
              <+> (filterWindow $ os ^. filters)
          , -- Tree
            joinBorders $ borderWithLabel
              (txt $ case os ^. treeMode of
                GcRoots {} -> "Root Closures"
                Retainer {} -> "Retainers"
                Profile {} -> "Profile"
                Strings {} -> "Strings"
                ArrWords {} -> "ArrWords"
                Thunk {} -> "Thunks"
              )
              (pauseModeTree (\_ -> renderIOTree) os)
          , footer (osSize os) (_resultSize os) (os ^. footerMode)
          ]]

  where

  kbOverlay :: OverlayMode -> [Widget Name] -> [Widget Name]
  kbOverlay KeybindingsShown ws = centerLayer kbWindow : ws
  kbOverlay (CommandPicker picker) ws = centerLayer (withAttr menuAttr $ ListPicker.renderListPicker picker) : ws
  kbOverlay (HistoryPicker picker) ws  = centerLayer (withAttr menuAttr $ ListPicker.renderListPicker picker) : ws
  kbOverlay NoOverlay ws = ws

  filterWindow [] = emptyWidget
  filterWindow xs = borderWithLabel (txt "Filters") $ hLimit 50 $ vBox $ map renderUIFilter xs

  kbWindow :: Widget Name
  kbWindow =
    withAttr menuAttr $
    borderWithLabel (txt "Keybindings") $ vBox $
      map (renderCommandDesc actual_width) all_keys

  all_keys =
    [ ("Parent", Just (Vty.EvKey KLeft []))
    , ("Child", Just (Vty.EvKey KRight []))
    , ("Command Picker", Just (Vty.EvKey (Vty.KChar 'p') [Vty.MCtrl]))
    , ("Invert Filter", Just invertFilterEvent)]
    ++ [(commandDescription cmd, commandKey cmd) | cmd <- F.toList commandList ]
    ++ [ ("Exit", Just (Vty.EvKey KEsc [])) ]

  maximum_size = maximum (map (T.length . fst) all_keys)

  actual_width = maximum_size + 5  -- 5, maximum width of rendering a key
                              + 1  -- 1, at least one padding