From 52a2f3c11cdec4f58a719004119983f6968f6cf8 Mon Sep 17 00:00:00 2001 From: CrystalSplitter Date: Sun, 1 Oct 2023 22:43:10 -0700 Subject: [PATCH] Module box + more --- app/AppConfig.hs | 18 +- app/AppInterpState.hs | 44 +++-- app/AppState.hs | 106 +++++++---- app/BrickUI.hs | 384 ++++++-------------------------------- app/Events.hs | 330 ++++++++++++++++++++++++++++++++ app/Main.hs | 32 ++-- ghcitui.cabal | 4 + lib/Ghcid/Daemon.hs | 116 ++++++------ lib/Ghcid/ParseContext.hs | 94 ++++++---- lib/Loc.hs | 27 +-- 10 files changed, 651 insertions(+), 504 deletions(-) create mode 100644 app/Events.hs diff --git a/app/AppConfig.hs b/app/AppConfig.hs index 1718d49..535e7b0 100644 --- a/app/AppConfig.hs +++ b/app/AppConfig.hs @@ -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 } diff --git a/app/AppInterpState.hs b/app/AppInterpState.hs index 7b14c2b..c3ae8d1 100644 --- a/app/AppInterpState.hs +++ b/app/AppInterpState.hs @@ -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 diff --git a/app/AppState.hs b/app/AppState.hs index 24fb88c..7fcdb8f 100644 --- a/app/AppState.hs +++ b/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 diff --git a/app/BrickUI.hs b/app/BrickUI.hs index 4a0e3cd..61012fa 100644 --- a/app/BrickUI.hs +++ b/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 "" + 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 "" + 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 "" 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 $ diff --git a/app/Events.hs b/app/Events.hs new file mode 100644 index 0000000..4f58584 --- /dev/null +++ b/app/Events.hs @@ -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 "" 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 diff --git a/app/Main.hs b/app/Main.hs index eeb2c89..dc93101 100644 --- a/app/Main.hs +++ b/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") diff --git a/ghcitui.cabal b/ghcitui.cabal index d7764de..5be1f3d 100644 --- a/ghcitui.cabal +++ b/ghcitui.cabal @@ -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 diff --git a/lib/Ghcid/Daemon.hs b/lib/Ghcid/Daemon.hs index 87673c0..2b75507 100644 --- a/lib/Ghcid/Daemon.hs +++ b/lib/Ghcid/Daemon.hs @@ -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}}|] _ -> "" :: 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 diff --git a/lib/Ghcid/ParseContext.hs b/lib/Ghcid/ParseContext.hs index 9eed3e4..fa9fabf 100644 --- a/lib/Ghcid/ParseContext.hs +++ b/lib/Ghcid/ParseContext.hs @@ -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 diff --git a/lib/Loc.hs b/lib/Loc.hs index dd1bdd7..c351487 100644 --- a/lib/Loc.hs +++ b/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