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