mirror of
https://github.com/CrystalSplitter/ghcitui.git
synced 2024-08-16 14:40:48 +03:00
Module box + more
This commit is contained in:
parent
ea7d9cc403
commit
52a2f3c11c
@ -2,14 +2,14 @@
|
||||
|
||||
module AppConfig where
|
||||
|
||||
import Data.Maybe
|
||||
import Data.Text (Text)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import qualified Data.Text as T
|
||||
import System.Environment (lookupEnv)
|
||||
|
||||
userConfigDir :: IO FilePath
|
||||
userConfigDir = fromMaybe (error errorMsg) <$> result
|
||||
where
|
||||
innerLift accA xA = do
|
||||
chooseNonEmpty accA xA = do
|
||||
a <- accA
|
||||
if a == mempty
|
||||
then xA
|
||||
@ -17,7 +17,7 @@ userConfigDir = fromMaybe (error errorMsg) <$> result
|
||||
errorMsg = "Cannot set config location. Neither XDG_CONFIG_HOME nor HOME values were set."
|
||||
result =
|
||||
foldr
|
||||
innerLift
|
||||
chooseNonEmpty
|
||||
mempty
|
||||
[lookupEnv "XDG_CONFIG_HOME", fmap (fmap (<> "/.config")) (lookupEnv "HOME")]
|
||||
|
||||
@ -25,13 +25,15 @@ defaultSplashPath :: IO FilePath
|
||||
defaultSplashPath = fmap (<> "/ghcitui/assets/splash") userConfigDir
|
||||
|
||||
data AppConfig = AppConfig
|
||||
{ getInterpreterPrompt :: !Text
|
||||
{ getInterpreterPrompt :: !T.Text
|
||||
-- ^ Prompt to show for the live interpreter.
|
||||
, getDebugConsoleOnStart :: !Bool
|
||||
-- ^ Display the debug console on start up.
|
||||
, getStartupSplashPath :: !(Maybe FilePath)
|
||||
, getCmd :: !Text
|
||||
, getStartupCommands :: ![Text]
|
||||
, getCmd :: !T.Text
|
||||
-- ^ Command to run to initialise the interpreter.
|
||||
, getStartupCommands :: ![T.Text]
|
||||
-- ^ Commands to run in ghci during start up.
|
||||
}
|
||||
|
||||
defaultConfig :: AppConfig
|
||||
@ -40,7 +42,7 @@ defaultConfig =
|
||||
{ getInterpreterPrompt = "ghci> "
|
||||
, getDebugConsoleOnStart = False
|
||||
, getStartupSplashPath = Nothing
|
||||
, getCmd = "cabal v2-repl"
|
||||
, getCmd = "cabal v2-repl --repl-options='-fno-it'"
|
||||
, getStartupCommands = mempty
|
||||
}
|
||||
|
||||
|
@ -1,18 +1,18 @@
|
||||
module AppInterpState (
|
||||
AppInterpState (..),
|
||||
commandBuffer,
|
||||
emptyAppInterpState,
|
||||
futHistoryPos,
|
||||
history,
|
||||
isScanningHist,
|
||||
liveEditor,
|
||||
pastHistoryPos,
|
||||
pushHistory,
|
||||
viewLock,
|
||||
) where
|
||||
module AppInterpState
|
||||
( AppInterpState (_liveEditor, _viewLock, _commandBuffer, historyPos)
|
||||
, commandBuffer
|
||||
, emptyAppInterpState
|
||||
, futHistoryPos
|
||||
, history
|
||||
, isScanningHist
|
||||
, liveEditor
|
||||
, pastHistoryPos
|
||||
, pushHistory
|
||||
, viewLock
|
||||
) where
|
||||
|
||||
import qualified Brick.Widgets.Edit as BE
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Lens.Micro as Lens
|
||||
|
||||
data AppInterpState s n = AppInterpState
|
||||
@ -25,18 +25,19 @@ data AppInterpState s n = AppInterpState
|
||||
|
||||
-- | Lens accessor for the editor.
|
||||
liveEditor :: Lens.Lens' (AppInterpState s n) (BE.Editor s n)
|
||||
liveEditor = Lens.lens _liveEditor (\ais le -> ais { _liveEditor = le })
|
||||
liveEditor = Lens.lens _liveEditor (\ais le -> ais{_liveEditor = le})
|
||||
|
||||
-- | Lens for the view lock setting
|
||||
viewLock :: Lens.Lens' (AppInterpState s n) Bool
|
||||
viewLock = Lens.lens _viewLock (\ais x -> ais { _viewLock = x })
|
||||
viewLock = Lens.lens _viewLock (\ais x -> ais{_viewLock = x})
|
||||
|
||||
commandBuffer :: Lens.Lens' (AppInterpState s n) [s]
|
||||
commandBuffer = Lens.lens _commandBuffer (\ais x -> ais { _commandBuffer = x })
|
||||
commandBuffer = Lens.lens _commandBuffer (\ais x -> ais{_commandBuffer = x})
|
||||
|
||||
history :: AppInterpState s n -> [[s]]
|
||||
history = _history
|
||||
|
||||
emptyAppInterpState :: n -> AppInterpState Text n
|
||||
emptyAppInterpState :: n -> AppInterpState T.Text n
|
||||
emptyAppInterpState name =
|
||||
AppInterpState
|
||||
{ _liveEditor = initInterpWidget name (Just 1)
|
||||
@ -46,6 +47,9 @@ emptyAppInterpState name =
|
||||
, historyPos = 0
|
||||
}
|
||||
|
||||
resetHistoryPos :: AppInterpState s n -> AppInterpState s n
|
||||
resetHistoryPos s = s{historyPos = 0}
|
||||
|
||||
-- | Move interpreter history back.
|
||||
pastHistoryPos :: AppInterpState s n -> AppInterpState s n
|
||||
pastHistoryPos s@AppInterpState{..} =
|
||||
@ -61,9 +65,9 @@ isScanningHist AppInterpState{..} = historyPos /= 0
|
||||
futHistoryPos :: AppInterpState s n -> AppInterpState s n
|
||||
futHistoryPos s@AppInterpState{..} = s{historyPos = max 0 $ pred historyPos}
|
||||
|
||||
-- | Push a new value on to the history stack.
|
||||
-- | Push a new value on to the history stack and reset the position.
|
||||
pushHistory :: [s] -> AppInterpState s n -> AppInterpState s n
|
||||
pushHistory cmdLines s = s {_history = cmdLines : history s}
|
||||
pushHistory cmdLines s = resetHistoryPos $ s{_history = cmdLines : history s}
|
||||
|
||||
-- | Create the initial live interpreter widget object.
|
||||
initInterpWidget
|
||||
@ -71,5 +75,5 @@ initInterpWidget
|
||||
-- ^ Editor name (must be a unique identifier).
|
||||
-> Maybe Int
|
||||
-- ^ Line height of the editor. Nothing for unlimited.
|
||||
-> BE.Editor Text n
|
||||
-> BE.Editor T.Text n
|
||||
initInterpWidget name height = BE.editorText name height mempty
|
||||
|
106
app/AppState.hs
106
app/AppState.hs
@ -4,39 +4,41 @@ module AppState
|
||||
( ActiveWindow (..)
|
||||
, AppConfig (..)
|
||||
, AppState (..)
|
||||
, appInterpState
|
||||
, getSourceContents
|
||||
, updateSourceMap
|
||||
, resetSelectedLine
|
||||
, getSourceLineCount
|
||||
, listAvailableSources
|
||||
, liveEditor'
|
||||
, makeInitialState
|
||||
, resetSelectedLine
|
||||
, toggleActiveLineInterpreter
|
||||
, toggleBreakpointLine
|
||||
, appInterpState
|
||||
, liveEditor'
|
||||
, updateSourceMap
|
||||
, writeDebugLog
|
||||
, WindowSizes
|
||||
) where
|
||||
|
||||
import AppConfig (AppConfig (..), resolveStartupSplashPath)
|
||||
import qualified AppInterpState as AIS
|
||||
import qualified Brick.Widgets.Edit as BE
|
||||
import Control.Exception (SomeException, catch, try, IOException)
|
||||
import Control.Error (fromMaybe, lastMay)
|
||||
import Control.Exception (IOException, SomeException, catch, try)
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.IO as T
|
||||
import qualified Lens.Micro as Lens
|
||||
|
||||
import AppConfig (AppConfig (..), resolveStartupSplashPath)
|
||||
import qualified AppInterpState as AIS
|
||||
import AppTopLevel (AppName (..))
|
||||
import Ghcid.Daemon (toggleBreakpointLine)
|
||||
import qualified Ghcid.Daemon as Daemon
|
||||
import qualified Loc
|
||||
import qualified Loc
|
||||
|
||||
data ActiveWindow = ActiveCodeViewport | ActiveLiveInterpreter | ActiveInfoWindow
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
-- | Size information of the current GHCiDTUI main boxes.
|
||||
{- | Size information of the current GHCiDTUI main boxes.
|
||||
type WindowSizes = [(ActiveWindow, (Maybe Int, Maybe Int))]
|
||||
-}
|
||||
|
||||
-- | Application state wrapper
|
||||
data AppState n = AppState
|
||||
@ -44,38 +46,47 @@ data AppState n = AppState
|
||||
-- ^ The interpreter handle.
|
||||
, getCurrentWorkingDir :: !FilePath
|
||||
-- ^ The current working directory.
|
||||
, _appInterpState :: AIS.AppInterpState Text n
|
||||
, _appInterpState :: AIS.AppInterpState T.Text n
|
||||
-- ^ The live interpreter state (separate from the interpreter
|
||||
-- and the app state itself.
|
||||
, interpLogs :: ![Text]
|
||||
, appConfig :: !AppConfig
|
||||
-- ^ Program launch configuration.
|
||||
, activeWindow :: ActiveWindow
|
||||
, activeWindow :: !ActiveWindow
|
||||
-- ^ Currently active window.
|
||||
, selectedFile :: Maybe FilePath
|
||||
, selectedFile :: !(Maybe FilePath)
|
||||
-- ^ Filepath to the current code viewport contents, if set.
|
||||
, selectedLine :: Int
|
||||
, selectedLine :: !Int
|
||||
-- ^ Currently selected line number. Resets back to 1.
|
||||
, sourceMap :: Map.Map FilePath Text
|
||||
, sourceMap :: Map.Map FilePath T.Text
|
||||
-- ^ Mapping between source filepaths and their contents.
|
||||
, displayDebugConsoleLogs :: Bool
|
||||
, displayDebugConsoleLogs :: !Bool
|
||||
-- ^ Whether to display debug Console logs.
|
||||
, debugConsoleLogs :: [Text]
|
||||
-- ^ Place for debug output to go.
|
||||
, splashContents :: !(Maybe Text)
|
||||
, splashContents :: !(Maybe T.Text)
|
||||
-- ^ Splash to show on start up.
|
||||
}
|
||||
|
||||
newtype AppStateA m a = AppStateA {runAppStateA :: m a}
|
||||
|
||||
instance (Functor m) => Functor (AppStateA m) where
|
||||
fmap f appStateA = AppStateA (f <$> runAppStateA appStateA)
|
||||
|
||||
instance (Applicative m) => Applicative (AppStateA m) where
|
||||
pure appState = AppStateA (pure appState)
|
||||
(<*>) = undefined
|
||||
|
||||
-- | Lens for the App's interpreter box.
|
||||
appInterpState :: Lens.Lens' (AppState n) (AIS.AppInterpState Text n)
|
||||
appInterpState :: Lens.Lens' (AppState n) (AIS.AppInterpState T.Text n)
|
||||
appInterpState = Lens.lens _appInterpState (\x ais -> x{_appInterpState = ais})
|
||||
|
||||
-- | Lens wrapper for zooming with handleEditorEvent.
|
||||
liveEditor' :: Lens.Lens' (AppState n) (BE.Editor Text n)
|
||||
liveEditor' :: Lens.Lens' (AppState n) (BE.Editor T.Text n)
|
||||
liveEditor' = appInterpState . AIS.liveEditor
|
||||
|
||||
-- | Write a debug log entry.
|
||||
writeDebugLog :: Text -> AppState n -> AppState n
|
||||
writeDebugLog :: T.Text -> AppState n -> AppState n
|
||||
writeDebugLog lg s = s{debugConsoleLogs = lg : debugConsoleLogs s}
|
||||
|
||||
toggleActiveLineInterpreter :: AppState n -> AppState n
|
||||
@ -85,20 +96,27 @@ toggleActiveLineInterpreter s@AppState{activeWindow} =
|
||||
toggleLogic ActiveLiveInterpreter = ActiveCodeViewport
|
||||
toggleLogic _ = ActiveLiveInterpreter
|
||||
|
||||
-- | Reset the code viewport selected line.
|
||||
-- | Reset the code viewport selected line to the pause location.
|
||||
resetSelectedLine :: AppState n -> AppState n
|
||||
resetSelectedLine s@AppState{interpState} = s{selectedFile, selectedLine}
|
||||
resetSelectedLine s@AppState{interpState} =
|
||||
s{selectedFile = ourSelectedFile, selectedLine = ourSelectedLine}
|
||||
where
|
||||
selectedLine :: Int
|
||||
selectedLine = fromMaybe 1 (Loc.startLine . Loc.fSourceRange =<< interpState.pauseLoc)
|
||||
selectedFile = Loc.filepath <$> interpState.pauseLoc
|
||||
ourSelectedLine :: Int
|
||||
ourSelectedLine =
|
||||
fromMaybe
|
||||
(selectedLine s)
|
||||
(Loc.startLine . Loc.fSourceRange =<< interpState.pauseLoc)
|
||||
ourSelectedFile = maybe (selectedFile s) (Just . Loc.filepath) interpState.pauseLoc
|
||||
|
||||
-- | Update the source map given any app state changes.
|
||||
updateSourceMap :: AppState n -> IO (AppState n)
|
||||
updateSourceMap s =
|
||||
case s.interpState.pauseLoc of
|
||||
updateSourceMap s = do
|
||||
s' <- case selectedFile s of
|
||||
Just sf -> updateSourceMapWithFilepath s sf
|
||||
Nothing -> pure s
|
||||
(Just (Loc.FileLoc{filepath})) -> updateSourceMapWithFilepath s filepath
|
||||
case s'.interpState.pauseLoc of
|
||||
Nothing -> pure s'
|
||||
(Just (Loc.FileLoc{filepath})) -> updateSourceMapWithFilepath s' filepath
|
||||
|
||||
-- | Update the source map with a given filepath.
|
||||
updateSourceMapWithFilepath :: AppState n -> FilePath -> IO (AppState n)
|
||||
@ -114,15 +132,24 @@ updateSourceMapWithFilepath s filepath
|
||||
let newSourceMap = Map.insert filepath contents s.sourceMap
|
||||
pure s{sourceMap = newSourceMap}
|
||||
|
||||
listAvailableSources :: AppState n -> [(T.Text, FilePath)]
|
||||
listAvailableSources = Loc.moduleFileMapAssocs . Daemon.moduleFileMap . interpState
|
||||
|
||||
-- | Return the potential contents of the current paused file location.
|
||||
getSourceContents :: AppState n -> Maybe Text
|
||||
getSourceContents :: AppState n -> Maybe T.Text
|
||||
getSourceContents s = s.selectedFile >>= (s.sourceMap Map.!?)
|
||||
|
||||
{- | Return the number of lines in the current source viewer.
|
||||
Returns Nothing if there's no currently viewed source.
|
||||
-}
|
||||
getSourceLineCount :: AppState n -> Maybe Int
|
||||
getSourceLineCount s = length . T.lines <$> getSourceContents s
|
||||
|
||||
-- | Initialise the state from the config.
|
||||
makeInitialState
|
||||
:: AppConfig
|
||||
-- ^ Start up config.
|
||||
-> Text
|
||||
-> T.Text
|
||||
-- ^ Daemon command prefix.
|
||||
-> FilePath
|
||||
-- ^ Workding directory.
|
||||
@ -136,18 +163,27 @@ makeInitialState appConfig target cwd = do
|
||||
(Just <$> (T.readFile =<< resolveStartupSplashPath appConfig))
|
||||
-- The splash is never critical.
|
||||
-- Just put nothing there if we can't find it.
|
||||
(const (pure Nothing) :: SomeException -> IO (Maybe Text))
|
||||
pure
|
||||
(const (pure Nothing) :: SomeException -> IO (Maybe T.Text))
|
||||
let selectedFile =
|
||||
case Loc.moduleFileMapAssocs (Daemon.moduleFileMap interpState) of
|
||||
-- If we just have one file, select that.
|
||||
[(_, filepath)] -> Just filepath
|
||||
-- If we have no module/file mappings, nothing must be selected.
|
||||
[] -> Nothing
|
||||
-- If we don't have a selected file, but we have a module loaded,
|
||||
-- select the last one.
|
||||
xs -> fmap snd (lastMay xs)
|
||||
updateSourceMap
|
||||
AppState
|
||||
{ interpState
|
||||
, getCurrentWorkingDir = cwd'
|
||||
, _appInterpState = AIS.emptyAppInterpState LiveInterpreter
|
||||
, activeWindow = ActiveCodeViewport
|
||||
, activeWindow = ActiveLiveInterpreter
|
||||
, appConfig
|
||||
, debugConsoleLogs = mempty
|
||||
, displayDebugConsoleLogs = getDebugConsoleOnStart appConfig
|
||||
, interpLogs = mempty
|
||||
, selectedFile = Nothing
|
||||
, selectedFile
|
||||
, selectedLine = 1
|
||||
, sourceMap = mempty
|
||||
, splashContents
|
||||
|
384
app/BrickUI.hs
384
app/BrickUI.hs
@ -11,14 +11,12 @@ import qualified Brick.Widgets.Border as B
|
||||
import qualified Brick.Widgets.Center as B
|
||||
import Brick.Widgets.Core ((<+>), (<=>))
|
||||
import qualified Brick.Widgets.Edit as BE
|
||||
import Control.Error.Util (note)
|
||||
import Control.Monad.IO.Class (MonadIO (..))
|
||||
import Control.Error (headMay)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Zipper as Zipper
|
||||
import qualified Graphics.Vty as V
|
||||
import Lens.Micro as Lens
|
||||
import Safe (atDef, headMay, lastDef)
|
||||
import Lens.Micro ((&), (<&>), (^.))
|
||||
import qualified Text.Wrap as Wrap
|
||||
|
||||
import qualified AppConfig
|
||||
import qualified AppInterpState as AIS
|
||||
@ -29,16 +27,12 @@ import AppState
|
||||
, getSourceContents
|
||||
, liveEditor'
|
||||
, makeInitialState
|
||||
, resetSelectedLine
|
||||
, toggleActiveLineInterpreter
|
||||
, updateSourceMap
|
||||
, writeDebugLog
|
||||
)
|
||||
import AppTopLevel (AppName (..))
|
||||
import qualified Events
|
||||
import qualified Ghcid.Daemon as Daemon
|
||||
import qualified Loc
|
||||
import qualified NameBinding
|
||||
import Util (showT)
|
||||
import qualified Util
|
||||
|
||||
-- | Alias for 'AppState AppName' convenience.
|
||||
@ -48,16 +42,13 @@ appDraw :: AppS -> [B.Widget AppName]
|
||||
appDraw s =
|
||||
[ (viewportBox <=> interpreterBox <=> debugBox)
|
||||
-- TODO: Make this an expandable viewport, maybe?
|
||||
<+> infoBox
|
||||
<+> infoBox s
|
||||
]
|
||||
where
|
||||
sourceLabel =
|
||||
markLabel
|
||||
(s.activeWindow == ActiveCodeViewport)
|
||||
( "Source: "
|
||||
<> case s.interpState.pauseLoc of
|
||||
Nothing -> "?"
|
||||
Just loc -> T.pack (Loc.filepath loc)
|
||||
( "Source: " <> maybe "?" T.pack s.selectedFile
|
||||
)
|
||||
interpreterLabel =
|
||||
markLabel
|
||||
@ -67,6 +58,7 @@ appDraw s =
|
||||
else "Interpreter (Scrolling)"
|
||||
)
|
||||
|
||||
viewportBox :: B.Widget AppName
|
||||
viewportBox =
|
||||
B.borderWithLabel sourceLabel
|
||||
. appendLastCommand
|
||||
@ -80,6 +72,7 @@ appDraw s =
|
||||
Just h -> B.padBottom B.Max (w <=> B.hBorder <=> B.txt h)
|
||||
_ -> w
|
||||
|
||||
interpreterBox :: B.Widget AppName
|
||||
interpreterBox =
|
||||
B.borderWithLabel interpreterLabel
|
||||
. B.vLimit (displayLimit + 1) -- Plus one for the current line.
|
||||
@ -89,45 +82,69 @@ appDraw s =
|
||||
where
|
||||
enableCursor = True
|
||||
displayLimit = 10
|
||||
displayF t = B.vBox $ B.txt <$> t
|
||||
previousOutput =
|
||||
if not (null s.interpLogs)
|
||||
then
|
||||
if null s.interpLogs
|
||||
then B.emptyWidget
|
||||
else
|
||||
B.txt
|
||||
. T.unlines
|
||||
. reverse
|
||||
$ s.interpLogs
|
||||
else B.emptyWidget
|
||||
promptLine :: B.Widget AppName
|
||||
promptLine =
|
||||
B.txt s.appConfig.getInterpreterPrompt
|
||||
<+> BE.renderEditor displayF enableCursor (s ^. liveEditor')
|
||||
where
|
||||
displayF :: [T.Text] -> B.Widget AppName
|
||||
displayF t = B.vBox $ B.txt <$> t
|
||||
lockToBottomOnViewLock w =
|
||||
if s ^. appInterpState . AIS.viewLock
|
||||
then B.visible w
|
||||
else w
|
||||
|
||||
infoBox =
|
||||
B.borderWithLabel (B.txt "Info")
|
||||
. B.hLimit 30
|
||||
. B.padBottom B.Max
|
||||
. B.padRight B.Max
|
||||
$ case NameBinding.renderNamesTxt s.interpState.bindings of
|
||||
[] -> B.txt " " -- Can't be an empty widget due to padding?
|
||||
bs -> B.vBox (B.txt <$> bs)
|
||||
|
||||
debugBox =
|
||||
if s.displayDebugConsoleLogs
|
||||
then
|
||||
let logDisplay =
|
||||
if null s.debugConsoleLogs then [" "] else s.debugConsoleLogs
|
||||
in B.borderWithLabel (B.txt "Debug") $
|
||||
B.withVScrollBars B.OnRight $
|
||||
B.padRight B.Max $
|
||||
B.txt $
|
||||
T.unlines $
|
||||
reverse logDisplay
|
||||
in B.borderWithLabel (B.txt "Debug")
|
||||
. B.withVScrollBars B.OnRight
|
||||
. B.padRight B.Max
|
||||
. B.txt
|
||||
. T.unlines
|
||||
. reverse
|
||||
$ logDisplay
|
||||
else B.emptyWidget
|
||||
|
||||
infoBox :: AppS -> B.Widget AppName
|
||||
infoBox appState =
|
||||
B.borderWithLabel (B.txt "Info")
|
||||
. B.hLimit 30
|
||||
. B.padRight B.Max
|
||||
. B.padBottom B.Max
|
||||
$ bindingBox <=> B.hBorderWithLabel (B.txt "Modules") <=> moduleBox
|
||||
where
|
||||
wrapSettings =
|
||||
Wrap.defaultWrapSettings
|
||||
{ Wrap.preserveIndentation = True
|
||||
, Wrap.breakLongWords = True
|
||||
, Wrap.fillStrategy = Wrap.FillIndent 2
|
||||
}
|
||||
intState = interpState appState
|
||||
bindingBox :: B.Widget AppName
|
||||
bindingBox = case NameBinding.renderNamesTxt <$> Daemon.bindings intState of
|
||||
Left _ -> B.txt "<Error displaying bindings>"
|
||||
Right [] -> B.txt " " -- Can't be an empty widget due to padding?
|
||||
Right bs -> B.vBox (B.txtWrapWith wrapSettings <$> bs)
|
||||
moduleBox :: B.Widget AppName
|
||||
moduleBox =
|
||||
if null mfmAssocs
|
||||
then B.txt "<No module mappings>"
|
||||
else foldr1 (<=>) (mkModEntryWidget <$> mfmAssocs)
|
||||
where
|
||||
mfmAssocs = Loc.moduleFileMapAssocs (Daemon.moduleFileMap intState)
|
||||
mkModEntryWidget (modName, fp) = B.txt (modName <> " > " <> T.pack fp)
|
||||
|
||||
-- | Mark the label if the first arg is True.
|
||||
markLabel :: Bool -> T.Text -> B.Widget a
|
||||
markLabel False labelTxt = B.txt (labelTxt <> " [Ctrl+x]")
|
||||
@ -164,7 +181,7 @@ makeGutter GutterInfo{..} =
|
||||
breakColumn
|
||||
| isSelected && isBreakpoint = B.withAttr (B.attrName "selected-marker") (B.txt "@")
|
||||
| isSelected = B.withAttr (B.attrName "selected-marker") (B.txt ">")
|
||||
| isBreakpoint = B.withAttr (B.attrName "breakpoint-marker") (B.txt "b")
|
||||
| isBreakpoint = B.withAttr (B.attrName "breakpoint-marker") (B.txt "*")
|
||||
| otherwise = spaceW
|
||||
stopColumn
|
||||
| isStoppedHere = B.withAttr (B.attrName "stop-line") (B.txt "!")
|
||||
@ -174,9 +191,9 @@ makeGutter GutterInfo{..} =
|
||||
codeViewportDraw :: AppS -> B.Widget AppName
|
||||
codeViewportDraw s =
|
||||
case (currentlyRunning, sourceDataMaybe) of
|
||||
(_, Just sourceData) -> codeViewportDraw' s sourceData
|
||||
(False, _) -> notRunningWidget
|
||||
(_, Nothing) -> noSourceWidget
|
||||
(_, Just sourceData) -> codeViewportDraw' s sourceData
|
||||
where
|
||||
currentlyRunning = Daemon.isExecuting (interpState s)
|
||||
sourceDataMaybe = getSourceContents s
|
||||
@ -209,7 +226,7 @@ codeViewportDraw' s sourceData = composedTogether
|
||||
_loadedWindowSize = error "loadedWindowSize not implemented"
|
||||
withLineNums = zip [startLineno ..]
|
||||
|
||||
breakpoints = Daemon.getBpInCurModule s.interpState
|
||||
breakpoints = maybe [] (Daemon.getBpInFile (interpState s)) (selectedFile s)
|
||||
gutterInfoForLine lineno =
|
||||
GutterInfo
|
||||
{ isStoppedHere =
|
||||
@ -272,17 +289,14 @@ codeViewportDraw' s sourceData = composedTogether
|
||||
lineWidgetCached = B.cached (CodeViewportLine lineno) lineWidget
|
||||
|
||||
composedTogether :: B.Widget AppName
|
||||
composedTogether =
|
||||
B.vBox
|
||||
( (\(num, t) -> wrapSelectedLine num $ composedTogetherHelper (num, t))
|
||||
<$> windowedSplitSourceData
|
||||
)
|
||||
composedTogether = B.vBox (createWidget <$> windowedSplitSourceData)
|
||||
where
|
||||
wrapSelectedLine lineno w =
|
||||
if lineno == s.selectedLine
|
||||
then -- Add highlighting, then mark it as visible in the viewport.
|
||||
B.visible $ B.modifyDefAttr (`V.withStyle` V.bold) w
|
||||
else w
|
||||
createWidget (num, lineTxt) = wrapSelectedLine num (composedTogetherHelper (num, lineTxt))
|
||||
|
||||
-- | Make the Stopped Line widget (the line where we paused execution)
|
||||
makeStoppedLineWidget :: T.Text -> Loc.ColumnRange -> B.Widget AppName
|
||||
@ -301,288 +315,6 @@ makeStoppedLineWidget lineData (Just startCol, Just endCol) =
|
||||
(lineDataBefore, partial) = T.splitAt (startCol - 1) lineData
|
||||
(lineDataRange, lineDataAfter) = T.splitAt (endCol - startCol + 1) partial
|
||||
|
||||
-- -------------------------------------------------------------------------------------------------
|
||||
-- Event Handling
|
||||
-- -------------------------------------------------------------------------------------------------
|
||||
|
||||
-- | Handle any Brick event and update the state.
|
||||
handleEvent :: B.BrickEvent AppName e -> B.EventM AppName AppS ()
|
||||
handleEvent ev = do
|
||||
appState <- B.get
|
||||
case appState.activeWindow of
|
||||
ActiveCodeViewport -> handleViewportEvent ev
|
||||
ActiveLiveInterpreter -> handleInterpreterEvent ev
|
||||
_ -> pure ()
|
||||
|
||||
-- -------------------------------------------------------------------------------------------------
|
||||
-- Interpreter Event Handling
|
||||
-- -------------------------------------------------------------------------------------------------
|
||||
|
||||
-- | Handle events when the interpreter (live GHCi) is selected.
|
||||
handleInterpreterEvent :: B.BrickEvent AppName e -> B.EventM AppName AppS ()
|
||||
handleInterpreterEvent ev =
|
||||
case ev of
|
||||
B.VtyEvent (V.EvKey V.KEnter []) -> do
|
||||
appState <- B.get
|
||||
let cmd = T.strip (T.unlines (editorContents appState))
|
||||
|
||||
-- Actually run the command.
|
||||
(newAppState1, output) <- runDaemon2 (`Daemon.execCleaned` cmd) appState
|
||||
|
||||
let newEditor =
|
||||
BE.applyEdit
|
||||
(Zipper.killToEOF . Zipper.gotoBOF)
|
||||
(appState ^. liveEditor')
|
||||
-- TODO: Should be configurable?
|
||||
let interpreterLogLimit = 1000
|
||||
let formattedWithPrompt = appState.appConfig.getInterpreterPrompt <> cmd
|
||||
let combinedLogs = reverse output <> (formattedWithPrompt : interpLogs appState)
|
||||
let newAppState2 =
|
||||
writeDebugLog ("Handled Enter: Ran '" <> cmd <> "'")
|
||||
. Lens.set (appInterpState . AIS.viewLock) True
|
||||
. Lens.over appInterpState (AIS.pushHistory (editorContents appState))
|
||||
$ newAppState1
|
||||
{ interpLogs =
|
||||
take interpreterLogLimit combinedLogs
|
||||
}
|
||||
let appStateFinalIO = updateSourceMap (Lens.set liveEditor' newEditor newAppState2)
|
||||
B.put =<< liftIO appStateFinalIO
|
||||
B.VtyEvent (V.EvKey (V.KChar '\t') []) -> do
|
||||
-- Tab completion?
|
||||
appState <- B.get
|
||||
let cmd = T.strip (T.unlines (editorContents appState))
|
||||
(newAppState1, _output) <-
|
||||
runDaemon2
|
||||
(`Daemon.execCleaned` (":complete " <> cmd))
|
||||
appState
|
||||
B.put newAppState1
|
||||
B.VtyEvent (V.EvKey (V.KChar 'x') [V.MCtrl]) ->
|
||||
-- Toggle out of the interpreter.
|
||||
leaveInterpreter
|
||||
B.VtyEvent (V.EvKey V.KEsc _) ->
|
||||
-- Also toggle out of the interpreter.
|
||||
leaveInterpreter
|
||||
B.VtyEvent (V.EvKey V.KUp _) -> do
|
||||
let maybeStoreBuffer s =
|
||||
if not (AIS.isScanningHist (getAis s))
|
||||
then storeCommandBuffer s
|
||||
else s
|
||||
let wDebug s =
|
||||
writeDebugLog
|
||||
( "Handled Up; historyPos is "
|
||||
<> (showT . AIS.historyPos . getAis $ s)
|
||||
)
|
||||
s
|
||||
appState <- B.get
|
||||
let appState' =
|
||||
wDebug
|
||||
. replaceCommandBufferWithHist -- Display the history.
|
||||
. Lens.over appInterpState AIS.pastHistoryPos -- Go back in time.
|
||||
. maybeStoreBuffer -- Store the buffer if we're not scanning already.
|
||||
$ appState
|
||||
B.put appState'
|
||||
B.VtyEvent (V.EvKey V.KDown _) -> do
|
||||
let wDebug s =
|
||||
writeDebugLog
|
||||
( "Handled Down; historyPos is "
|
||||
<> (showT . AIS.historyPos . getAis $ s)
|
||||
)
|
||||
s
|
||||
appState <- B.get
|
||||
let appState' =
|
||||
wDebug
|
||||
. replaceCommandBufferWithHist -- Display the history.
|
||||
. Lens.over appInterpState AIS.futHistoryPos -- Go forward in time.
|
||||
$ appState
|
||||
B.put appState'
|
||||
B.VtyEvent (V.EvKey V.KPageDown _) ->
|
||||
B.vScrollPage (B.viewportScroll LiveInterpreterViewport) B.Down
|
||||
B.VtyEvent (V.EvKey V.KPageUp _) -> do
|
||||
B.vScrollPage (B.viewportScroll LiveInterpreterViewport) B.Up
|
||||
appState <- B.get
|
||||
B.put (Lens.set (appInterpState . AIS.viewLock) False appState)
|
||||
ev' -> do
|
||||
appState <- B.get
|
||||
B.put (Lens.set (appInterpState . AIS.viewLock) True appState)
|
||||
-- Actually handle text input commands.
|
||||
B.zoom liveEditor' $ BE.handleEditorEvent ev'
|
||||
where
|
||||
editorContents appState = BE.getEditContents $ appState ^. liveEditor'
|
||||
storeCommandBuffer appState =
|
||||
Lens.set (appInterpState . AIS.commandBuffer) (editorContents appState) appState
|
||||
getAis s = s ^. appInterpState
|
||||
getCommandAtHist :: Int -> AppS -> [T.Text]
|
||||
getCommandAtHist i s
|
||||
| i <= 0 = s ^. appInterpState . AIS.commandBuffer
|
||||
| otherwise = atDef (lastDef [] hist) hist (i - 1)
|
||||
where
|
||||
hist = s ^. appInterpState . Lens.to AIS.history
|
||||
|
||||
leaveInterpreter = B.put . toggleActiveLineInterpreter =<< B.get
|
||||
|
||||
replaceCommandBufferWithHist :: AppS -> AppS
|
||||
replaceCommandBufferWithHist s@AppState{_appInterpState} = replaceCommandBuffer cmd s
|
||||
where
|
||||
cmd = T.unlines . getCommandAtHist (AIS.historyPos _appInterpState) $ s
|
||||
|
||||
-- | Replace the command buffer with the given strings of Text.
|
||||
replaceCommandBuffer
|
||||
:: T.Text
|
||||
-- ^ Text to replace with.
|
||||
-> AppS
|
||||
-- ^ State to modify.
|
||||
-> AppS
|
||||
-- ^ New state.
|
||||
replaceCommandBuffer replacement s = Lens.set liveEditor' newEditor s
|
||||
where
|
||||
zipp :: Zipper.TextZipper T.Text -> Zipper.TextZipper T.Text
|
||||
zipp = Zipper.killToEOF . Zipper.insertMany replacement . Zipper.gotoBOF
|
||||
newEditor = BE.applyEdit zipp (s ^. liveEditor')
|
||||
|
||||
-- -------------------------------------------------------------------------------------------------
|
||||
-- Viewport Event Handling
|
||||
-- -------------------------------------------------------------------------------------------------
|
||||
|
||||
handleViewportEvent :: B.BrickEvent AppName e -> B.EventM AppName AppS ()
|
||||
handleViewportEvent ev =
|
||||
case ev of
|
||||
B.VtyEvent (V.EvKey key ms)
|
||||
| key == V.KChar 'q' -> do
|
||||
appState <- B.get
|
||||
_ <- liftIO $ Daemon.quit appState.interpState
|
||||
B.halt
|
||||
| key == V.KChar 's' -> do
|
||||
appState <- B.get
|
||||
newState <- Daemon.step `runDaemon` appState
|
||||
invalidateLineCache
|
||||
B.put newState
|
||||
| key == V.KChar 'c' -> do
|
||||
appState <- B.get
|
||||
newState <- Daemon.continue `runDaemon` appState
|
||||
invalidateLineCache
|
||||
B.put newState
|
||||
| key == V.KChar 'b' -> do
|
||||
appState <- B.get
|
||||
insertViewportBreakpoint appState
|
||||
-- j and k are the vim navigation keybindings.
|
||||
| key `elem` [V.KDown, V.KChar 'j'] -> do
|
||||
moveSelectedLine 1
|
||||
| key `elem` [V.KUp, V.KChar 'k'] -> do
|
||||
moveSelectedLine (-1)
|
||||
| key == V.KPageDown -> do
|
||||
let scroller = B.viewportScroll CodeViewport
|
||||
B.vScrollPage scroller B.Down
|
||||
| key == V.KPageUp -> do
|
||||
let scroller = B.viewportScroll CodeViewport
|
||||
B.vScrollPage scroller B.Up
|
||||
| key == V.KChar 'x' && ms == [V.MCtrl] ->
|
||||
B.put . toggleActiveLineInterpreter =<< B.get
|
||||
-- TODO: Mouse support here?
|
||||
_ -> pure ()
|
||||
where
|
||||
moveSelectedLine :: Int -> B.EventM AppName (AppState n) ()
|
||||
moveSelectedLine movAmnt = do
|
||||
appState <- B.get
|
||||
let lineCount = maybe 1 (length . T.lines) (getSourceContents appState)
|
||||
let oldLineno = selectedLine appState
|
||||
let newLineno = B.clamp 1 lineCount (oldLineno + movAmnt)
|
||||
let newState = appState{selectedLine = newLineno}
|
||||
-- These two lines need to be re-rendered.
|
||||
B.invalidateCacheEntry (CodeViewportLine oldLineno)
|
||||
B.invalidateCacheEntry (CodeViewportLine newLineno)
|
||||
B.put newState
|
||||
|
||||
insertViewportBreakpoint :: AppS -> B.EventM AppName AppS ()
|
||||
insertViewportBreakpoint appState =
|
||||
case selectedModuleLoc appState of
|
||||
Left err -> do
|
||||
let selectedFileMsg = fromMaybe "<unknown>" appState.selectedFile
|
||||
let errMsg =
|
||||
"Cannot find module of line: "
|
||||
<> selectedFileMsg
|
||||
<> ":"
|
||||
<> show appState.selectedLine
|
||||
<> ": "
|
||||
<> T.unpack err
|
||||
liftIO $ fail errMsg
|
||||
Right ml -> do
|
||||
interpState <-
|
||||
liftIO $
|
||||
Daemon.toggleBreakpointLine
|
||||
appState.interpState
|
||||
(Daemon.ModLoc ml)
|
||||
-- We may need to be smarter about this,
|
||||
-- because there's a chance that the module loc 'ml'
|
||||
-- doesn't actually refer to this viewed file?
|
||||
case Loc.singleify (Loc.sourceRange ml) of
|
||||
Just (lineno, _colrange) ->
|
||||
B.invalidateCacheEntry (CodeViewportLine lineno)
|
||||
_ ->
|
||||
-- If we don't know, just invalidate everything.
|
||||
invalidateLineCache
|
||||
B.put appState{interpState}
|
||||
|
||||
-- TODO: Invalidate only the lines instead of the entire application.
|
||||
invalidateLineCache :: (Ord n) => B.EventM n (state n) ()
|
||||
invalidateLineCache = B.invalidateCache
|
||||
|
||||
runDaemon
|
||||
:: (MonadIO m)
|
||||
=> (Daemon.InterpState () -> IO (Daemon.InterpState ()))
|
||||
-> AppState n
|
||||
-> m (AppState n)
|
||||
runDaemon f appState =
|
||||
liftIO $ do
|
||||
interp <- f appState.interpState
|
||||
newState <- updateSourceMap appState{interpState = interp}
|
||||
pure (resetSelectedLine newState)
|
||||
|
||||
runDaemon2
|
||||
:: (MonadIO m)
|
||||
=> (Daemon.InterpState () -> IO (Daemon.InterpState (), a))
|
||||
-> AppState n
|
||||
-> m (AppState n, a)
|
||||
runDaemon2 f appState =
|
||||
liftIO $ do
|
||||
(interp, x) <- f appState.interpState
|
||||
newState <- updateSourceMap appState{interpState = interp}
|
||||
pure (resetSelectedLine newState, x)
|
||||
|
||||
handleCursorPosition
|
||||
:: AppS
|
||||
-- ^ State of the app.
|
||||
-> [B.CursorLocation AppName]
|
||||
-- ^ Potential Locs
|
||||
-> Maybe (B.CursorLocation AppName)
|
||||
-- ^ The chosen cursor location if any.
|
||||
handleCursorPosition s ls =
|
||||
if s.activeWindow == ActiveLiveInterpreter
|
||||
then -- If we're in the interpreter window, show the cursor.
|
||||
B.showCursorNamed widgetName ls
|
||||
else -- No cursor
|
||||
Nothing
|
||||
where
|
||||
widgetName = LiveInterpreter
|
||||
|
||||
-- | Get Location that's currently selected.
|
||||
selectedModuleLoc :: AppState n -> Either T.Text Loc.ModuleLoc
|
||||
selectedModuleLoc s = eModuleLoc =<< fl
|
||||
where
|
||||
sourceRange = Loc.srFromLineNo (selectedLine s)
|
||||
fl = case s.selectedFile of
|
||||
Nothing -> Left "No selected file to get module of"
|
||||
Just x -> Right (Loc.FileLoc x sourceRange)
|
||||
eModuleLoc x =
|
||||
let moduleFileMap = Daemon.moduleFileMap (interpState s)
|
||||
res = Loc.toModuleLoc moduleFileMap x
|
||||
errMsg =
|
||||
"No matching module found for '"
|
||||
<> showT x
|
||||
<> "' because moduleFileMap was '"
|
||||
<> showT moduleFileMap
|
||||
<> "'"
|
||||
in note errMsg res
|
||||
|
||||
-- -------------------------------------------------------------------------------------------------
|
||||
-- Brick Main
|
||||
-- -------------------------------------------------------------------------------------------------
|
||||
@ -592,8 +324,8 @@ brickApp :: B.App AppS e AppName
|
||||
brickApp =
|
||||
B.App
|
||||
{ B.appDraw = appDraw
|
||||
, B.appChooseCursor = handleCursorPosition
|
||||
, B.appHandleEvent = handleEvent
|
||||
, B.appChooseCursor = Events.handleCursorPosition
|
||||
, B.appHandleEvent = Events.handleEvent
|
||||
, B.appStartEvent = pure ()
|
||||
, B.appAttrMap =
|
||||
const $
|
||||
|
330
app/Events.hs
Normal file
330
app/Events.hs
Normal file
@ -0,0 +1,330 @@
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
|
||||
module Events (handleEvent, handleCursorPosition) where
|
||||
|
||||
import qualified Brick.Main as B
|
||||
import qualified Brick.Types as B
|
||||
import qualified Brick.Util as B
|
||||
import qualified Brick.Widgets.Edit as BE
|
||||
import Control.Error (atDef, fromMaybe, lastDef, note)
|
||||
import Control.Monad.IO.Class (MonadIO (..))
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Zipper as T
|
||||
import qualified Graphics.Vty as V
|
||||
import Lens.Micro ((^.))
|
||||
import qualified Lens.Micro as Lens
|
||||
|
||||
import qualified AppInterpState as AIS
|
||||
import AppState
|
||||
import AppTopLevel
|
||||
( AppName (..)
|
||||
)
|
||||
import qualified Ghcid.Daemon as Daemon
|
||||
import qualified Loc
|
||||
import Util (showT)
|
||||
|
||||
-- | Handle any Brick event and update the state.
|
||||
handleEvent :: B.BrickEvent AppName e -> B.EventM AppName (AppState AppName) ()
|
||||
handleEvent ev = do
|
||||
appState <- B.get
|
||||
case appState.activeWindow of
|
||||
ActiveCodeViewport -> handleViewportEvent ev
|
||||
ActiveLiveInterpreter -> handleInterpreterEvent ev
|
||||
_ -> pure ()
|
||||
|
||||
-- -------------------------------------------------------------------------------------------------
|
||||
-- Interpreter Event Handling
|
||||
-- -------------------------------------------------------------------------------------------------
|
||||
|
||||
-- | Handle events when the interpreter (live GHCi) is selected.
|
||||
handleInterpreterEvent :: B.BrickEvent AppName e -> B.EventM AppName (AppState AppName) ()
|
||||
handleInterpreterEvent ev =
|
||||
case ev of
|
||||
B.VtyEvent (V.EvKey V.KEnter []) -> do
|
||||
appState <- B.get
|
||||
let cmd = T.strip (T.unlines (editorContents appState))
|
||||
|
||||
-- Actually run the command.
|
||||
(newAppState1, output) <- runDaemon2 (`Daemon.execCleaned` cmd) appState
|
||||
|
||||
let newEditor =
|
||||
BE.applyEdit
|
||||
(T.killToEOF . T.gotoBOF)
|
||||
(appState ^. liveEditor')
|
||||
-- TODO: Should be configurable?
|
||||
let interpreterLogLimit = 1000
|
||||
let formattedWithPrompt = appState.appConfig.getInterpreterPrompt <> cmd
|
||||
let combinedLogs = reverse output <> (formattedWithPrompt : interpLogs appState)
|
||||
let newAppState2 =
|
||||
writeDebugLog ("Handled Enter: Ran '" <> cmd <> "'")
|
||||
. Lens.set (appInterpState . AIS.viewLock) True
|
||||
. Lens.over appInterpState (AIS.pushHistory (editorContents appState))
|
||||
$ newAppState1
|
||||
{ interpLogs =
|
||||
take interpreterLogLimit combinedLogs
|
||||
}
|
||||
let appStateFinalIO = updateSourceMap (Lens.set liveEditor' newEditor newAppState2)
|
||||
B.put =<< liftIO appStateFinalIO
|
||||
-- Invalidate the entire render state of the application
|
||||
-- because we don't know what's actually changed here now.
|
||||
B.invalidateCache
|
||||
B.VtyEvent (V.EvKey (V.KChar '\t') []) -> do
|
||||
-- Tab completion?
|
||||
appState <- B.get
|
||||
let cmd = T.strip (T.unlines (editorContents appState))
|
||||
(newAppState1, _output) <-
|
||||
runDaemon2
|
||||
(`Daemon.execCleaned` (":complete " <> cmd))
|
||||
appState
|
||||
B.put newAppState1
|
||||
B.VtyEvent (V.EvKey (V.KChar 'x') [V.MCtrl]) ->
|
||||
-- Toggle out of the interpreter.
|
||||
leaveInterpreter
|
||||
B.VtyEvent (V.EvKey V.KEsc _) ->
|
||||
-- Also toggle out of the interpreter.
|
||||
leaveInterpreter
|
||||
B.VtyEvent (V.EvKey V.KUp _) -> do
|
||||
let maybeStoreBuffer s =
|
||||
if not (AIS.isScanningHist (getAis s))
|
||||
then storeCommandBuffer s
|
||||
else s
|
||||
let wDebug s =
|
||||
writeDebugLog
|
||||
( "Handled Up; historyPos is "
|
||||
<> (showT . AIS.historyPos . getAis $ s)
|
||||
)
|
||||
s
|
||||
appState <- B.get
|
||||
let appState' =
|
||||
wDebug
|
||||
. replaceCommandBufferWithHist -- Display the history.
|
||||
. Lens.over appInterpState AIS.pastHistoryPos -- Go back in time.
|
||||
. maybeStoreBuffer -- Store the buffer if we're not scanning already.
|
||||
$ appState
|
||||
B.put appState'
|
||||
B.VtyEvent (V.EvKey V.KDown _) -> do
|
||||
appState <- B.get
|
||||
let wDebug s =
|
||||
writeDebugLog
|
||||
( "Handled Down; historyPos is "
|
||||
<> (showT . AIS.historyPos . getAis $ s)
|
||||
)
|
||||
s
|
||||
let appState' =
|
||||
wDebug
|
||||
. replaceCommandBufferWithHist -- Display the history.
|
||||
. Lens.over appInterpState AIS.futHistoryPos -- Go forward in time.
|
||||
$ appState
|
||||
B.put appState'
|
||||
B.VtyEvent (V.EvKey V.KPageDown _) ->
|
||||
B.vScrollPage (B.viewportScroll LiveInterpreterViewport) B.Down
|
||||
B.VtyEvent (V.EvKey V.KPageUp _) -> do
|
||||
B.vScrollPage (B.viewportScroll LiveInterpreterViewport) B.Up
|
||||
appState <- B.get
|
||||
B.put (Lens.set (appInterpState . AIS.viewLock) False appState)
|
||||
ev' -> do
|
||||
appState <- B.get
|
||||
B.put (Lens.set (appInterpState . AIS.viewLock) True appState)
|
||||
-- Actually handle text input commands.
|
||||
B.zoom liveEditor' $ BE.handleEditorEvent ev'
|
||||
where
|
||||
editorContents appState = BE.getEditContents $ appState ^. liveEditor'
|
||||
storeCommandBuffer appState =
|
||||
Lens.set (appInterpState . AIS.commandBuffer) (editorContents appState) appState
|
||||
getAis s = s ^. appInterpState
|
||||
getCommandAtHist :: Int -> AppState n -> [T.Text]
|
||||
getCommandAtHist i s
|
||||
| i <= 0 = s ^. appInterpState . AIS.commandBuffer
|
||||
| otherwise = atDef (lastDef [] hist) hist (i - 1)
|
||||
where
|
||||
hist = s ^. appInterpState . Lens.to AIS.history
|
||||
|
||||
leaveInterpreter = B.put . toggleActiveLineInterpreter =<< B.get
|
||||
|
||||
replaceCommandBufferWithHist :: AppState n -> AppState n
|
||||
replaceCommandBufferWithHist s@AppState{_appInterpState} = replaceCommandBuffer cmd s
|
||||
where
|
||||
cmd = T.unlines . getCommandAtHist (AIS.historyPos _appInterpState) $ s
|
||||
|
||||
-- | Replace the command buffer with the given strings of Text.
|
||||
replaceCommandBuffer
|
||||
:: T.Text
|
||||
-- ^ Text to replace with.
|
||||
-> AppState n
|
||||
-- ^ State to modify.
|
||||
-> AppState n
|
||||
-- ^ New state.
|
||||
replaceCommandBuffer replacement s = Lens.set liveEditor' newEditor s
|
||||
where
|
||||
zipp :: T.TextZipper T.Text -> T.TextZipper T.Text
|
||||
zipp = T.killToEOF . T.insertMany replacement . T.gotoBOF
|
||||
newEditor = BE.applyEdit zipp (s ^. liveEditor')
|
||||
|
||||
-- -------------------------------------------------------------------------------------------------
|
||||
-- Viewport Event Handling
|
||||
-- -------------------------------------------------------------------------------------------------
|
||||
|
||||
-- TODO: Handle mouse events?
|
||||
handleViewportEvent :: B.BrickEvent AppName e -> B.EventM AppName (AppState AppName) ()
|
||||
handleViewportEvent (B.VtyEvent (V.EvKey key ms))
|
||||
| key == V.KChar 'q' = do
|
||||
appState <- B.get
|
||||
_ <- liftIO $ Daemon.quit appState.interpState
|
||||
B.halt
|
||||
| key == V.KChar 's' = do
|
||||
appState <- B.get
|
||||
newState <- Daemon.step `runDaemon` appState
|
||||
invalidateLineCache
|
||||
B.put newState
|
||||
| key == V.KChar 'c' = do
|
||||
appState <- B.get
|
||||
newState <- Daemon.continue `runDaemon` appState
|
||||
invalidateLineCache
|
||||
B.put newState
|
||||
| key == V.KChar 'b' = do
|
||||
appState <- B.get
|
||||
insertViewportBreakpoint appState
|
||||
-- j and k are the vim navigation keybindings.
|
||||
| key `elem` [V.KDown, V.KChar 'j'] = do
|
||||
moveSelectedLineBy 1
|
||||
| key `elem` [V.KUp, V.KChar 'k'] = do
|
||||
moveSelectedLineBy (-1)
|
||||
| key == V.KPageDown = do
|
||||
appState <- B.get
|
||||
mViewport <- B.lookupViewport CodeViewport
|
||||
let oldSelectedLine = selectedLine appState
|
||||
let getViewportBot viewport = B._vpTop viewport + snd (B._vpSize viewport)
|
||||
let newSelectedLine = case mViewport of
|
||||
-- Need the + 1 due to one-indexing.
|
||||
Just viewport ->
|
||||
let lineCount = fromMaybe 1 (getSourceLineCount appState)
|
||||
in B.clamp 1 lineCount (getViewportBot viewport + 1)
|
||||
Nothing -> oldSelectedLine
|
||||
invalidateCachedLine oldSelectedLine
|
||||
invalidateCachedLine newSelectedLine
|
||||
B.put appState{selectedLine = newSelectedLine}
|
||||
let scroller = B.viewportScroll CodeViewport
|
||||
B.vScrollPage scroller B.Down
|
||||
| key == V.KPageUp = do
|
||||
appState <- B.get
|
||||
mViewport <- B.lookupViewport CodeViewport
|
||||
let oldSelectedLine = selectedLine appState
|
||||
let newSelectedLine = case mViewport of
|
||||
Just viewport ->
|
||||
let lineCount = fromMaybe 1 (getSourceLineCount appState)
|
||||
in B.clamp 1 lineCount (B._vpTop viewport)
|
||||
Nothing -> oldSelectedLine
|
||||
invalidateCachedLine oldSelectedLine
|
||||
invalidateCachedLine newSelectedLine
|
||||
B.put appState{selectedLine = newSelectedLine}
|
||||
let scroller = B.viewportScroll CodeViewport
|
||||
B.vScrollPage scroller B.Up
|
||||
| key == V.KChar 'x' && ms == [V.MCtrl] =
|
||||
B.put . toggleActiveLineInterpreter =<< B.get
|
||||
handleViewportEvent _ = pure ()
|
||||
|
||||
moveSelectedLineBy :: Int -> B.EventM AppName (AppState n) ()
|
||||
moveSelectedLineBy movAmnt = do
|
||||
appState <- B.get
|
||||
let lineCount = fromMaybe 1 (getSourceLineCount appState)
|
||||
let oldLineno = selectedLine appState
|
||||
let newLineno = B.clamp 1 lineCount (oldLineno + movAmnt)
|
||||
let newState = appState{selectedLine = newLineno}
|
||||
-- These two lines need to be re-rendered.
|
||||
invalidateCachedLine oldLineno
|
||||
invalidateCachedLine newLineno
|
||||
B.put newState
|
||||
|
||||
invalidateCachedLine :: Int -> B.EventM AppName s ()
|
||||
invalidateCachedLine lineno = B.invalidateCacheEntry (CodeViewportLine lineno)
|
||||
|
||||
insertViewportBreakpoint :: AppState AppName -> B.EventM AppName (AppState AppName) ()
|
||||
insertViewportBreakpoint appState =
|
||||
case selectedModuleLoc appState of
|
||||
Left err -> do
|
||||
let selectedFileMsg = fromMaybe "<unknown>" appState.selectedFile
|
||||
let errMsg =
|
||||
"Cannot find module of line: "
|
||||
<> selectedFileMsg
|
||||
<> ":"
|
||||
<> show appState.selectedLine
|
||||
<> ": "
|
||||
<> T.unpack err
|
||||
liftIO $ fail errMsg
|
||||
Right ml -> do
|
||||
interpState <-
|
||||
liftIO $
|
||||
Daemon.toggleBreakpointLine
|
||||
appState.interpState
|
||||
(Daemon.ModLoc ml)
|
||||
-- We may need to be smarter about this,
|
||||
-- because there's a chance that the module loc 'ml'
|
||||
-- doesn't actually refer to this viewed file?
|
||||
case Loc.singleify (Loc.sourceRange ml) of
|
||||
Just (lineno, _colrange) ->
|
||||
invalidateCachedLine lineno
|
||||
_ ->
|
||||
-- If we don't know, just invalidate everything.
|
||||
invalidateLineCache
|
||||
B.put appState{interpState}
|
||||
|
||||
-- TODO: Invalidate only the lines instead of the entire application.
|
||||
invalidateLineCache :: (Ord n) => B.EventM n (state n) ()
|
||||
invalidateLineCache = B.invalidateCache
|
||||
|
||||
runDaemon
|
||||
:: (MonadIO m)
|
||||
=> (Daemon.InterpState () -> IO (Daemon.InterpState ()))
|
||||
-> AppState n
|
||||
-> m (AppState n)
|
||||
runDaemon f appState =
|
||||
liftIO $ do
|
||||
interp <- f appState.interpState
|
||||
newState <- updateSourceMap appState{interpState = interp}
|
||||
pure (resetSelectedLine newState)
|
||||
|
||||
runDaemon2
|
||||
:: (MonadIO m)
|
||||
=> (Daemon.InterpState () -> IO (Daemon.InterpState (), a))
|
||||
-> AppState n
|
||||
-> m (AppState n, a)
|
||||
runDaemon2 f appState =
|
||||
liftIO $ do
|
||||
(interp, x) <- f appState.interpState
|
||||
newState <- updateSourceMap appState{interpState = interp}
|
||||
pure (resetSelectedLine newState, x)
|
||||
|
||||
handleCursorPosition
|
||||
:: AppState AppName
|
||||
-- ^ State of the app.
|
||||
-> [B.CursorLocation AppName]
|
||||
-- ^ Potential Locs
|
||||
-> Maybe (B.CursorLocation AppName)
|
||||
-- ^ The chosen cursor location if any.
|
||||
handleCursorPosition s ls =
|
||||
if s.activeWindow == ActiveLiveInterpreter
|
||||
then -- If we're in the interpreter window, show the cursor.
|
||||
B.showCursorNamed widgetName ls
|
||||
else -- No cursor
|
||||
Nothing
|
||||
where
|
||||
widgetName = LiveInterpreter
|
||||
|
||||
-- | Get Location that's currently selected.
|
||||
selectedModuleLoc :: AppState n -> Either T.Text Loc.ModuleLoc
|
||||
selectedModuleLoc s = eModuleLoc =<< fl
|
||||
where
|
||||
sourceRange = Loc.srFromLineNo (selectedLine s)
|
||||
fl = case s.selectedFile of
|
||||
Nothing -> Left "No selected file to get module of"
|
||||
Just x -> Right (Loc.FileLoc x sourceRange)
|
||||
eModuleLoc x =
|
||||
let moduleFileMap = Daemon.moduleFileMap (interpState s)
|
||||
res = Loc.toModuleLoc moduleFileMap x
|
||||
errMsg =
|
||||
"No matching module found for '"
|
||||
<> showT x
|
||||
<> "' because moduleFileMap was '"
|
||||
<> showT moduleFileMap
|
||||
<> "'"
|
||||
in note errMsg res
|
32
app/Main.hs
32
app/Main.hs
@ -1,9 +1,10 @@
|
||||
module Main where
|
||||
|
||||
import BrickUI (launchBrick)
|
||||
import qualified Data.Text as T
|
||||
import qualified Options.Applicative as Opt
|
||||
|
||||
import qualified AppConfig
|
||||
import BrickUI (launchBrick)
|
||||
|
||||
{-
|
||||
Old code for reference.
|
||||
@ -39,7 +40,6 @@ launch = do
|
||||
pure ()
|
||||
-}
|
||||
|
||||
|
||||
-- | Holds passed in command line options.
|
||||
data CmdOptions = CmdOptions
|
||||
{ debugConsole :: !Bool
|
||||
@ -48,7 +48,8 @@ data CmdOptions = CmdOptions
|
||||
-- ^ Launch the TUI at this work directory.
|
||||
, target :: !T.Text
|
||||
-- ^ Build target, passed as the final argument to cmd.
|
||||
} deriving (Show, Eq)
|
||||
}
|
||||
deriving (Show, Eq)
|
||||
|
||||
parseOpts :: Opt.Parser CmdOptions
|
||||
parseOpts =
|
||||
@ -74,20 +75,21 @@ parseOpts =
|
||||
)
|
||||
<*> Opt.argument Opt.str (Opt.metavar "TARGET")
|
||||
|
||||
fibty :: Int -> Int
|
||||
fibty 1 = 0
|
||||
fibty 2 = 1
|
||||
fibty n =
|
||||
let left = fibty (n - 1)
|
||||
right = fibty (n - 2)
|
||||
in left + right
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
opts <- Opt.execParser parserInfo
|
||||
let conf = AppConfig.defaultConfig { AppConfig.getDebugConsoleOnStart = debugConsole opts }
|
||||
let defConf = AppConfig.defaultConfig
|
||||
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)
|
||||
where
|
||||
parserInfo = Opt.info
|
||||
(Opt.helper Opt.<*> parseOpts)
|
||||
(Opt.fullDesc <> Opt.progDesc "Program Description")
|
||||
parserInfo =
|
||||
Opt.info
|
||||
(Opt.helper Opt.<*> parseOpts)
|
||||
(Opt.fullDesc <> Opt.progDesc "Program Description")
|
||||
|
@ -30,6 +30,8 @@ executable ghcitui
|
||||
, microlens ^>= 0.4.13.1
|
||||
, text-zipper ^>= 0.13
|
||||
, optparse-applicative ^>= 0.18.1.0
|
||||
, word-wrap ^>= 0.5
|
||||
, transformers ^>= 0.6.1.0
|
||||
hs-source-dirs: app
|
||||
other-modules: BrickUI
|
||||
, AppState
|
||||
@ -37,6 +39,7 @@ executable ghcitui
|
||||
, Util
|
||||
, AppInterpState
|
||||
, AppConfig
|
||||
, Events
|
||||
ghc-options: -rtsopts
|
||||
-threaded
|
||||
-Wall
|
||||
@ -63,6 +66,7 @@ library
|
||||
, safe ^>= 0.3.19
|
||||
, string-interpolate ^>= 0.3.2.1
|
||||
, text ^>= 2.0.2
|
||||
, transformers ^>= 0.6.1.0
|
||||
exposed-modules: Ghcid.Daemon
|
||||
, Ghcid.ParseContext
|
||||
, Loc
|
||||
|
@ -1,8 +1,10 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Ghcid.Daemon
|
||||
( startup
|
||||
( DaemonError
|
||||
, startup
|
||||
, BreakpointArg (..)
|
||||
, InterpState (..)
|
||||
, continue
|
||||
@ -22,15 +24,15 @@ module Ghcid.Daemon
|
||||
, toggleBreakpointLine
|
||||
) where
|
||||
|
||||
import Control.Error
|
||||
import Control.Monad (when)
|
||||
import Control.Monad.IO.Class (MonadIO (..))
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import qualified Data.Bifunctor as Bifunctor
|
||||
import Data.Maybe (catMaybes, mapMaybe)
|
||||
import Data.String.Interpolate (i)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.IO as T
|
||||
import qualified Language.Haskell.Ghcid as Ghcid
|
||||
import Safe
|
||||
|
||||
import qualified Ghcid.ParseContext as ParseContext
|
||||
import qualified Loc
|
||||
@ -42,26 +44,31 @@ newtype LogLevel = LogLevel Int
|
||||
-- | Determines where the daemon logs are written.
|
||||
data LogOutput = LogOutputStdOut | LogOutputStdErr | LogOutputFile FilePath
|
||||
|
||||
data DaemonError
|
||||
= UpdateBindingError T.Text
|
||||
| UpdateBreakListError T.Text
|
||||
deriving (Show, Eq)
|
||||
|
||||
data InterpState a = InterpState
|
||||
{ _ghci :: Ghcid.Ghci
|
||||
-- ^ GHCiD handle.
|
||||
, func :: Maybe T.Text
|
||||
, func :: !(Maybe T.Text)
|
||||
-- ^ Current pause position function name.
|
||||
, pauseLoc :: Maybe Loc.FileLoc
|
||||
, pauseLoc :: !(Maybe Loc.FileLoc)
|
||||
-- ^ Current pause position.
|
||||
, moduleFileMap :: Loc.ModuleFileMap
|
||||
, moduleFileMap :: !Loc.ModuleFileMap
|
||||
-- ^ Mapping between modules and their filepaths.
|
||||
, stack :: [T.Text]
|
||||
-- ^ Program stack (only available during tracing).
|
||||
, breakpoints :: [(Int, Loc.ModuleLoc)]
|
||||
-- ^ Currently set breakpoint locations.
|
||||
, bindings :: [NameBinding.NameBinding T.Text]
|
||||
, bindings :: Either DaemonError [NameBinding.NameBinding T.Text]
|
||||
-- ^ Current context value bindings.
|
||||
, status :: Either T.Text a
|
||||
, status :: !(Either T.Text a)
|
||||
-- ^ IDK? I had an idea here at one point.
|
||||
, logLevel :: LogLevel
|
||||
, logLevel :: !LogLevel
|
||||
-- ^ How much should we log?
|
||||
, logOutput :: LogOutput
|
||||
, logOutput :: !LogOutput
|
||||
-- ^ Where should we log to?
|
||||
, execHist :: [T.Text]
|
||||
-- ^ What's the execution history?
|
||||
@ -75,7 +82,7 @@ instance Show (InterpState a) where
|
||||
let srcRngFmt :: String
|
||||
srcRngFmt =
|
||||
[i|{sourceRange=(#{startLine},#{startCol})-(#{endLine},#{endCol})}|]
|
||||
in [i|{func="#{func'}", filepath="#{filepath'}", #{srcRngFmt}}|]
|
||||
in [i|{func=#{func'}, filepath=#{filepath'}, #{srcRngFmt}}|]
|
||||
_ -> "<unknown pause location>" :: String
|
||||
in msg
|
||||
|
||||
@ -89,7 +96,7 @@ emptyInterpreterState ghci =
|
||||
, moduleFileMap = mempty
|
||||
, stack = mempty
|
||||
, breakpoints = mempty
|
||||
, bindings = mempty
|
||||
, bindings = Right mempty
|
||||
, status = Right mempty
|
||||
, logLevel = LogLevel 3
|
||||
, logOutput = LogOutputFile "/tmp/ghcitui.log"
|
||||
@ -114,7 +121,7 @@ startup
|
||||
-- ^ The newly created interpreter handle.
|
||||
startup cmd pwd = do
|
||||
(ghci, _) <- Ghcid.startGhci cmd (Just pwd) (\_ _ -> pure ())
|
||||
pure $ emptyInterpreterState ghci
|
||||
updateState (emptyInterpreterState ghci)
|
||||
|
||||
-- | Shutdown GHCiD.
|
||||
quit :: InterpState a -> IO (InterpState a)
|
||||
@ -124,11 +131,24 @@ quit state = do
|
||||
|
||||
-- | Update the interpreter state. Wrapper around other updaters.
|
||||
updateState :: (Monoid a) => InterpState a -> IO (InterpState a)
|
||||
updateState state =
|
||||
updateContext state
|
||||
>>= updateBindings
|
||||
>>= updateModuleFileMap
|
||||
>>= updateBreakList
|
||||
updateState state = do
|
||||
-- Make a wrapper so we don't fail on updating bindings.
|
||||
-- Parsing bindings turns out to be actually impossible to solve
|
||||
-- with the current ':show bindings' output.
|
||||
result <-
|
||||
runExceptT
|
||||
( (lift . updateContext) state
|
||||
>>= ( \s ->
|
||||
updateBindings s
|
||||
`catchE` (\er -> pure s{bindings = Left er})
|
||||
)
|
||||
>>= lift . updateModuleFileMap
|
||||
>>= updateBreakList
|
||||
)
|
||||
case result of
|
||||
Right x -> pure x
|
||||
Left (UpdateBindingError msg) -> error (T.unpack msg)
|
||||
Left (UpdateBreakListError msg) -> error (T.unpack msg)
|
||||
|
||||
-- | Update the current interpreter context.
|
||||
updateContext :: (Monoid a) => InterpState a -> IO (InterpState a)
|
||||
@ -146,33 +166,17 @@ updateContext state@InterpState{_ghci} = do
|
||||
then pure (emptyInterpreterState _ghci) -- We exited everything.
|
||||
else do
|
||||
let ctx = ParseContext.parseContext feedback
|
||||
let unwrapLog f wrapper = case f ctx of
|
||||
Left (ParseContext.ParseError msg) -> do
|
||||
logError state msg
|
||||
pure Nothing
|
||||
Right x -> pure (wrapper x)
|
||||
mFunc <- unwrapLog ParseContext.func Just
|
||||
filepath <- case ParseContext.filepath ctx of
|
||||
Left (ParseContext.ParseError msg) -> do
|
||||
logError state msg
|
||||
error ("parsing filepath: " <> T.unpack msg)
|
||||
Right x -> pure x
|
||||
sourceRange <- case ParseContext.pcSourceRange ctx of
|
||||
Left (ParseContext.ParseError msg) -> do
|
||||
logError state msg
|
||||
pure Loc.unknownSourceRange
|
||||
Right x -> pure x
|
||||
pure
|
||||
state
|
||||
{ func = mFunc
|
||||
, pauseLoc = Just $ Loc.FileLoc filepath sourceRange
|
||||
}
|
||||
case ctx of
|
||||
ParseContext.PCError er -> error [i|Failed to update context: #{er}|]
|
||||
ParseContext.PCNoContext -> pure (emptyInterpreterState _ghci)
|
||||
ParseContext.PCContext ParseContext.ParseContextOut{func, filepath, pcSourceRange} ->
|
||||
pure state{func = Just func, pauseLoc = Just $ Loc.FileLoc filepath pcSourceRange}
|
||||
|
||||
-- | Update the current local bindings.
|
||||
updateBindings :: InterpState a -> IO (InterpState a)
|
||||
updateBindings :: InterpState a -> ExceptT DaemonError IO (InterpState a)
|
||||
updateBindings state@InterpState{_ghci} = do
|
||||
logDebug state "|updateBindings| CMD: :show bindings\n"
|
||||
msgs <- Ghcid.exec _ghci ":show bindings"
|
||||
msgs <- liftIO (Ghcid.exec _ghci ":show bindings")
|
||||
let feedback = ParseContext.cleanResponse (T.pack <$> msgs)
|
||||
logDebug
|
||||
state
|
||||
@ -181,15 +185,21 @@ updateBindings state@InterpState{_ghci} = do
|
||||
<> "\n"
|
||||
)
|
||||
case ParseContext.parseBindings feedback of
|
||||
Right bindings -> pure (state{bindings})
|
||||
Left err -> error ("Failed to update bindings:\n" <> T.unpack err)
|
||||
Right bindings -> pure (state{bindings = pure bindings})
|
||||
Left er -> throwE (UpdateBindingError [i|Failed to update bindings: #{er}|])
|
||||
|
||||
-- | Update the source map given any app state changes.
|
||||
updateModuleFileMap :: InterpState a -> IO (InterpState a)
|
||||
updateModuleFileMap state@InterpState{_ghci, moduleFileMap} = do
|
||||
modules <- Ghcid.showModules _ghci
|
||||
logDebug state ("|updateModuleFileMap| modules: " <> showT modules)
|
||||
let addedModuleMap = Loc.moduleFileMapFromList (Bifunctor.first T.pack <$> modules)
|
||||
logDebug state "updateModuleFileMap|: CMD: :show modules\n"
|
||||
msgs <- Ghcid.exec _ghci ":show modules"
|
||||
let packedMsgs = StringUtil.linesToText msgs
|
||||
logDebug state [i||updateModuleFileMap|: OUT: #{packedMsgs}\n|]
|
||||
modules <- case ParseContext.parseShowModules packedMsgs of
|
||||
Right modules -> pure modules
|
||||
Left er -> error $ show er
|
||||
logDebug state [i||updateModuleFileMap| modules: #{modules}|]
|
||||
let addedModuleMap = Loc.moduleFileMapFromList modules
|
||||
let newModuleFileMap = addedModuleMap <> moduleFileMap
|
||||
pure $ state{moduleFileMap = newModuleFileMap}
|
||||
|
||||
@ -332,23 +342,21 @@ deleteBreakpointLine state loc =
|
||||
)
|
||||
pure state
|
||||
|
||||
updateBreakList :: InterpState a -> IO (InterpState a)
|
||||
updateBreakList :: InterpState a -> ExceptT DaemonError IO (InterpState a)
|
||||
updateBreakList state@InterpState{_ghci} = do
|
||||
logDebug state "|updateBreakList| CMD: :show breaks\n"
|
||||
msgs <- Ghcid.exec _ghci ":show breaks"
|
||||
msgs <- liftIO (Ghcid.exec _ghci ":show breaks")
|
||||
logDebug
|
||||
state
|
||||
( "|updateBreakList| OUT:\n"
|
||||
<> StringUtil.linesToText msgs
|
||||
)
|
||||
let response = ParseContext.cleanResponse (T.pack <$> msgs)
|
||||
pure
|
||||
( case ParseContext.parseShowBreaks response of
|
||||
Right breakpoints -> state{breakpoints}
|
||||
Left err -> error ("parsing breakpoint list: " <> T.unpack err)
|
||||
)
|
||||
case ParseContext.parseShowBreaks response of
|
||||
Right breakpoints -> pure state{breakpoints}
|
||||
Left er -> throwE (UpdateBreakListError [i|parsing breakpoint list: #{er}|])
|
||||
|
||||
-- | Return a list of breakpoint line numbers in the current file.
|
||||
-- | Return a list of breakpoint line numbers in the currently paused file.
|
||||
getBpInCurModule :: InterpState a -> [Int]
|
||||
getBpInCurModule InterpState{pauseLoc = Nothing} = []
|
||||
getBpInCurModule s@InterpState{pauseLoc = Just Loc.FileLoc{filepath = fp}} = getBpInFile s fp
|
||||
|
@ -1,13 +1,16 @@
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Ghcid.ParseContext
|
||||
( ParseContextOut (..)
|
||||
, ParseContextReturn (..)
|
||||
, NameBinding (..)
|
||||
, BindingValue (..)
|
||||
, parseContext
|
||||
, parseBreakResponse
|
||||
, parseBindings
|
||||
, parseShowBreaks
|
||||
, parseShowModules
|
||||
, cleanResponse
|
||||
, ParseError (..)
|
||||
) where
|
||||
@ -15,10 +18,11 @@ module Ghcid.ParseContext
|
||||
import Prelude hiding (lines)
|
||||
|
||||
import Control.Applicative ((<|>))
|
||||
import Control.Error.Util (note)
|
||||
import Control.Error
|
||||
import Data.Array ((!))
|
||||
import Data.String.Interpolate (i)
|
||||
import qualified Data.Text as T
|
||||
import Safe (atMay, headMay, lastDef, readMay, readNote)
|
||||
import Safe (readNote)
|
||||
import Text.Regex.TDFA (MatchResult (..), (=~~))
|
||||
|
||||
import qualified Loc
|
||||
@ -35,29 +39,35 @@ showT = T.pack . show
|
||||
|
||||
-- | Output record datatype for 'parseContext'.
|
||||
data ParseContextOut = ParseContextOut
|
||||
{ func :: !(Either ParseError T.Text)
|
||||
, filepath :: !(Either ParseError FilePath)
|
||||
, pcSourceRange :: !(Either ParseError Loc.SourceRange)
|
||||
{ func :: !T.Text
|
||||
, filepath :: !FilePath
|
||||
, pcSourceRange :: !Loc.SourceRange
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data ParseContextReturn = PCError ParseError | PCNoContext | PCContext ParseContextOut
|
||||
|
||||
-- | Parse the output from ":show context" for the interpreter state.
|
||||
parseContext :: T.Text -> ParseContextOut
|
||||
parseContext contextText = case eInfoLine contextText of
|
||||
Right (func, rest) ->
|
||||
ParseContextOut
|
||||
(Right func)
|
||||
(parseFile rest)
|
||||
(Right (parseSourceRange rest))
|
||||
Left e -> ParseContextOut (Left e) (Left e) (Left e)
|
||||
parseContext :: T.Text -> ParseContextReturn
|
||||
parseContext contextText =
|
||||
case eInfoLine contextText of
|
||||
Right (func, rest) ->
|
||||
let sourceRange = parseSourceRange rest
|
||||
in case parseFile rest of
|
||||
Right f -> PCContext (ParseContextOut func f sourceRange)
|
||||
Left e -> PCError e
|
||||
Left (ParseError e) ->
|
||||
let contextTextLines = T.lines contextText
|
||||
in if all (`elem` ["", "()"]) contextTextLines
|
||||
then PCNoContext
|
||||
else PCError (ParseError [i| parsing context: #{e}|])
|
||||
|
||||
parseFile :: T.Text -> Either ParseError FilePath
|
||||
parseFile s
|
||||
| Just mr <- s =~~ ("^[ \t]*([^:]*):" :: T.Text) = Right (T.unpack (mrSubs mr ! 1))
|
||||
| otherwise = Left (ParseError ("Could not parse file from: '" <> s <> "'"))
|
||||
| otherwise = Left (ParseError [i|Could not parse file from: '#{s}'|])
|
||||
|
||||
{- | Parse a source range structure into a SourceRange object.
|
||||
-}
|
||||
-- | Parse a source range structure into a SourceRange object.
|
||||
parseSourceRange :: T.Text -> Loc.SourceRange
|
||||
parseSourceRange s
|
||||
-- Matches (12,34)-(56,78)
|
||||
@ -117,6 +127,7 @@ parseSourceRange s
|
||||
into ("Foo.Bar", "other stuff here") if the text matches.
|
||||
-}
|
||||
eInfoLine :: T.Text -> Either ParseError (T.Text, T.Text)
|
||||
eInfoLine "" = Left $ ParseError "Could not find info line in empty string"
|
||||
eInfoLine contextText =
|
||||
note
|
||||
(ParseError $ "Could not match info line: '" <> showT splits <> "'")
|
||||
@ -125,9 +136,9 @@ eInfoLine contextText =
|
||||
splits = splitBy ghcidPrompt contextText
|
||||
stopLineMR = foldr (\n acc -> acc <|> stopReg n) Nothing splits
|
||||
stopLine = (\mr -> (mrSubs mr ! 1, mrSubs mr ! 2)) <$> stopLineMR
|
||||
-- \| Match on the "Stopped in ..." line.
|
||||
-- Match on the "Stopped in ..." line.
|
||||
stopReg :: T.Text -> Maybe (MatchResult T.Text)
|
||||
stopReg s = s =~~ ("^[ \t]*Stopped in ([[:alnum:]_.]+),(.*)" :: T.Text)
|
||||
stopReg s = s =~~ ("^[ \t]*Stopped in ([[:alnum:]_.()]+),(.*)" :: T.Text)
|
||||
|
||||
parseBreakResponse :: T.Text -> Either T.Text [Loc.ModuleLoc]
|
||||
parseBreakResponse t
|
||||
@ -172,7 +183,7 @@ parseShowBreaks t
|
||||
parseEach mr =
|
||||
let
|
||||
-- Don't need to use readMay because regex.
|
||||
idx = readNote "failed to read index." $ T.unpack $ mr.mrSubs ! 1
|
||||
idx = readNote "Failed to read index" $ T.unpack $ mr.mrSubs ! 1
|
||||
module_ = mr.mrSubs ! 2
|
||||
_filepath = Just $ mr.mrSubs ! 3 -- Not used currently but could be useful?
|
||||
sourceRange = parseSourceRange $ mr.mrSubs ! 4
|
||||
@ -182,40 +193,46 @@ parseShowBreaks t
|
||||
x -> Left ("Breakpoint neither enabled nor disabled: " <> x)
|
||||
in
|
||||
case sourceRange of
|
||||
_ | sourceRange == Loc.unknownSourceRange ->
|
||||
Left ("Could not parse source range for breakpoint " <> showT idx)
|
||||
| otherwise ->
|
||||
enabled >> Right ( idx, Loc.ModuleLoc module_ sourceRange )
|
||||
_
|
||||
| sourceRange == Loc.unknownSourceRange ->
|
||||
Left ("Could not parse source range for breakpoint " <> showT idx)
|
||||
| otherwise ->
|
||||
enabled >> Right (idx, Loc.ModuleLoc module_ sourceRange)
|
||||
|
||||
-- | Parse the output of ":show modules".
|
||||
parseShowModules :: T.Text -> Either T.Text [(T.Text, FilePath)]
|
||||
parseShowModules :: T.Text -> Either ParseError [(T.Text, FilePath)]
|
||||
parseShowModules t
|
||||
| T.null stripped = Right []
|
||||
| Just xs <- (mapM matching . T.lines) =<< response =
|
||||
| Just xs <- matchingLines =
|
||||
let
|
||||
parseEach :: MatchResult T.Text -> (T.Text, FilePath)
|
||||
parseEach mr = (mr.mrSubs ! 1, T.unpack $ mr.mrSubs ! 2)
|
||||
in
|
||||
Right $ parseEach <$> xs
|
||||
| otherwise = Left ("failed to parse ':show modules': " <> stripped)
|
||||
| otherwise = Left (ParseError [i|Failed to parse ':show modules': #{stripped}|])
|
||||
where
|
||||
stripped = T.strip t
|
||||
response = headMay (splitBy ghcidPrompt stripped)
|
||||
reg = "([[:alnum:]_.]+)[ \\t]+\\( *(.*),.*\\)" :: T.Text
|
||||
matchingLines = mapMaybe matching . T.lines <$> lastMay (splitBy ghcidPrompt stripped)
|
||||
reg = "([[:alnum:]_.]+)[ \\t]+\\( *([^,]*),.*\\)" :: T.Text
|
||||
matching :: T.Text -> Maybe (MatchResult T.Text)
|
||||
matching = (=~~ reg)
|
||||
|
||||
-- Sometimes there's lines that are just Unit '()'. Unsure
|
||||
-- what they are meant to represent in the binding list.
|
||||
dropUnitLines :: [T.Text] -> [T.Text]
|
||||
dropUnitLines = filter (\x -> T.strip x /= "()")
|
||||
|
||||
-- | Parse the output of ":show bindings".
|
||||
parseBindings :: T.Text -> Either T.Text [NameBinding T.Text]
|
||||
parseBindings t
|
||||
| T.null stripped = Right []
|
||||
| Just xs <- mapM (=~~ reg) (mergeBindingLines (T.lines stripped)) =
|
||||
| Just xs <- mapM (=~~ reg) (dropUnitLines (mergeBindingLines (T.lines stripped))) =
|
||||
let
|
||||
parseEach :: MatchResult T.Text -> NameBinding T.Text
|
||||
parseEach mr = NameBinding (mr.mrSubs ! 1) (mr.mrSubs ! 2) (Evald $ mr.mrSubs ! 3)
|
||||
in
|
||||
Right $ parseEach <$> xs
|
||||
| otherwise = Left ("failed to parse ':show bindings':\n" <> stripped)
|
||||
| otherwise = Left ("Failed to parse ':show bindings':\n" <> stripped)
|
||||
where
|
||||
stripped = T.strip t
|
||||
|
||||
@ -223,11 +240,12 @@ parseBindings t
|
||||
mergeBindingLines [] = []
|
||||
mergeBindingLines [x] = [x]
|
||||
mergeBindingLines (x1 : x2 : xs) =
|
||||
if T.elem '=' x1
|
||||
then x1 : mergeBindingLines (x2 : xs)
|
||||
else
|
||||
let newLine = (T.strip x1 <> " " <> T.strip x2)
|
||||
case T.uncons x2 of
|
||||
Just (' ', rest) ->
|
||||
let newLine = (T.strip x1 <> " " <> T.strip rest)
|
||||
in mergeBindingLines (newLine : xs)
|
||||
_ -> x1 : mergeBindingLines (x2 : xs)
|
||||
|
||||
{- They look like...
|
||||
ghci> :show bindings
|
||||
somethingLong ::
|
||||
@ -248,4 +266,10 @@ include what we want fairly consistently.
|
||||
Additionally, pack the lines into a single T.Text block.
|
||||
-}
|
||||
cleanResponse :: [T.Text] -> T.Text
|
||||
cleanResponse msgs = lastDef "" (splitBy ghcidPrompt (T.unlines msgs))
|
||||
cleanResponse =
|
||||
T.unlines
|
||||
. dropUnitLines
|
||||
. T.lines
|
||||
. lastDef ""
|
||||
. splitBy ghcidPrompt
|
||||
. T.unlines
|
||||
|
27
lib/Loc.hs
27
lib/Loc.hs
@ -1,27 +1,26 @@
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
|
||||
module Loc
|
||||
( ColumnRange
|
||||
, ModuleLoc (..)
|
||||
, FileLoc (..)
|
||||
, ModuleFileMap
|
||||
, moduleFileMapFromList
|
||||
, moduleFileMapAssocs
|
||||
, getPathOfModule
|
||||
, getModuleOfPath
|
||||
, toModuleLoc
|
||||
, toFileLoc
|
||||
, HasSourceRange(..)
|
||||
, SourceRange(..)
|
||||
, HasSourceRange (..)
|
||||
, SourceRange (..)
|
||||
, unknownSourceRange
|
||||
, isLineInside
|
||||
, srFromLineNo
|
||||
, singleify
|
||||
) where
|
||||
|
||||
import Data.Map.Strict as Map
|
||||
import Data.Maybe (isNothing)
|
||||
import qualified Data.Text as T
|
||||
import Safe (headMay)
|
||||
import Data.Maybe (isNothing)
|
||||
import Data.Map.Strict as Map
|
||||
|
||||
-- ------------------------------------------------------------------------------------------------
|
||||
|
||||
@ -33,14 +32,17 @@ data SourceRange = SourceRange
|
||||
, startCol :: !(Maybe Int)
|
||||
, endLine :: !(Maybe Int)
|
||||
, endCol :: !(Maybe Int)
|
||||
} deriving (Show, Eq, Ord)
|
||||
}
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
-- | A source range that represents an unknown location.
|
||||
unknownSourceRange :: SourceRange
|
||||
unknownSourceRange = SourceRange Nothing Nothing Nothing Nothing
|
||||
|
||||
srFromLineNo :: Int -> SourceRange
|
||||
srFromLineNo lineno = unknownSourceRange { startLine = Just lineno, endLine = Just lineno }
|
||||
srFromLineNo lineno = unknownSourceRange{startLine = Just lineno, endLine = Just lineno}
|
||||
|
||||
-- | Return whether a given line number lies within a given source range.
|
||||
isLineInside :: SourceRange -> Int -> Bool
|
||||
isLineInside SourceRange{startLine = Just sl, endLine = Just el} num = num >= sl && num <= el
|
||||
isLineInside SourceRange{startLine = Just sl, endLine = Nothing} num = num >= sl
|
||||
@ -50,13 +52,12 @@ isLineInside _ _ = False
|
||||
singleify :: SourceRange -> Maybe (Int, ColumnRange)
|
||||
singleify sr
|
||||
| isNothing sl = Nothing
|
||||
| sl == el = do
|
||||
lineno <- sl
|
||||
| sl == endLine sr = do
|
||||
lineno <- sl
|
||||
pure (lineno, (startCol sr, endCol sr))
|
||||
| otherwise = Nothing
|
||||
where
|
||||
sl = startLine sr
|
||||
el = endLine sr
|
||||
|
||||
-- ------------------------------------------------------------------------------------------------
|
||||
|
||||
@ -95,6 +96,10 @@ instance Monoid ModuleFileMap where
|
||||
moduleFileMapFromList :: [(T.Text, FilePath)] -> ModuleFileMap
|
||||
moduleFileMapFromList = ModuleFileMap . Map.fromList
|
||||
|
||||
-- | Return mappings between a module name and a filepath.
|
||||
moduleFileMapAssocs :: ModuleFileMap -> [(T.Text, FilePath)]
|
||||
moduleFileMapAssocs (ModuleFileMap map_) = Map.assocs map_
|
||||
|
||||
-- | Convert a module to a FilePath.
|
||||
getPathOfModule :: ModuleFileMap -> T.Text -> Maybe FilePath
|
||||
getPathOfModule (ModuleFileMap ms) mod' = Map.lookup mod' ms
|
||||
|
Loading…
Reference in New Issue
Block a user