mirror of
https://github.com/CrystalSplitter/ghcitui.git
synced 2024-09-11 10:55:29 +03:00
The interpreter commit
This commit is contained in:
parent
cb44c6bb8a
commit
77d08e470a
139
app/AppState.hs
Normal file
139
app/AppState.hs
Normal file
@ -0,0 +1,139 @@
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
|
||||
module AppState (
|
||||
ActiveWindow(..)
|
||||
, AppConfig(..)
|
||||
, AppState(..)
|
||||
, getSourceContents
|
||||
, updateSourceMap
|
||||
, liveEditorLens
|
||||
, resetSelectedLine
|
||||
, makeInitialState
|
||||
, AppStateConfig(..)
|
||||
, toggleActiveLineInterpreter
|
||||
, toggleBreakpointLine
|
||||
) where
|
||||
|
||||
import qualified Brick.Widgets.Edit as BE
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text.IO
|
||||
import qualified Lens.Micro as Lens
|
||||
|
||||
import AppTopLevel (AppName (..), Command)
|
||||
import qualified Daemon
|
||||
import qualified Loc
|
||||
import Daemon (toggleBreakpointLine)
|
||||
|
||||
data ActiveWindow = ActiveCodeViewport | ActiveLiveInterpreter | ActiveInfoWindow
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
newtype AppConfig = AppConfig
|
||||
{ interpreterPrompt :: Text
|
||||
-- ^ Prompt to show for the live interpreter.
|
||||
} deriving (Eq, Show)
|
||||
|
||||
-- | Application state wrapper
|
||||
data AppState n = AppState
|
||||
{ interpState :: Daemon.InterpState ()
|
||||
, liveEditor :: BE.Editor Text n
|
||||
, interpLogs :: [Text]
|
||||
, appConfig :: AppConfig
|
||||
-- ^ The interpreter handle.
|
||||
, activeWindow :: ActiveWindow
|
||||
-- ^ Currently active interpreter.
|
||||
, selectedFile :: Maybe FilePath
|
||||
-- ^ Filepath to the current code viewport contents, if set.
|
||||
, selectedLine :: Int
|
||||
-- ^ Currently selected line number. Resets back to 1.
|
||||
, sourceMap :: Map.Map FilePath Text
|
||||
-- ^ Mapping between source filepaths and their contents.
|
||||
, appStateConfig :: AppStateConfig
|
||||
-- ^ Program launch configuration.
|
||||
, displayDebugConsoleLogs :: Bool
|
||||
-- ^ Whether to display debug Console logs.
|
||||
, debugConsoleLogs :: [Text]
|
||||
-- ^ Place for debug output to go.
|
||||
, splashContents :: !(Maybe Text)
|
||||
-- ^ Splash to show on start up.
|
||||
}
|
||||
|
||||
-- | Lens wrapper for zooming with handleEditorEvent.
|
||||
liveEditorLens :: Lens.Lens' (AppState n) (BE.Editor Text n)
|
||||
liveEditorLens = Lens.lens liveEditor (\s newEditor -> s{liveEditor = newEditor})
|
||||
|
||||
toggleActiveLineInterpreter :: AppState n -> AppState n
|
||||
toggleActiveLineInterpreter s@AppState{activeWindow} =
|
||||
s{activeWindow = toggleLogic activeWindow}
|
||||
where
|
||||
toggleLogic ActiveLiveInterpreter = ActiveCodeViewport
|
||||
toggleLogic _ = ActiveLiveInterpreter
|
||||
|
||||
-- | Reset the code viewport selected line.
|
||||
resetSelectedLine :: AppState n -> AppState n
|
||||
resetSelectedLine s@AppState{interpState} = s{selectedFile, selectedLine}
|
||||
where
|
||||
selectedLine = fromMaybe 1 interpState.pauseLoc.linenoF
|
||||
selectedFile = interpState.pauseLoc.filepath
|
||||
|
||||
-- | Update the source map given any app state changes.
|
||||
updateSourceMap :: AppState n -> IO (AppState n)
|
||||
updateSourceMap s =
|
||||
case s.interpState.pauseLoc.filepath of
|
||||
Nothing -> pure s
|
||||
(Just filepath) -> updateSourceMapWithFilepath s filepath
|
||||
|
||||
-- | Update the source map with a given filepath.
|
||||
updateSourceMapWithFilepath :: AppState n -> FilePath -> IO (AppState n)
|
||||
updateSourceMapWithFilepath s filepath
|
||||
| Map.member filepath s.sourceMap = pure s
|
||||
| otherwise = do
|
||||
contents <- Data.Text.IO.readFile filepath
|
||||
let newSourceMap = Map.insert filepath contents s.sourceMap
|
||||
pure $ s{sourceMap = newSourceMap}
|
||||
|
||||
-- | Return the potential contents of the current paused file location.
|
||||
getSourceContents :: AppState n -> Maybe Text
|
||||
getSourceContents s = s.selectedFile >>= (s.sourceMap Map.!?)
|
||||
|
||||
-- | Configuration options read in at start-up.
|
||||
newtype AppStateConfig = AppStateConfig
|
||||
{ startupSplashPath :: FilePath
|
||||
}
|
||||
|
||||
-- | Create the initial live interpreter widget object.
|
||||
initInterpWidget
|
||||
:: n
|
||||
-- ^ Editor name (must be a unique identifier).
|
||||
-> Maybe Int
|
||||
-- ^ Line height of the editor. Nothing for unlimited.
|
||||
-> BE.Editor Text n
|
||||
initInterpWidget name height = BE.editorText name height ""
|
||||
|
||||
-- TODO: This should not be hardcoded for debugging.
|
||||
makeInitialState :: AppStateConfig -> Command -> IO (AppState AppName)
|
||||
makeInitialState config cmd = do
|
||||
interpState_ <-
|
||||
Daemon.startup cmd "."
|
||||
>>= flip Daemon.load "app/Main.hs"
|
||||
>>= flip Daemon.stepInto "fibty 10"
|
||||
interpState <- Daemon.setBreakpointLine interpState_ (Daemon.LocalLine 41)
|
||||
splashContents <- Data.Text.IO.readFile config.startupSplashPath
|
||||
pure $
|
||||
AppState
|
||||
{ interpState
|
||||
, selectedLine = 1
|
||||
, selectedFile = Nothing
|
||||
, sourceMap = mempty
|
||||
, appStateConfig = config
|
||||
, appConfig = AppConfig {
|
||||
interpreterPrompt = "ghci> "
|
||||
}
|
||||
, activeWindow = ActiveCodeViewport
|
||||
, liveEditor = initInterpWidget LiveInterpreter (Just 1)
|
||||
, interpLogs = []
|
||||
, displayDebugConsoleLogs = False
|
||||
, debugConsoleLogs = mempty
|
||||
, splashContents = Just splashContents
|
||||
}
|
5
app/AppTopLevel.hs
Normal file
5
app/AppTopLevel.hs
Normal file
@ -0,0 +1,5 @@
|
||||
module AppTopLevel (AppName(..), Command) where
|
||||
|
||||
data AppName = GHCiTUI | CodeViewport | LiveInterpreter deriving (Eq, Show, Ord)
|
||||
|
||||
type Command = String
|
311
app/BrickUI.hs
311
app/BrickUI.hs
@ -10,98 +10,126 @@ import qualified Brick as B
|
||||
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.Monad.IO.Class (MonadIO (..))
|
||||
import Data.List (find)
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Text (Text, append, pack)
|
||||
import Data.Text (Text, append, pack, unpack)
|
||||
import qualified Data.Text
|
||||
import qualified Data.Text.IO
|
||||
import qualified Data.Text.Zipper as Zipper
|
||||
import qualified Graphics.Vty as V
|
||||
import Safe (atMay)
|
||||
|
||||
import AppState
|
||||
( ActiveWindow (..)
|
||||
, AppConfig (..)
|
||||
, AppState (..)
|
||||
, AppStateConfig (..)
|
||||
, getSourceContents
|
||||
, liveEditorLens
|
||||
, makeInitialState
|
||||
, resetSelectedLine
|
||||
, toggleActiveLineInterpreter
|
||||
, updateSourceMap
|
||||
)
|
||||
import AppTopLevel (AppName (..), Command)
|
||||
import qualified Daemon
|
||||
import Debug.Trace (trace)
|
||||
import qualified Loc
|
||||
|
||||
data AppName = GHCiTUI | CodeViewport | LiveInterpreter deriving (Eq, Show, Ord)
|
||||
-- | Alias for 'AppState AppName' convenience.
|
||||
type AppS = AppState AppName
|
||||
|
||||
-- | Application state wrapper
|
||||
data AppState = AppState
|
||||
{ interpState :: Daemon.InterpState ()
|
||||
, selectedFile :: Maybe FilePath
|
||||
, selectedLine :: Int
|
||||
, sourceMap :: Map.Map FilePath Text
|
||||
-- ^ Mapping between source filepaths and their contents.
|
||||
, appStateConfig :: AppStateConfig
|
||||
-- ^ Program launch configuration
|
||||
, splashContents :: Maybe Text
|
||||
}
|
||||
|
||||
resetSelectedLine :: AppState -> AppState
|
||||
resetSelectedLine s@AppState{interpState} = s{selectedFile, selectedLine}
|
||||
where
|
||||
selectedLine = fromMaybe 1 interpState.pauseLoc.linenoF
|
||||
selectedFile = interpState.pauseLoc.filepath
|
||||
|
||||
-- | Update the source map given any app state changes.
|
||||
updateSourceMap :: AppState -> IO AppState
|
||||
updateSourceMap s =
|
||||
case s.interpState.pauseLoc.filepath of
|
||||
Nothing -> pure s
|
||||
(Just filepath) -> updateSourceMapWithFilepath s filepath
|
||||
|
||||
-- | Update the source map with a given filepath.
|
||||
updateSourceMapWithFilepath :: AppState -> FilePath -> IO AppState
|
||||
updateSourceMapWithFilepath s filepath
|
||||
| Map.member filepath s.sourceMap = pure s
|
||||
| otherwise = do
|
||||
contents <- Data.Text.IO.readFile filepath
|
||||
let newSourceMap = Map.insert filepath contents s.sourceMap
|
||||
pure $ s{sourceMap = newSourceMap}
|
||||
|
||||
appDraw :: AppState -> [B.Widget AppName]
|
||||
appDraw :: AppS -> [B.Widget AppName]
|
||||
appDraw s =
|
||||
[ ( B.borderWithLabel
|
||||
(B.txt ("Source: " `append` maybe "?" pack (s.interpState.pauseLoc.filepath)))
|
||||
( B.withVScrollBars
|
||||
B.OnRight
|
||||
( B.viewport
|
||||
CodeViewport
|
||||
B.Vertical
|
||||
( B.padRight B.Max (makeCodeViewport s)
|
||||
let
|
||||
sourceLabel =
|
||||
markLabel
|
||||
(s.activeWindow == ActiveCodeViewport)
|
||||
("Source: " `append` maybe "?" pack (s.interpState.pauseLoc.filepath))
|
||||
interpreterLabel =
|
||||
markLabel (s.activeWindow == ActiveLiveInterpreter) "Interpreter"
|
||||
viewportBox =
|
||||
B.borderWithLabel sourceLabel
|
||||
. B.withVScrollBars B.OnRight
|
||||
. B.viewport CodeViewport B.Vertical
|
||||
. B.padRight B.Max
|
||||
$ codeViewportDraw s
|
||||
|
||||
interpreterBox =
|
||||
B.borderWithLabel
|
||||
interpreterLabel
|
||||
$ let enableCursor = True
|
||||
displayLimit = 5
|
||||
displayF t = B.vBox $ B.txt <$> t
|
||||
previousOutput =
|
||||
B.vLimit displayLimit
|
||||
. B.padTop B.Max
|
||||
. B.txt
|
||||
. Data.Text.unlines
|
||||
. reverse
|
||||
. take displayLimit
|
||||
$ if null s.interpLogs
|
||||
then [" "]
|
||||
else s.interpLogs
|
||||
promptLine =
|
||||
B.txt s.appConfig.interpreterPrompt
|
||||
<+> BE.renderEditor displayF enableCursor s.liveEditor
|
||||
in previousOutput <=> promptLine
|
||||
infoBox =
|
||||
B.borderWithLabel
|
||||
(B.txt "Info")
|
||||
( B.padBottom
|
||||
B.Max
|
||||
( B.padLeft
|
||||
(B.Pad 20)
|
||||
(B.txt " ") -- Important that there's a space here for padding.
|
||||
)
|
||||
)
|
||||
)
|
||||
-- TODO: Make this an editor viewport.
|
||||
<=> B.borderWithLabel
|
||||
(B.txt "Interpreter")
|
||||
(B.padRight B.Max (B.txt " >>> "))
|
||||
)
|
||||
-- TODO: Make this an expandable viewport, maybe?
|
||||
<+> B.borderWithLabel
|
||||
(B.txt "Info")
|
||||
( B.padBottom
|
||||
B.Max
|
||||
( B.padLeft
|
||||
(B.Pad 20)
|
||||
(B.txt " ") -- Important that there's a space here for padding.
|
||||
)
|
||||
)
|
||||
]
|
||||
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 $
|
||||
Data.Text.unlines $
|
||||
reverse logDisplay
|
||||
else B.emptyWidget
|
||||
in
|
||||
[ (viewportBox <=> interpreterBox <=> debugBox)
|
||||
-- TODO: Make this an expandable viewport, maybe?
|
||||
<+> infoBox
|
||||
]
|
||||
|
||||
-- | Mark the label if the first arg is True.
|
||||
markLabel :: Bool -> Text -> B.Widget a
|
||||
markLabel False labelTxt = B.txt labelTxt
|
||||
markLabel True labelTxt =
|
||||
B.withAttr (B.attrName "highlight") (B.txt ("#>" `append` labelTxt `append` "<#"))
|
||||
|
||||
-- | Information used to compute the gutter status of each line.
|
||||
data GutterInfo = GutterInfo
|
||||
{ isStoppedHere :: !Bool
|
||||
-- ^ Is the interpreter stopped/paused here?
|
||||
, isBreakpoint :: !Bool
|
||||
-- ^ Is there a breakpoint here?
|
||||
, isSelected :: !Bool
|
||||
-- ^ Is this line currently selected by the user?
|
||||
, gutterLineNumber :: !Int
|
||||
-- ^ What line number is this?
|
||||
, gutterDigitWidth :: !Int
|
||||
-- ^ How many columns is the gutter line number?
|
||||
}
|
||||
|
||||
-- | Prepend gutter information on each line in the primary viewport.
|
||||
prependGutter :: GutterInfo -> B.Widget n -> B.Widget n
|
||||
prependGutter gi line = makeGutter gi <+> line
|
||||
|
||||
-- | Prepend gutter information on each line in the primary viewport.
|
||||
-- | Create the gutter section for a given line (formed from GutterInfo).
|
||||
makeGutter :: GutterInfo -> B.Widget n
|
||||
makeGutter GutterInfo{..} =
|
||||
lineNoWidget <+> spaceW <+> stopColumn <+> breakColumn <+> spaceW
|
||||
@ -119,25 +147,22 @@ makeGutter GutterInfo{..} =
|
||||
| isStoppedHere = B.withAttr (B.attrName "stop-line") (B.txt "!")
|
||||
| otherwise = spaceW
|
||||
|
||||
-- | Return the potential contents of the current paused file location.
|
||||
getSourceContents :: AppState -> Maybe Text
|
||||
getSourceContents s = s.selectedFile >>= (s.sourceMap Map.!?)
|
||||
|
||||
-- | Make the primary viewport widget.
|
||||
makeCodeViewport :: AppState -> B.Widget AppName
|
||||
makeCodeViewport s =
|
||||
codeViewportDraw :: AppS -> B.Widget AppName
|
||||
codeViewportDraw s =
|
||||
let sourceDataMaybe = getSourceContents s
|
||||
noSourceWidget =
|
||||
B.padTop (B.Pad 3) $
|
||||
B.hCenter $
|
||||
B.withAttr (B.attrName "styled") $
|
||||
maybe (B.txt "No source file loaded") B.txt s.splashContents
|
||||
in case sourceDataMaybe of
|
||||
Nothing ->
|
||||
B.padTop (B.Pad 3) $
|
||||
B.hCenter $
|
||||
B.withAttr (B.attrName "styled") $
|
||||
maybe (B.txt "No source file loaded") B.txt s.splashContents
|
||||
Just sourceData -> makeCodeViewport' s sourceData
|
||||
Nothing -> noSourceWidget
|
||||
Just sourceData -> codeViewportDraw' s sourceData
|
||||
|
||||
-- | Viewport when we have source contents.
|
||||
makeCodeViewport' :: AppState -> Text -> B.Widget AppName
|
||||
makeCodeViewport' s sourceData = composedTogether
|
||||
codeViewportDraw' :: AppS -> Text -> B.Widget AppName
|
||||
codeViewportDraw' s sourceData = composedTogether
|
||||
where
|
||||
splitSourceData = Data.Text.lines sourceData
|
||||
breakpoints = Daemon.getBpInCurModule s.interpState
|
||||
@ -162,9 +187,12 @@ makeCodeViewport' s sourceData = composedTogether
|
||||
|
||||
selectedLineW :: Text -> B.Widget AppName
|
||||
selectedLineW lineTxt =
|
||||
let lineWidget = B.txt $ Data.Text.replace " " " " lineTxt
|
||||
let transform = id -- Potentialy useful for highlighting spaces?
|
||||
lineWidget = B.txt $ transform lineTxt
|
||||
in prefixLineDefault' (s.selectedLine, lineWidget)
|
||||
|
||||
-- Select which line widget we want to draw based on both the interpreter
|
||||
-- state and the app state.
|
||||
composedTogetherHelper :: (Int, Text) -> B.Widget AppName
|
||||
composedTogetherHelper (lineno, lineTxt)
|
||||
| Just lineno == s.interpState.pauseLoc.linenoF = stoppedLineW lineTxt
|
||||
@ -218,14 +246,59 @@ formatDigits spacing num = pack (replicate left ' ') `append` pack (show num)
|
||||
where
|
||||
left = spacing - getNumDigits num
|
||||
|
||||
selectedModuleLoc :: AppState -> Maybe Loc.ModuleLoc
|
||||
selectedModuleLoc :: AppState n -> Maybe Loc.ModuleLoc
|
||||
selectedModuleLoc s =
|
||||
Loc.toModuleLoc
|
||||
s.interpState.moduleFileMap
|
||||
(Loc.FileLoc s.selectedFile (Just s.selectedLine) (Nothing, Nothing))
|
||||
|
||||
handleEvent :: B.BrickEvent AppName e -> B.EventM AppName AppState ()
|
||||
handleEvent ev =
|
||||
-- | 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 ()
|
||||
|
||||
-- | 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 AppState{liveEditor, interpState, debugConsoleLogs, interpLogs} = appState
|
||||
let cmd = Data.Text.strip . Data.Text.unlines . BE.getEditContents $ liveEditor
|
||||
(newInterpState, output) <-
|
||||
liftIO $
|
||||
Daemon.execCleaned interpState (unpack cmd)
|
||||
let newEditor = BE.applyEdit (Zipper.killToEOF . Zipper.gotoBOF) liveEditor
|
||||
-- TODO: Should be configurable?
|
||||
let interpreterLogLimit = 1000
|
||||
let formattedWithPrompt = appState.appConfig.interpreterPrompt `append` cmd
|
||||
let combinedLogs = (pack <$> reverse output) ++ formattedWithPrompt : interpLogs
|
||||
B.put
|
||||
appState
|
||||
{ debugConsoleLogs = "Handled Enter" : debugConsoleLogs
|
||||
, interpState = newInterpState
|
||||
, liveEditor = newEditor
|
||||
, interpLogs =
|
||||
take interpreterLogLimit combinedLogs
|
||||
}
|
||||
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
|
||||
ev' -> do
|
||||
-- Actually handle text input commands.
|
||||
B.zoom liveEditorLens $ BE.handleEditorEvent ev'
|
||||
where
|
||||
leaveInterpreter = B.put . toggleActiveLineInterpreter =<< B.get
|
||||
|
||||
handleViewportEvent :: B.BrickEvent AppName e -> B.EventM AppName (AppState n) ()
|
||||
handleViewportEvent ev =
|
||||
case ev of
|
||||
B.VtyEvent (V.EvKey key ms)
|
||||
| key == V.KChar 'q' -> do
|
||||
@ -242,12 +315,7 @@ handleEvent ev =
|
||||
B.put newState
|
||||
| key == V.KChar 'b' -> do
|
||||
appState <- B.get
|
||||
let mlM = selectedModuleLoc appState
|
||||
let runner interpState ml =
|
||||
Daemon.toggleBreakpointLine
|
||||
interpState
|
||||
(Daemon.ModLoc ml)
|
||||
case mlM of
|
||||
case selectedModuleLoc appState of
|
||||
Nothing ->
|
||||
liftIO $
|
||||
fail
|
||||
@ -257,7 +325,11 @@ handleEvent ev =
|
||||
++ show appState.selectedLine
|
||||
)
|
||||
Just ml -> do
|
||||
interpState <- liftIO $ runner appState.interpState ml
|
||||
interpState <-
|
||||
liftIO $
|
||||
Daemon.toggleBreakpointLine
|
||||
appState.interpState
|
||||
(Daemon.ModLoc ml)
|
||||
B.put appState{interpState}
|
||||
|
||||
-- j and k are the vim navigation keybindings.
|
||||
@ -268,17 +340,15 @@ handleEvent ev =
|
||||
| key == V.KPageDown -> do
|
||||
let scroller = B.viewportScroll CodeViewport
|
||||
B.vScrollPage scroller B.Down
|
||||
pure ()
|
||||
| key == V.KPageUp -> do
|
||||
let scroller = B.viewportScroll CodeViewport
|
||||
B.vScrollPage scroller B.Up
|
||||
pure ()
|
||||
| key == V.KChar 'x' && ms == [V.MCtrl] -> do
|
||||
-- TODO: Handle live interpreter
|
||||
pure ()
|
||||
| key == V.KChar 'x' && ms == [V.MCtrl] ->
|
||||
B.put . toggleActiveLineInterpreter =<< B.get
|
||||
-- TODO: Mouse support here?
|
||||
_ -> pure ()
|
||||
where
|
||||
moveSelectedLine :: Int -> B.EventM a AppState ()
|
||||
moveSelectedLine :: Int -> B.EventM a (AppState n) ()
|
||||
moveSelectedLine movAmnt = do
|
||||
appState <- B.get
|
||||
let lineCount = maybe 1 (length . Data.Text.lines) (getSourceContents appState)
|
||||
@ -289,21 +359,37 @@ handleEvent ev =
|
||||
|
||||
runDaemon
|
||||
:: (MonadIO m)
|
||||
=> AppState
|
||||
=> AppState n
|
||||
-> (Daemon.InterpState () -> IO (Daemon.InterpState ()))
|
||||
-> m AppState
|
||||
-> m (AppState n)
|
||||
runDaemon appState f =
|
||||
liftIO $ do
|
||||
interp <- f appState.interpState
|
||||
newState <- updateSourceMap appState{interpState = interp}
|
||||
pure $ resetSelectedLine newState
|
||||
|
||||
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.
|
||||
|
||||
let widgetName = LiveInterpreter
|
||||
in B.showCursorNamed widgetName ls
|
||||
else -- No cursor
|
||||
Nothing
|
||||
|
||||
-- | Brick main program.
|
||||
brickApp :: B.App AppState e AppName
|
||||
brickApp :: B.App AppS e AppName
|
||||
brickApp =
|
||||
B.App
|
||||
{ B.appDraw = appDraw
|
||||
, B.appChooseCursor = B.neverShowCursor
|
||||
, B.appChooseCursor = handleCursorPosition
|
||||
, B.appHandleEvent = handleEvent
|
||||
, B.appStartEvent = pure ()
|
||||
, B.appAttrMap =
|
||||
@ -322,31 +408,6 @@ brickApp =
|
||||
]
|
||||
}
|
||||
|
||||
type Command = String
|
||||
|
||||
newtype AppStateConfig = AppStateConfig
|
||||
{ startupSplashPath :: FilePath
|
||||
}
|
||||
|
||||
-- TODO: This should not be hardcoded for debugging.
|
||||
makeInitialState :: AppStateConfig -> Command -> IO AppState
|
||||
makeInitialState config cmd = do
|
||||
interpState_ <-
|
||||
Daemon.startup cmd "."
|
||||
>>= flip Daemon.load "app/Main.hs"
|
||||
>>= flip Daemon.stepInto "fibty 10"
|
||||
interpState <- Daemon.setBreakpointLine interpState_ (Daemon.LocalLine 41)
|
||||
splashContents <- Data.Text.IO.readFile config.startupSplashPath
|
||||
pure $
|
||||
AppState
|
||||
{ interpState
|
||||
, selectedLine = 1
|
||||
, selectedFile = Nothing
|
||||
, sourceMap = mempty
|
||||
, appStateConfig = config
|
||||
, splashContents = Just splashContents
|
||||
}
|
||||
|
||||
-- | Start the Brick UI
|
||||
launchBrick :: IO ()
|
||||
launchBrick = do
|
||||
@ -356,4 +417,4 @@ launchBrick = do
|
||||
_ -> error "Not a supported command type"
|
||||
initialState <- makeInitialState (AppStateConfig "assets/splash.txt") cmd
|
||||
_ <- B.defaultMain brickApp initialState
|
||||
pure ()
|
||||
pure ()
|
||||
|
@ -1,2 +1,8 @@
|
||||
#!/bin/sh
|
||||
fswatch -n 64 -ro -l1 -m poll_monitor app/ lib/ | xargs -I{} cabal build
|
||||
|
||||
if ! which fswatch >/dev/null; then
|
||||
printf "%s\n" "'fswatch' is needed to run this script"
|
||||
exit 1
|
||||
fi
|
||||
|
||||
fswatch -n 64 -ro -l1 -m poll_monitor app/ lib/ *.cabal | xargs -I{} cabal build
|
||||
|
@ -26,8 +26,12 @@ executable ghcitui
|
||||
, ghcituilib
|
||||
, vty
|
||||
, safe
|
||||
, microlens ^>= 0.4.13.1
|
||||
, text-zipper ^>= 0.13
|
||||
hs-source-dirs: app
|
||||
other-modules: BrickUI
|
||||
, AppState
|
||||
, AppTopLevel
|
||||
ghc-options: -rtsopts
|
||||
-threaded
|
||||
-Wall
|
||||
@ -40,7 +44,6 @@ executable ghcitui
|
||||
DuplicateRecordFields
|
||||
OverloadedStrings
|
||||
RecordWildCards
|
||||
|
||||
|
||||
library ghcituilib
|
||||
hs-source-dirs: lib
|
||||
@ -56,8 +59,8 @@ library ghcituilib
|
||||
exposed-modules: Daemon
|
||||
, Tui
|
||||
, Loc
|
||||
other-modules: ParseContext
|
||||
, StringUtil
|
||||
other-modules: ParseContext
|
||||
ghc-options: -rtsopts
|
||||
-threaded
|
||||
-Wall
|
||||
|
@ -7,6 +7,8 @@ module Daemon
|
||||
, deleteBreakpointLine
|
||||
, emptyInterpreterState
|
||||
, exec
|
||||
, execCleaned
|
||||
, execMuted
|
||||
, getBpInCurModule
|
||||
, getBpInFile
|
||||
, load
|
||||
@ -22,13 +24,11 @@ module Daemon
|
||||
import Control.Monad (when)
|
||||
import Control.Monad.IO.Class (MonadIO (..))
|
||||
import qualified Data.Bifunctor as Bifunctor
|
||||
import Data.List (intercalate)
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Data.Maybe (catMaybes, mapMaybe, fromMaybe)
|
||||
import Data.Maybe (catMaybes, fromMaybe, mapMaybe)
|
||||
import Data.String.Interpolate (i)
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.IO as Text
|
||||
import Debug.Trace (trace)
|
||||
import qualified Language.Haskell.Ghcid as Ghcid
|
||||
|
||||
import qualified Loc
|
||||
@ -37,6 +37,8 @@ import Safe
|
||||
|
||||
newtype LogLevel = LogLevel Int
|
||||
|
||||
data LogOutput = LogOutputStdOut | LogOutputStdErr | LogOutputFile FilePath
|
||||
|
||||
data InterpState a = InterpState
|
||||
{ _ghci :: Ghcid.Ghci
|
||||
-- ^ GHCID handle
|
||||
@ -53,6 +55,9 @@ data InterpState a = InterpState
|
||||
, status :: Either Text.Text a
|
||||
-- ^ IDK? I had an idea here at one point.
|
||||
, logLevel :: LogLevel
|
||||
-- ^ How much should we log?
|
||||
, logOutput :: LogOutput
|
||||
-- ^ Where should we log to?
|
||||
}
|
||||
|
||||
instance Show (InterpState a) where
|
||||
@ -71,7 +76,8 @@ emptyInterpreterState ghci =
|
||||
, stack = []
|
||||
, breakpoints = mempty
|
||||
, status = Right mempty
|
||||
, logLevel = LogLevel 0
|
||||
, logLevel = LogLevel 3
|
||||
, logOutput = LogOutputFile "/tmp/ghcitui.log"
|
||||
}
|
||||
|
||||
-- | Start up the GHCI Daemon
|
||||
@ -99,12 +105,14 @@ updateState state_1@InterpState{_ghci} = do
|
||||
|
||||
updateContext :: (Monoid a) => InterpState a -> IO (InterpState a)
|
||||
updateContext state@InterpState{_ghci} = do
|
||||
logDebug state "|updateContext| CMD: :show context\n"
|
||||
msgs <- Ghcid.exec _ghci ":show context"
|
||||
let feedback = ParseContext.cleanResponse msgs
|
||||
logDebug
|
||||
state
|
||||
( "|updateContext| CMD: :show context\n|updateContext| OUT:\n"
|
||||
( "|updateContext| OUT:\n"
|
||||
`Text.append` ParseContext.linesToText msgs
|
||||
`Text.append` "\n"
|
||||
)
|
||||
if Text.null feedback
|
||||
then pure (emptyInterpreterState _ghci) -- We exited everything.
|
||||
@ -147,13 +155,13 @@ load state filepath = execMuted state (":l " ++ filepath)
|
||||
-- | Execute an arbitrary command, as if it was directly written in GHCi.
|
||||
exec :: (Monoid a) => InterpState a -> String -> IO (InterpState a, [String])
|
||||
exec state@InterpState{_ghci} cmd = do
|
||||
logDebug state ("|exec| CMD: " `Text.append` Text.pack cmd)
|
||||
msgs <- Ghcid.exec _ghci cmd
|
||||
logDebug
|
||||
state
|
||||
( "|exec| CMD: "
|
||||
`Text.append` Text.pack cmd
|
||||
`Text.append` "\n|exec| OUT:\n"
|
||||
`Text.append` Text.pack (intercalate "\n" msgs)
|
||||
( "|exec| OUT:\n"
|
||||
`Text.append` ParseContext.linesToText msgs
|
||||
`Text.append` "\n"
|
||||
)
|
||||
newState <- updateState state
|
||||
pure (newState, msgs)
|
||||
@ -164,6 +172,15 @@ execMuted state cmd = do
|
||||
(newState, _) <- exec state cmd
|
||||
pure newState
|
||||
|
||||
-- | @exec@, but clean the message from prompt.
|
||||
execCleaned :: (Monoid a) => InterpState a -> String -> IO (InterpState a, [String])
|
||||
execCleaned state cmd = do
|
||||
res <- cleaner <$> exec state cmd
|
||||
logDebug state ( "|cleaned|:\n" `Text.append` (Text.pack . unlines . snd $ res))
|
||||
pure res
|
||||
where
|
||||
cleaner (s, ls) = (s, Text.unpack <$> (Text.lines . ParseContext.cleanResponse) ls)
|
||||
|
||||
-- | Location info passed to *BreakpointLine functions.
|
||||
data BreakpointArg
|
||||
= -- | Location in the current file.
|
||||
@ -195,7 +212,7 @@ toggleBreakpointLine state loc
|
||||
|
||||
-- | Set a breakpoint at a given line.
|
||||
setBreakpointLine :: (Monoid a) => InterpState a -> BreakpointArg -> IO (InterpState a)
|
||||
setBreakpointLine state loc = execMuted state command
|
||||
setBreakpointLine state loc = execMuted state command
|
||||
where
|
||||
command =
|
||||
":break " ++ case loc of
|
||||
@ -204,8 +221,9 @@ setBreakpointLine state loc = execMuted state command
|
||||
let mod' = Text.unpack $ fromMaybe "" modM
|
||||
pos = maybe "" show posM
|
||||
colno = maybe "" show colnoM
|
||||
in if pos == "" then error "Cannot set breakpoint at unknown line number" else
|
||||
mod' ++ " " ++ pos ++ " " ++ colno
|
||||
in if pos == ""
|
||||
then error "Cannot set breakpoint at unknown line number"
|
||||
else mod' ++ " " ++ pos ++ " " ++ colno
|
||||
|
||||
-- | Delete a breakpoint at a given line.
|
||||
deleteBreakpointLine :: (Monoid a) => InterpState a -> BreakpointArg -> IO (InterpState a)
|
||||
@ -226,12 +244,12 @@ deleteBreakpointLine state loc =
|
||||
| (idx, otherML) <- state.breakpoints
|
||||
, otherML.modName == modName && otherML.linenoM == linenoM
|
||||
]
|
||||
|
||||
in case idxMaybe of
|
||||
Just num -> execMuted state (":delete " ++ show num)
|
||||
Nothing -> do
|
||||
putStrLn
|
||||
( "No breakpoint at "
|
||||
logDebug
|
||||
state
|
||||
( Text.pack $ "No breakpoint at "
|
||||
++ show loc
|
||||
++ "; breakpoints are found at "
|
||||
++ show state.breakpoints
|
||||
@ -240,10 +258,11 @@ deleteBreakpointLine state loc =
|
||||
|
||||
updateBreakList :: InterpState a -> IO (InterpState a)
|
||||
updateBreakList state@InterpState{_ghci} = do
|
||||
logDebug state "|updateBreakList| CMD: :show breaks\n"
|
||||
msgs <- Ghcid.exec _ghci ":show breaks"
|
||||
logDebug
|
||||
state
|
||||
( "|updateBreakList| CMD: :show breaks\n|updateBreakList| OUT:\n"
|
||||
( "|updateBreakList| OUT:\n"
|
||||
`Text.append` ParseContext.linesToText msgs
|
||||
)
|
||||
let response = ParseContext.cleanResponse msgs
|
||||
@ -269,17 +288,26 @@ getBpInFile s fp = catMaybes [loc.linenoF | loc <- breakpointlocs, loc.filepath
|
||||
-- | Log a message at the Debug level.
|
||||
logDebug :: (MonadIO m) => InterpState a -> Text.Text -> m ()
|
||||
logDebug s msg =
|
||||
liftIO $
|
||||
liftIO $ do
|
||||
when (num >= 3) $
|
||||
logHelper "[DEBUG]: " msg
|
||||
logHelper output "[DEBUG]: " msg
|
||||
where
|
||||
LogLevel num = s.logLevel
|
||||
output = logOutput s
|
||||
|
||||
logHelper :: (MonadIO m) => Text.Text -> Text.Text -> m ()
|
||||
logHelper prefix msg =
|
||||
liftIO $
|
||||
Text.putStrLn
|
||||
( Text.intercalate
|
||||
"\n"
|
||||
[prefix `Text.append` line | line <- Text.lines msg]
|
||||
)
|
||||
logHelper
|
||||
:: (MonadIO m)
|
||||
=> LogOutput
|
||||
-- ^ Where to log?
|
||||
-> Text.Text
|
||||
-- ^ prefix
|
||||
-> Text.Text
|
||||
-- ^ Message
|
||||
-> m ()
|
||||
logHelper outputLoc prefix msg = do
|
||||
liftIO $ case outputLoc of
|
||||
LogOutputFile path -> Text.appendFile path fmtMsg
|
||||
LogOutputStdOut -> Text.putStrLn fmtMsg
|
||||
_ -> error "Cannot log to that output configuration."
|
||||
where
|
||||
fmtMsg = Text.unlines [prefix `Text.append` line | line <- Text.lines msg]
|
||||
|
@ -35,7 +35,7 @@ instance Semigroup ModuleFileMap where
|
||||
ModuleFileMap a <> ModuleFileMap b = ModuleFileMap (a <> b)
|
||||
|
||||
instance Monoid ModuleFileMap where
|
||||
mempty = ModuleFileMap []
|
||||
mempty = ModuleFileMap mempty
|
||||
|
||||
-- | Convert a module to a FilePath
|
||||
getPathOfModule :: ModuleFileMap -> Text -> Maybe FilePath
|
||||
@ -53,4 +53,4 @@ toModuleLoc mfm fl = go <$> fl.filepath
|
||||
toFileLoc :: ModuleFileMap -> ModuleLoc -> Maybe FileLoc
|
||||
toFileLoc mfm ml = go <$> ml.modName
|
||||
where
|
||||
go = (\x -> FileLoc x ml.linenoM ml.colrangeM) . getPathOfModule mfm
|
||||
go = (\x -> FileLoc x ml.linenoM ml.colrangeM) . getPathOfModule mfm
|
||||
|
@ -129,8 +129,8 @@ parseShowBreaks t
|
||||
enabled = case mr.mrSubs ! 7 of
|
||||
"enabled" -> Right True
|
||||
"disabled" -> Right False
|
||||
x -> Left ("Breakpoint neither enabled nor disabled: " ++ unpack x)
|
||||
in Right (idx, Loc.ModuleLoc module_ lineno' (colStart, colEnd))
|
||||
x -> Left ("Breakpoint neither enabled nor disabled: " `append` x)
|
||||
in enabled >> Right (idx, Loc.ModuleLoc module_ lineno' (colStart, colEnd))
|
||||
|
||||
|
||||
parseShowModules :: Text -> Either Text [(Text, FilePath)]
|
||||
@ -160,4 +160,4 @@ include what we want fairly consistently.
|
||||
Additionally, pack the lines into a single Text block.
|
||||
-}
|
||||
cleanResponse :: [String] -> Text
|
||||
cleanResponse msgs = lastDef "" (splitBy ghcidPrompt (linesToText msgs))
|
||||
cleanResponse msgs = lastDef "" (splitBy ghcidPrompt (linesToText msgs))
|
||||
|
@ -1,10 +1,46 @@
|
||||
module StringUtil (splitBy) where
|
||||
|
||||
import Data.Text (Text, breakOn, drop, length)
|
||||
import Prelude hiding (drop, length)
|
||||
import Data.Text (Text, breakOn, drop, length, unlines, unsnoc, length)
|
||||
import Prelude hiding (drop, length, unlines)
|
||||
|
||||
splitBy :: Text -> Text -> [Text]
|
||||
-- | Split text based on a delimiter.
|
||||
splitBy
|
||||
:: Text
|
||||
-- ^ Delimeter.
|
||||
-> Text
|
||||
-- ^ Text to split on.
|
||||
-> [Text]
|
||||
splitBy delim source =
|
||||
case breakOn delim source of
|
||||
(l, "") -> [l]
|
||||
(l, r) -> l : splitBy delim (drop (length delim) r)
|
||||
|
||||
-- | Split text based on a predicate.
|
||||
-- splitByPred
|
||||
-- :: (Text -> Bool)
|
||||
-- -- ^ Predicate
|
||||
-- -> Text
|
||||
-- -- ^ Text to split on.
|
||||
-- -> [Text]
|
||||
-- splitByPred _ "" = []
|
||||
-- splitByPred pr toSplit = : splitByPred (restOf
|
||||
-- where
|
||||
-- restOf x = maybe mempty snd (uncons x)
|
||||
|
||||
-- | Cleans prompt data from the GHCID output.
|
||||
cleanPrompt
|
||||
:: Text
|
||||
-- ^ Prompt text to remove.
|
||||
-> [Text]
|
||||
-- ^ Input lines to clean.
|
||||
-> [Text]
|
||||
-- ^ Cleaned output
|
||||
cleanPrompt prompt ls =
|
||||
let sp = splitBy prompt (unlines ls)
|
||||
fileRangeOf t =
|
||||
maybe (0,0) (\(_, lastChar) ->
|
||||
if lastChar == ']'
|
||||
then (0, length t - 1)
|
||||
else (0, 0)
|
||||
) (unsnoc t)
|
||||
in sp
|
||||
|
Loading…
Reference in New Issue
Block a user