mirror of
https://github.com/CrystalSplitter/ghcitui.git
synced 2024-09-11 10:55:29 +03:00
Clean up Daemon start up and messaging
This commit is contained in:
parent
e4ae716522
commit
bf93aeecda
@ -1,6 +1,6 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module AppConfig where
|
||||
module AppConfig (AppConfig(..), defaultConfig, resolveStartupSplashPath) where
|
||||
|
||||
import Data.Maybe (fromMaybe)
|
||||
import qualified Data.Text as T
|
||||
@ -29,6 +29,8 @@ data AppConfig = AppConfig
|
||||
-- ^ Prompt to show for the live interpreter.
|
||||
, getDebugConsoleOnStart :: !Bool
|
||||
-- ^ Display the debug console on start up.
|
||||
, getDebugLogPath :: !FilePath
|
||||
, getVerbosity :: !Int
|
||||
, getStartupSplashPath :: !(Maybe FilePath)
|
||||
, getCmd :: !T.Text
|
||||
-- ^ Command to run to initialise the interpreter.
|
||||
@ -41,6 +43,8 @@ defaultConfig =
|
||||
AppConfig
|
||||
{ getInterpreterPrompt = "ghci> "
|
||||
, getDebugConsoleOnStart = False
|
||||
, getDebugLogPath = ""
|
||||
, getVerbosity = 0
|
||||
, getStartupSplashPath = Nothing
|
||||
, getCmd = "cabal v2-repl --repl-options='-fno-it'"
|
||||
, getStartupCommands = mempty
|
||||
|
79
app/Main.hs
79
app/Main.hs
@ -1,5 +1,12 @@
|
||||
{-# LANGUAGE ApplicativeDo #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
module Main where
|
||||
|
||||
import qualified Paths_ghcitui as CabalPkg
|
||||
import qualified Data.Version
|
||||
|
||||
import Control.Applicative (many)
|
||||
import qualified Data.Text as T
|
||||
import qualified Options.Applicative as Opt
|
||||
|
||||
@ -8,7 +15,10 @@ import BrickUI (launchBrick)
|
||||
|
||||
-- | Holds passed in command line options.
|
||||
data CmdOptions = CmdOptions
|
||||
{ debugConsole :: !Bool
|
||||
{ version :: !Bool
|
||||
, debugConsole :: !Bool
|
||||
, verbosity :: !Int
|
||||
, debugLogPath :: !FilePath
|
||||
, cmd :: !T.Text
|
||||
, workdir :: !FilePath
|
||||
-- ^ Launch the TUI at this work directory.
|
||||
@ -18,43 +28,74 @@ data CmdOptions = CmdOptions
|
||||
deriving (Show, Eq)
|
||||
|
||||
parseOpts :: Opt.Parser CmdOptions
|
||||
parseOpts =
|
||||
CmdOptions
|
||||
<$> Opt.switch
|
||||
parseOpts = do
|
||||
version <- Opt.switch (Opt.long "version" <> Opt.help "Print the version number and exit")
|
||||
debugConsole <-
|
||||
Opt.switch
|
||||
( Opt.long "debug-console"
|
||||
<> Opt.short 'd'
|
||||
<> Opt.help "Display the debug console"
|
||||
)
|
||||
<*> Opt.strOption
|
||||
verbosity <-
|
||||
length <$> many (Opt.flag' () (Opt.short 'v' <> Opt.help verbosityHelp))
|
||||
debugLogPath <-
|
||||
Opt.strOption
|
||||
( Opt.long "daemon-log"
|
||||
<> Opt.help daemonLogHelp
|
||||
<> Opt.metavar "LOGFILE"
|
||||
<> Opt.value "/tmp/ghcitui.log"
|
||||
)
|
||||
cmd <-
|
||||
Opt.strOption
|
||||
( Opt.long "cmd"
|
||||
<> Opt.short 'c'
|
||||
<> Opt.metavar "CMD"
|
||||
<> Opt.help "Command to start the internal interpreter"
|
||||
<> Opt.value ""
|
||||
)
|
||||
<*> Opt.strOption
|
||||
workdir <-
|
||||
Opt.strOption
|
||||
( Opt.long "workdir"
|
||||
<> Opt.short 'C'
|
||||
<> Opt.metavar "DIR"
|
||||
<> Opt.help "Set working dir"
|
||||
<> Opt.value ""
|
||||
)
|
||||
<*> Opt.argument Opt.str (Opt.metavar "TARGET" <> Opt.value "")
|
||||
target <- Opt.argument Opt.str (Opt.metavar "TARGET" <> Opt.value "")
|
||||
pure CmdOptions{..}
|
||||
where
|
||||
verbosityHelp =
|
||||
"Set verbosity for output logs."
|
||||
<> " Pass multiple times (e.g -vvv) to increase the logging."
|
||||
<> " Use --daemon-log to specify where the logs go."
|
||||
daemonLogHelp =
|
||||
"File path for debugging daemon logs."
|
||||
<> " Used with -v."
|
||||
<> " Setting this to 'stdout' or 'stderr' sends logs to each, respectively."
|
||||
<> " Defaults to /tmp/ghcitui.log."
|
||||
|
||||
-- | The cabal package version.
|
||||
programVersion :: String
|
||||
programVersion = Data.Version.showVersion CabalPkg.version
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
opts <- Opt.execParser parserInfo
|
||||
let conf =
|
||||
defConf
|
||||
{ AppConfig.getDebugConsoleOnStart = debugConsole opts
|
||||
, AppConfig.getCmd =
|
||||
if T.null $ cmd opts
|
||||
then AppConfig.getCmd defConf
|
||||
else cmd opts
|
||||
}
|
||||
launchBrick conf (target opts) (workdir opts)
|
||||
if version opts
|
||||
then do
|
||||
putStrLn $ programName <> " " <> programVersion
|
||||
else do
|
||||
let conf =
|
||||
AppConfig.defaultConfig
|
||||
{ AppConfig.getDebugConsoleOnStart = debugConsole opts
|
||||
, AppConfig.getVerbosity = verbosity opts
|
||||
, AppConfig.getDebugLogPath = debugLogPath opts
|
||||
, AppConfig.getCmd =
|
||||
if T.null $ cmd opts
|
||||
then AppConfig.getCmd AppConfig.defaultConfig
|
||||
else cmd opts
|
||||
}
|
||||
launchBrick conf (target opts) (workdir opts)
|
||||
where
|
||||
programName = "ghcitui"
|
||||
programDescription = Opt.progDesc (programName <> ": A TUI interface for GHCi")
|
||||
parserInfo = Opt.info (Opt.helper <*> parseOpts) (Opt.fullDesc <> programDescription)
|
||||
defConf = AppConfig.defaultConfig
|
||||
parserInfo = Opt.info (Opt.helper <*> parseOpts) (Opt.fullDesc <> programDescription)
|
@ -10,6 +10,7 @@ description:
|
||||
* A source view window, with debug keybindings.
|
||||
* Live variable bindings.
|
||||
* Live loaded modules.
|
||||
* Visible trace history.
|
||||
* An GHCi session in the current context.
|
||||
|
||||
bug-reports: https://github.com/CrystalSplitter/ghcitui
|
||||
@ -22,6 +23,8 @@ maintainer: gamewhizzit@gmail.com
|
||||
category: Debug
|
||||
extra-source-files: CHANGELOG.md
|
||||
, LICENSE
|
||||
, MANUAL.rst
|
||||
, README.md
|
||||
|
||||
source-repository head
|
||||
type: git
|
||||
@ -50,6 +53,8 @@ executable ghcitui
|
||||
, AppConfig
|
||||
, Events
|
||||
, HelpText
|
||||
-- Cabal autogen module for package version info.
|
||||
, Paths_ghcitui
|
||||
ghc-options: -rtsopts
|
||||
-threaded
|
||||
-Wall
|
||||
@ -70,7 +75,7 @@ library ghcitui-lib
|
||||
hs-source-dirs: lib
|
||||
build-depends: base >= 4.17 && < 5
|
||||
, array ^>= 0.5.4.0
|
||||
, containers ^>= 0.6.7
|
||||
, containers >= 0.6.7 && < 0.8
|
||||
, errors ^>= 2.3.0
|
||||
, ghcid ^>= 0.8.8
|
||||
, regex-base ^>= 0.94.0.2
|
||||
@ -81,9 +86,11 @@ library ghcitui-lib
|
||||
, transformers ^>= 0.6.1.0
|
||||
exposed-modules: Ghcitui.Ghcid.Daemon
|
||||
, Ghcitui.Ghcid.ParseContext
|
||||
, Ghcitui.Ghcid.LogConfig
|
||||
, Ghcitui.Loc
|
||||
, Ghcitui.Util
|
||||
, Ghcitui.NameBinding
|
||||
other-modules: Ghcitui.Ghcid.StartupConfig
|
||||
ghc-options: -Wall
|
||||
-Wcompat
|
||||
-Wincomplete-record-updates
|
||||
|
@ -19,6 +19,7 @@ module Ghcitui.Ghcid.Daemon
|
||||
|
||||
-- * Startup and shutdown
|
||||
, startup
|
||||
, StartupConfig(..)
|
||||
, quit
|
||||
|
||||
-- * Base operations with the daemon
|
||||
@ -49,6 +50,7 @@ module Ghcitui.Ghcid.Daemon
|
||||
, run
|
||||
, DaemonIO
|
||||
, DaemonError
|
||||
, LogOutput(..)
|
||||
) where
|
||||
|
||||
import Control.Error
|
||||
@ -65,11 +67,9 @@ import qualified Ghcitui.Loc as Loc
|
||||
import qualified Ghcitui.NameBinding as NameBinding
|
||||
import Ghcitui.Util (showT)
|
||||
import qualified Ghcitui.Util as Util
|
||||
|
||||
newtype LogLevel = LogLevel Int deriving (Eq, Ord, Show)
|
||||
|
||||
-- | Determines where the daemon logs are written.
|
||||
data LogOutput = LogOutputStdOut | LogOutputStdErr | LogOutputFile FilePath
|
||||
import Ghcitui.Ghcid.LogConfig (LogLevel(..), LogOutput(..))
|
||||
import Ghcitui.Ghcid.StartupConfig (StartupConfig)
|
||||
import qualified Ghcitui.Ghcid.StartupConfig as StartupConfig
|
||||
|
||||
data InterpState a = InterpState
|
||||
{ _ghci :: Ghcid.Ghci
|
||||
@ -113,8 +113,8 @@ instance Show (InterpState a) where
|
||||
{- | Create an empty/starting interpreter state.
|
||||
Usually you don't want to call this directly. Instead use 'startup'.
|
||||
-}
|
||||
emptyInterpreterState :: (Monoid a) => Ghcid.Ghci -> InterpState a
|
||||
emptyInterpreterState ghci =
|
||||
emptyInterpreterState :: (Monoid a) => Ghcid.Ghci -> StartupConfig -> InterpState a
|
||||
emptyInterpreterState ghci startupConfig =
|
||||
InterpState
|
||||
{ _ghci = ghci
|
||||
, func = Nothing
|
||||
@ -124,12 +124,23 @@ emptyInterpreterState ghci =
|
||||
, breakpoints = mempty
|
||||
, bindings = Right mempty
|
||||
, status = Right mempty
|
||||
, logLevel = LogLevel 3
|
||||
, logOutput = LogOutputFile "/tmp/ghcitui.log"
|
||||
, logLevel = StartupConfig.logLevel startupConfig
|
||||
, logOutput = StartupConfig.logOutput startupConfig
|
||||
, execHist = mempty
|
||||
, traceHist = mempty
|
||||
}
|
||||
|
||||
-- | Reset anything context-based in a 'InterpState'.
|
||||
contextReset :: (Monoid a) => InterpState a -> InterpState a
|
||||
contextReset state = state {
|
||||
func = Nothing
|
||||
, pauseLoc = Nothing
|
||||
, stack = mempty
|
||||
, bindings = Right mempty
|
||||
, status = Right mempty
|
||||
, traceHist = mempty
|
||||
}
|
||||
|
||||
-- | Append a string to the interpreter's history.
|
||||
appendExecHist :: T.Text -> InterpState a -> InterpState a
|
||||
appendExecHist cmd s@InterpState{execHist} = s{execHist = cmd : execHist}
|
||||
@ -145,12 +156,18 @@ startup
|
||||
-- ^ Command to run (e.g. "ghci" or "cabal repl")
|
||||
-> FilePath
|
||||
-- ^ Working directory to run the start up command in.
|
||||
-> StartupConfig
|
||||
-- ^ Where do we put the logging?
|
||||
-> DaemonIO (InterpState ())
|
||||
-- ^ The newly created interpreter handle.
|
||||
startup cmd pwd = do
|
||||
let startOp = Ghcid.startGhci cmd (Just pwd) (\_ _ -> pure ())
|
||||
startup cmd wd logOutput = do
|
||||
-- We don't want any highlighting or colours.
|
||||
let realCmd = "env TERM='dumb' " <> cmd
|
||||
let startOp = Ghcid.startGhci realCmd (Just wd) (\_ _ -> pure ())
|
||||
(ghci, _) <- liftIO startOp
|
||||
updateState (emptyInterpreterState ghci)
|
||||
let state = emptyInterpreterState ghci logOutput
|
||||
logDebug "|startup| GHCi Daemon initted" state
|
||||
updateState state
|
||||
|
||||
-- | Shut down the GHCi Daemon.
|
||||
quit :: InterpState a -> IO (InterpState a)
|
||||
@ -187,12 +204,12 @@ updateContext state@InterpState{_ghci} = do
|
||||
)
|
||||
state
|
||||
if T.null feedback
|
||||
then pure (emptyInterpreterState _ghci) -- We exited everything.
|
||||
then pure $ contextReset state -- We exited everything.
|
||||
else do
|
||||
let ctx = ParseContext.parseContext feedback
|
||||
case ctx of
|
||||
ParseContext.PCError er -> error [i|Failed to update context: #{er}|]
|
||||
ParseContext.PCNoContext -> pure (emptyInterpreterState _ghci)
|
||||
ParseContext.PCNoContext -> pure $ contextReset state
|
||||
ParseContext.PCContext
|
||||
ParseContext.ParseContextOut{func, filepath, pcSourceRange} ->
|
||||
pure
|
||||
@ -292,7 +309,7 @@ exec :: (Monoid a) => T.Text -> InterpState a -> ExceptT DaemonError IO (InterpS
|
||||
exec cmd state@InterpState{_ghci} = do
|
||||
logDebug ("|exec| CMD: " <> cmd) state
|
||||
msgs <- liftIO $ Ghcid.exec _ghci (T.unpack cmd)
|
||||
logDebug [i|{|exec| OUT:\n#{Util.linesToText msgs}\n}|] state
|
||||
logDebug [i||exec| OUT:\n#{Util.linesToText msgs}\n|] state
|
||||
newState <-
|
||||
updateState
|
||||
( -- Only append the command to the history if it has something interesting.
|
||||
@ -367,7 +384,7 @@ setBreakpointLine loc state = do
|
||||
then
|
||||
throwE
|
||||
(BreakpointError "Cannot set breakpoint at unknown line number")
|
||||
else pure (mod' <> " " <> line <> " " <> colno)
|
||||
else pure [i|#{mod'} #{line} #{colno}|]
|
||||
pure (":break " <> breakPos)
|
||||
|
||||
-- | Delete a breakpoint at a given line.
|
||||
@ -447,12 +464,12 @@ getBpInFile fp state =
|
||||
logDebug :: (MonadIO m) => T.Text -> InterpState a -> m ()
|
||||
logDebug msg state =
|
||||
liftIO $ do
|
||||
when (logLevel state >= LogLevel 3) $
|
||||
when (logLevel state >= LogLevel 2) $
|
||||
logHelper output "[DEBUG]: " msg
|
||||
where
|
||||
output = logOutput state
|
||||
|
||||
-- | Log a message at the Error level.
|
||||
{- Log a message at the Error level.
|
||||
logError :: (MonadIO m) => T.Text -> InterpState a -> m ()
|
||||
logError msg state =
|
||||
liftIO $ do
|
||||
@ -460,6 +477,7 @@ logError msg state =
|
||||
logHelper output "[ERROR]: " msg
|
||||
where
|
||||
output = logOutput state
|
||||
-}
|
||||
|
||||
logHelper
|
||||
:: (MonadIO m)
|
||||
|
7
lib/Ghcitui/Ghcid/LogConfig.hs
Normal file
7
lib/Ghcitui/Ghcid/LogConfig.hs
Normal file
@ -0,0 +1,7 @@
|
||||
module Ghcitui.Ghcid.LogConfig where
|
||||
|
||||
-- | Determines how verbose logging should be.
|
||||
newtype LogLevel = LogLevel Int deriving (Eq, Ord, Show)
|
||||
|
||||
-- | Determines where the daemon logs are written.
|
||||
data LogOutput = LogOutputStdOut | LogOutputStdErr | LogOutputFile FilePath deriving (Show)
|
9
lib/Ghcitui/Ghcid/StartupConfig.hs
Normal file
9
lib/Ghcitui/Ghcid/StartupConfig.hs
Normal file
@ -0,0 +1,9 @@
|
||||
module Ghcitui.Ghcid.StartupConfig where
|
||||
|
||||
import Ghcitui.Ghcid.LogConfig (LogLevel, LogOutput)
|
||||
|
||||
-- | Configuration passed during Daemon 'startup'
|
||||
data StartupConfig = StartupConfig
|
||||
{ logLevel :: !LogLevel
|
||||
, logOutput :: !LogOutput
|
||||
}
|
Loading…
Reference in New Issue
Block a user