spade-0.1.0.6: src/IDE/IDE.hs
module IDE.IDE where
import Common
import Data.Text.Encoding (decodeUtf8)
import Compiler.Lexer
import Compiler.Parser
import Control.Concurrent
import Control.Concurrent.STM
import Control.Concurrent.STM.TSem
import Control.Exception
import Control.Monad
import Data.IORef
import qualified Data.List as DL
import Data.Map as Map
import Data.Maybe
import qualified Data.Set as S
import Data.Text as T
import Data.Text.IO as T
import System.Process (createPipe)
import qualified System.IO as SIO
import Compiler.AST.Program
import IDE.Common
import IDE.Help
import Interpreter
import Interpreter.Common
import Interpreter.Lib.Misc
import Interpreter.Initialize
import Parser.Parser
import UI.Widgets
import UI.Widgets.AutoComplete
import UI.Widgets.Layout
import UI.Widgets.TextContainer
import UI.Widgets.LogWidget
import UI.Widgets.WatchWidget
import UI.Widgets.TitledContainer
import UI.Widgets.OutputContainer
import DiffRender.DiffRender
import Data.Version (Version(..))
import Paths_spade (version)
data IDEDebugEnv = IDEDebugEnv
{ ideDebugIn :: TBQueue DebugIn
, ideDebugOut :: TBQueue DebugOut
, ideDebugThreadInputR :: SIO.Handle
, ideDebugThreadInputW :: SIO.Handle
, ideDebugThreadId :: Maybe ThreadId
}
data IDEState = IDEState
{ idsDebugEnv :: Maybe IDEDebugEnv
, idsCodeAutocompletions :: [(Text, Text)]
, idsCodeParseError :: Maybe (Location, Text)
, idsKeyInputReciever :: Maybe SomeKeyInputWidget
}
ideStartState :: IDEState
ideStartState = IDEState Nothing [] Nothing Nothing
resetIDEState :: IDEState -> IDEState
resetIDEState ids = ids { idsDebugEnv = Nothing, idsCodeParseError = Nothing, idsKeyInputReciever = Nothing }
type Clipboard = (Text -> IO (), IO (Maybe Text))
type IDEM a = WidgetM IO a
editorId :: Text
editorId = "editor"
watchWidgetId :: Text
watchWidgetId = "watch"
putStrLnFlush :: Text -> IO ()
putStrLnFlush s = do
T.putStrLn s
SIO.hFlush stdout
extractBuiltIns :: IO ([(Text, Text)], [(Text, Text)])
extractBuiltIns = do
sdlWindowsRef <- newIORef []
scope <- isGlobalScope . snd <$> runStateT loadBuiltIns (emptyIs sdlWindowsRef)
let keywords = (\x -> let s = toSource $ toEnum @Keyword x in (s, s)) <$> [0 .. fromEnum $ maxBound @Keyword]
let builtIns = DL.foldl' extractOneDoc [] (Map.assocs scope)
pure (keywords, builtIns)
where
extractOneDoc :: [(Text, Text)] -> (ScopeKey, Value) -> [(Text, Text)]
extractOneDoc in_ (SkIdentifier (unIdentifer ->ide), BuiltIn (BuiltinVal (ObjectValue m))) =
in_ <> ((\k -> let a = ide <> "." <> k in (a, a)) <$> Map.keys m)
extractOneDoc in_ (SkIdentifier ide, BuiltIn (BuiltinCallWithDoc s)) =
(unIdentifer ide <> "()", T.concat [
unIdentifer ide,
"(",
T.intercalate ", " ((\(l, r) -> T.concat [l, ": ", r]) <$> extractDoc s),
")"
]
) : in_
extractOneDoc in_ (SkIdentifier ide, BuiltIn (BuiltinCall _)) = (unIdentifer ide, unIdentifer ide) : in_
extractOneDoc in_ (SkOperator op, _) = (toSource op, toSource op) : in_
extractOneDoc in_ _ = in_
getAutocompleteSuggestions :: MonadIO m => TVar IDEState -> [(Text, Text)] -> Text -> m [(Text, Text)]
getAutocompleteSuggestions ideStateRef dict key = do
acs <- liftIO $ idsCodeAutocompletions <$> readTVarIO ideStateRef
pure $ Prelude.filter fn (acs <> dict)
where
fn :: (Text, Text) -> Bool
fn (i, _) = T.isPrefixOf key i
-- This thread reads the editor contents and try to parse into
-- tokens and ast. And then fills some autocomplete suggestions and
-- makes any parse error location.
codeProcessingThread :: IORef [Token] -> TChan IDEEvent -> MVar Text -> IO ()
codeProcessingThread tokensRef ideEventRef editorContentRef = forever $ flip catch handler $ do
liftIO $ atomically $ writeTChan ideEventRef IDEReqEditorContent
code <- takeMVar editorContentRef
tokens <- tokenize code
liftIO $ writeIORef tokensRef tokens
mError <- parseEither @Program tokens >>= \case
Left (ParseErrorWithParsed _ loc (FatalError a)) -> pure $ Just (loc, T.pack $ show a)
Left (ParseErrorWithParsed _ _ (FatalErrorWithLocation loc fpe)) -> pure $ Just (loc, T.pack $ show fpe)
_ -> pure Nothing
liftIO $ atomically $ writeTChan ideEventRef $ IDEParseErrorUpdate mError
liftIO $ atomically $ writeTChan ideEventRef $ IDEACUpdateIdentifiers $ S.toList $ S.fromList $ catMaybes $ filterIdentifiers <$> tokens
wait 1
where
handler :: SomeException -> IO ()
handler e = liftIO $ atomically $ writeTChan ideEventRef $ IDEAppendLog (T.pack $ show e)
filterIdentifiers :: Token -> Maybe Text
filterIdentifiers Token { tkRaw = (TkIdentifier (unIdentifer -> idf))} = Just idf
filterIdentifiers _ = Nothing
-- | A type to differentiat debuging mode in IDE when input events
-- need to be fed to the interpreted program, and not to the IDE.
data InputRouting
= RouteIDE
| RouteProgram SIO.Handle
instance Show InputRouting where
show RouteIDE = "Route To IDE"
show (RouteProgram _) = "Route To Program"
runIDE :: FilePath -> TChan TerminalEvent -> TMVar (TBQueue DebugIn) -> IO ()
runIDE filePath inputChan interpreterDebugInChanRef = do
content <- try (T.readFile filePath) >>= \case
Right c -> pure c
Left (_ :: SomeException) -> pure ""
(keywords, builtIns) <- extractBuiltIns
ideStateRef <- newTVarIO ideStartState
ideEventsRef <- newTChanIO
atomically $ writeTChan ideEventsRef (IDEAppendLog ("Loaded file: " <> (T.pack filePath)))
clipboardRef <- newIORef @(Maybe Text) Nothing
let clipboard = (\t -> modifyIORef clipboardRef (\_ -> Just t), readIORef clipboardRef)
editorContentMVar <- newEmptyMVar @Text
tokensRef <- newIORef @[Token] []
void $ forkIO $ codeProcessingThread tokensRef ideEventsRef editorContentMVar
inputRouteToRef <- newTVarIO RouteIDE
void $ liftIO $ forkIO $ forever $ do
kv <- atomically $ readTChan inputChan
(atomically $ readTVar inputRouteToRef) >>= \case
RouteIDE -> atomically $ writeTChan ideEventsRef (IDETerminalEvent kv)
RouteProgram handle' -> pushTerminalEventToHandle handle' kv
void $ runWidgetM $ do
-- The editor
editorRef <- editor (getAutocompleteSuggestions ideStateRef (keywords <> builtIns)) (Just $ SomeTokenStream (readIORef tokensRef))
modifyWRef editorRef (\ew' -> ew' { ewParams = (ewParams ew') { epLinenumberRightPad = 1, epBorder = False }})
setContent editorRef content
liftIO $ atomically $ modifyTVar ideStateRef (\ids -> ids { idsKeyInputReciever = Just $ SomeKeyInputWidget editorRef })
-- Output widget
(programOutputHandleR, programOutputHandleW) <- liftIO createPipe
outputWidgetRef <- outputContainer programOutputHandleR
titledOutputRef <- titledContainer (SomeWidgetRef outputWidgetRef) " OUTPUT "
modifyWRef titledOutputRef setVertical
setVisibility titledOutputRef False
-- Watch widget
watchWidgetRef <- watchWidget
titledWatchRef <- titledContainer (SomeWidgetRef watchWidgetRef) " Watch "
let dimensionDistributionFnMain = \case
1 -> [1]
2 -> [0.5, 0.5]
a -> error $ "Unsupported widget count:" <> show a
let dimensionDistributionFn = \case
1 -> [1]
2 -> [0.85, 0.15]
3 -> [0.70, 0.15, 0.15]
4 -> [0.55, 0.15, 0.15, 0.15]
a -> error $ "Unsupported widget count:" <> show a
logRef <- logWidget
titledLogRef <- titledContainer (SomeWidgetRef logRef) " Log "
helpWidgetRef <- helpWidget ((Prelude.head . T.split (== '.'). fst) <$> builtIns) ideEventsRef
-- The autocomplete widget
ac <- autoComplete
modifyWRef editorRef (\ed -> ed { ewAutocompleteWidget = Just $ SomeWidgetRef ac })
-- The aboutbox widget
aboutText <- textContainer (ScreenPos 0 0) (Dimensions 58 12)
let versionString = T.intercalate "." $ ((T.pack . show) <$> versionBranch version)
let aboutContent =
(T.replicate 24 " ") <> "S.P.A.D.E" <> "\n"
<> (T.replicate 24 " ") <> "=========" <> "\n\n"
<> " A Simple Programming And Debugging Environment" <> "\n"
<> " ______________________________________________" <> "\n\n"
<> " Version " <> versionString <> "\n\n\n"
<> " Copyright (C) 2022 Sandeep.C.R" <> "\n\n\n"
<> " Press Esc to close"
setContent aboutText aboutContent
aboutBox <- borderBox (ScreenPos 10 16) (Dimensions 60 16) (SomeWidgetRef aboutText)
setVisibility aboutBox False
-- The Outermost layout
layoutRef' <- layoutWidget Horizontal dimensionDistributionFnMain
layoutRef <- layoutWidget Vertical dimensionDistributionFn
modifyWRef layoutRef (\lw -> lw { lowFloatingContent = [SomeWidgetRef ac] })
modifyWRef layoutRef' (\lw -> lw { lowFloatingContent = [SomeWidgetRef aboutBox] })
addWidget layoutRef editorId editorRef
addWidget layoutRef "helpwidget" helpWidgetRef
addWidget layoutRef "watch" titledWatchRef
addWidget layoutRef "log" titledLogRef
addWidget layoutRef' "editorlayout" layoutRef
addWidget layoutRef' "output" titledOutputRef
setVisibility helpWidgetRef False
setVisibility titledWatchRef False
-- The menu
let menu = Menu
[ ("File", SubMenu ["Save (F6)", "Beautify", "Exit"])
, ("Edit", SubMenu ["Cut", "Copy", "Paste", "Select All"])
, ("Run", SubMenu ["Run (F5)", "Step (F8)", "Stop (F9)"])
, ("Windows", SubMenu ["Clear log", "Clear Output", "Toggle Output"])
, ("Help", SubMenu ["About", "Contents"])
] Nothing (Just $ T.pack filePath)
menuContainerRef <- menuContainer (SomeWidgetRef layoutRef') menu (selectionHandler ideEventsRef)
modify $ liftWSMod (\ws -> ws { wsCursorWidget = Just $ SomeKeyInputWidget editorRef })
-- A snippet that refresh the screen.
let
ideRedraw :: WidgetC m => m ()
ideRedraw = do
csClear
draw menuContainerRef
csDraw
let
getActiveEditor :: WidgetC m => m (WRef EditorWidget)
getActiveEditor = do
(getVisibility editorRef) >>= \case
True -> pure editorRef
_ -> getVisibility helpWidgetRef >>= \case
True -> hwContentWidget <$> (readWRef helpWidgetRef)
_ -> error "No visible editor"
let
launchProgram
:: forall m. WidgetC m
=> m (Either Text IDEDebugEnv, Maybe TSem)
launchProgram = do
source <- getContent editorRef
(pOutHandle, outputScreenOffset, outputScreenSize, mOutBufLock) <- getVisibility titledOutputRef >>= \case
True -> do
screenSize <- getDim outputWidgetRef
outputPos <- getPos outputWidgetRef
outBufLock <- liftIO $ atomically $ newTSem 1
pure (programOutputHandleW, outputPos, screenSize, Just outBufLock)
False -> do
clearscreen
screenSize <- (diffRenderToDimension . usDiffRender) <$> get
pure (SIO.stdout, ScreenPos 0 0, screenSize, Nothing)
liftIO $ do
compileEither source >>= \case
Right p -> do
debugIn <- atomically (newTBQueue 10)
debugOut <- atomically (newTBQueue 10)
let
handler :: SomeException -> IO ()
handler e = do
atomically (writeTBQueue debugOut (Errored (T.pack $ show e)))
(programInputHandleR, programInputHandleW) <- liftIO createPipe
let ideDebugEnv = IDEDebugEnv debugIn debugOut programInputHandleR programInputHandleW Nothing
void $ forkOS $ do
thisThreadId <- myThreadId
startMode <- atomically $ do
-- Initialize IDE debuggins state
dIn <- readTBQueue debugIn
check (dIn == Start || dIn == StartStep) -- Wait till the Start command
modifyTVar ideStateRef
(\idestate ->
idestate
{ idsDebugEnv = Just $ ideDebugEnv { ideDebugThreadId = Just thisThreadId }
})
pure dIn
let
stateFn = case startMode of
StartStep -> (\is -> is
{ isInputHandle = programInputHandleR
, isRunMode = DebugMode $ DebugEnv SingleStep debugIn debugOut
, isOutputHandle = pOutHandle
, isTerminalParams = Just (outputScreenOffset, outputScreenSize)
, isStdoutLock = mOutBufLock
})
Start -> (\is -> is
{ isRunMode = DebugMode (DebugEnv Continue debugIn debugOut)
, isInputHandle = programInputHandleR
, isOutputHandle = pOutHandle
, isTerminalParams = Just (outputScreenOffset, outputScreenSize)
, isStdoutLock = mOutBufLock
})
_ -> error "Impossible!"
flip catch handler (void $ do
void $ interpret stateFn p
atomically (writeTBQueue debugOut (Finished False))
)
-- Reset IDE debuggins state
void $ atomically $ do
readTBQueue debugIn >>= (check . (== Stop)) -- Wait till the stop command
void $ takeTMVar interpreterDebugInChanRef
modifyTVar ideStateRef
(\idestate ->
idestate
{ idsDebugEnv = Nothing
})
atomically $ putTMVar interpreterDebugInChanRef debugIn
pure (Right ideDebugEnv, mOutBufLock)
Left err -> do
pure (Left (hReadable err), mOutBufLock)
uiLoop ideEventsRef (\case
IDEShowAbout -> do
mc <- readWRef menuContainerRef
setVisibility aboutBox True
adim <- getDim aboutBox
move aboutBox (ScreenPos ((div (diW $ mcwDim mc) 2) - (div (diW adim) 2)) 20)
ideRedraw
pure True
IDEToggleOutput -> do
getVisibility titledOutputRef >>= \case
True -> setVisibility titledOutputRef False
False -> setVisibility titledOutputRef True
ideRedraw
pure True
IDEHideAbout -> do
setVisibility aboutBox False
ideRedraw
pure True
IDEToggleHelp -> do
getVisibility helpWidgetRef >>= \case
True -> do
setVisibility helpWidgetRef False
setVisibility editorRef True
setVisibility watchWidgetRef True
modify $ liftWSMod (\ws -> ws { wsCursorWidget = Just $ SomeKeyInputWidget editorRef })
liftIO $ atomically (modifyTVar ideStateRef (\is -> is { idsKeyInputReciever = Just $ SomeKeyInputWidget editorRef }))
False -> do
setVisibility helpWidgetRef True
setVisibility editorRef False
setVisibility watchWidgetRef False
modify $ liftWSMod (\ws -> ws { wsCursorWidget = Just $ SomeKeyInputWidget helpWidgetRef })
liftIO $ atomically (modifyTVar ideStateRef (\is -> is { idsKeyInputReciever = Just $ SomeKeyInputWidget helpWidgetRef }))
d <- getScreenBounds
csInitialize d
draw menuContainerRef
csDraw
pure True
IDEStop -> do
idsDebugEnv <$> (liftIO $ readTVarIO ideStateRef) >>= \case
Just ideDebugEnv -> case ideDebugThreadId ideDebugEnv of
Just threadId -> do
liftIO $ killThread threadId
waitTill (\_ -> True) (ideDebugOut ideDebugEnv) >>=
processDebugOut ideEventsRef ideStateRef logRef editorRef (ideDebugIn ideDebugEnv)
Nothing ->
insertLog logRef "No thread running"
Nothing ->
insertLog logRef "Interpreter is not running"
pure True
IDESave -> do
c <- getContent editorRef
liftIO $ T.writeFile filePath c
insertLog logRef ("Saved to " <> (T.pack filePath) <>".")
pure True
IDEEdit Copy -> do
ew <- getActiveEditor >>= readWRef
case selectionToTuple <$> (ewSelection ew) of
Just (r1, r2) -> let
contents = ewContent ew
removeLength = (r2 - r1 + 1)
copyContent = T.take (removeLength + 1) (T.drop r1 contents)
in liftIO $ (fst clipboard) copyContent
Nothing -> pass
pure True
IDEEdit Cut -> do
modifyWRefM editorRef (\ew -> case (selectionToTuple <$> ewSelection ew) of
Just (r1, r2) -> let
contents = ewContent ew
(p1, p2) = T.splitAt r1 contents
removeLength = (r2 - r1 + 1)
cutContent = T.take removeLength p2
in do
liftIO $ (fst clipboard) cutContent
let newCursor = max 0 (r1 - 1)
pure $ putCursor Nothing newCursor $ ew { ewSelection = Nothing, ewContent = p1 <> (T.drop removeLength p2) }
Nothing -> pure ew
)
ideRedraw
pure True
IDEEdit Paste -> do
modifyWRefM editorRef (\ew -> do
let
contents = ewContent ew
(p1, p2) = T.splitAt (ewCursor ew) contents
(liftIO (snd clipboard)) >>= \case
Nothing -> pure ew
Just insertContent ->
pure $ putCursor Nothing (ewCursor ew + T.length insertContent) $ ew { ewContent = p1 <> insertContent <> p2 }
)
ideRedraw
pure True
IDEEdit SelectAll -> do
modifyWRef editorRef (\ew -> ew { ewSelection = Just $ SelectionInfo 0 0 ((T.length $ ewContent ew) - 1) })
ideRedraw
pure True
IDEClearLog -> do
modifyWRef logRef (\lw -> lw { lwContent = [] })
pure True
IDEClearOutput -> do
clearOutput outputWidgetRef
pure True
IDEAppendLog msg -> do
insertLog logRef msg
pure True
IDEBeautify -> do
insertLog logRef "Formatting..."
code <- getContent editorRef
(liftIO $ compileEither @Program code) >>= \case
Right a -> do
setContent editorRef (T.strip $ toSource a)
liftIO $ atomically $ writeTChan ideEventsRef IDEClearDraw
Left (ParseErrorWithParsed _ _ e) -> insertLog logRef ("Parse error:" <> T.pack (show e))
pure True
IDEDraw -> do
pure True
IDEClearDraw -> do
d <- getScreenBounds
csInitialize d
draw menuContainerRef
csDraw
pure True
IDEACUpdateIdentifiers acs -> do
liftIO $ atomically (modifyTVar ideStateRef (\is -> is { idsCodeAutocompletions = (\x -> (x, x)) <$> acs }))
pure True
IDEParseErrorUpdate mError -> do
liftIO $ atomically (modifyTVar ideStateRef (\is -> is { idsCodeParseError = mError }))
idestate <- liftIO $ readTVarIO ideStateRef
case idsCodeParseError idestate of
Just (loc, _) -> modifyWRef editorRef (\ew -> ew { ewParseErrorLocation = Just loc })
Nothing -> modifyWRef editorRef (\ew -> ew { ewParseErrorLocation = Nothing })
ideRedraw
pure True
IDEReqEditorContent -> do
c <- getContent editorRef
liftIO $ void $ putMVar editorContentMVar c
pure True
IDEExit -> do
pure False
IDERun -> do
idsDebugEnv <$> liftIO (readTVarIO ideStateRef) >>= \case
-- If we are in a debug session, just run to completion.
(Just ideDebugEnv) -> do
insertLog logRef "Continuing debug session to end..."
liftIO $ atomically $ do
writeTBQueue (ideDebugIn ideDebugEnv) Run
writeTVar inputRouteToRef (RouteProgram $ ideDebugThreadInputW ideDebugEnv)
waitTill (\_ -> True) (ideDebugOut ideDebugEnv) >>=
processDebugOut ideEventsRef ideStateRef logRef editorRef (ideDebugIn ideDebugEnv)
liftIO $ atomically $ do
writeTChan ideEventsRef IDEClearDraw
writeTVar inputRouteToRef RouteIDE
_ -> do
-- Or else launch a new run of the program.
setCursorPosition 0 0
launchProgram >>= \case
(Right ideDebugEnv, mStdoutLock) -> do
insertLog logRef "Starting..."
liftIO $ atomically $ do
writeTBQueue (ideDebugIn ideDebugEnv) Start
writeTVar inputRouteToRef (RouteProgram $ ideDebugThreadInputW ideDebugEnv)
-- Keep the display updated in another thread
-- A flag is used to end this display update thread
-- as the conventional way of using killThread to kill
-- it appeared to not work sometimes. Probably because the
-- waitings involved inside it.
mDisplayThreadExitFlag <- liftIO (newTVarIO False)
mDisplayUpdateThread <- case mStdoutLock of
Nothing -> pure False
Just sem -> do
ws <- get
_ <- (liftIO $ forkIO $ let
go = do
liftIO $ atomically $ waitTSem sem
void $ runWidgetM'' ws ideRedraw
liftIO $ atomically $ signalTSem sem
wait 0.1
liftIO $ readTVarIO mDisplayThreadExitFlag >>= \case
True -> pure ()
_ -> go
in go)
pure True
waitTill (\_ -> True) (ideDebugOut ideDebugEnv) >>=
processDebugOut ideEventsRef ideStateRef logRef editorRef (ideDebugIn ideDebugEnv)
if mDisplayUpdateThread
then liftIO $ atomically $ writeTVar mDisplayThreadExitFlag True
else pass
liftIO $ atomically $ do
writeTChan ideEventsRef IDEClearDraw
writeTVar inputRouteToRef RouteIDE
(Left err, _) -> do
insertLog logRef $ "Compile Error: " <> err
liftIO $ atomically $ writeTChan ideEventsRef IDEClearDraw
pure True
IDEStep -> do
csSetCursorPosition 0 0
idsDebugEnv <$> liftIO (readTVarIO ideStateRef) >>= \case
-- A debugging session exists already.
-- Send the step command, wait for updated state to arrive.
(Just ideDebugEnv) -> do
-- Get current interpreter statement location
(liftIO $ atomically $ tryReadTBQueue (ideDebugOut ideDebugEnv)) >>= \case
Just debugOut -> do
processDebugOut ideEventsRef ideStateRef logRef editorRef (ideDebugIn ideDebugEnv) debugOut
Nothing -> pass
liftIO $ atomically $ do
writeTBQueue (ideDebugIn ideDebugEnv) StepIn
writeTVar inputRouteToRef (RouteProgram $ ideDebugThreadInputW ideDebugEnv)
-- Wait till the interpreter moves to the next location
(liftIO $ atomically $ readTBQueue (ideDebugOut ideDebugEnv)) >>=
processDebugOut ideEventsRef ideStateRef logRef editorRef (ideDebugIn ideDebugEnv)
liftIO $ atomically $ do
writeTVar inputRouteToRef RouteIDE
_ -> do
-- No debugging session exist. Launch one.
launchProgram >>= \case
(Right ideDebugEnv, _) -> do
liftIO $ atomically $ do
writeTBQueue (ideDebugIn ideDebugEnv) StartStep
writeTBQueue (ideDebugIn ideDebugEnv) StepIn
writeTVar inputRouteToRef (RouteProgram $ ideDebugThreadInputW ideDebugEnv)
-- Wait till the interpreter moves to the first location
(liftIO $ atomically $ readTBQueue (ideDebugOut ideDebugEnv)) >>=
processDebugOut ideEventsRef ideStateRef logRef editorRef (ideDebugIn ideDebugEnv)
liftIO $ atomically $ do
writeTVar inputRouteToRef RouteIDE
(Left err, _) -> insertLog logRef $ "Compile Error: " <> err
pure True
IDEDebugUpdate mds -> do
case mds of
Just ds -> do
items <- liftIO $ scopeToWatchItems $ dsScope ds
modifyWRef editorRef (\ew -> putCursor Nothing (lcOffset (dsLocation ds)) $ ew { ewReadOnly = True, ewDebugLocation = Just $ dsLocation ds })
modifyWRef titledWatchRef (\twr -> setTitle twr $ wrapInSpace ("Watching Thread: " <> dsThreadName ds))
setVisibility titledWatchRef True
modifyWRef watchWidgetRef (\ww -> ww { wwVisible = True, wwContent = items })
case dsCurrenEvaluation ds of
Just cv -> insertLog logRef ("Evaluating: " <> cv)
Nothing -> pass
Nothing -> do
modifyWRef titledWatchRef (\twr -> setTitle twr "Watch")
modifyWRef editorRef (\ew -> ew { ewReadOnly = False, ewDebugLocation = Nothing })
setVisibility titledWatchRef False
liftIO $ atomically $ writeTChan ideEventsRef IDEClearDraw
pure True
IDETerminalEvent TerminalInterrupt -> pure False
IDETerminalEvent (TerminalResize w h) -> do
let dim' = Dimensions w h
csInitialize dim'
modifyWRef menuContainerRef (\mc -> mc { mcwDim = dim' })
draw menuContainerRef
adjustScrollOffset editorRef
draw menuContainerRef
csDraw
pure True
IDETerminalEvent (TerminalKey ev) -> case ev of
KeyChar True _ _ 'c' -> pure False
KeyChar True _ _ 'C' -> pure False
k -> do
updateMenuOnKey ideEventsRef menuContainerRef k >>= \case
True -> pure ()
False -> shortcutsHandler ideEventsRef k >>= \case
True -> pure ()
False -> do
case k of
KeyCtrl _ _ _ Del -> liftIO $ atomically $ writeTChan ideEventsRef (IDEEdit Cut)
_ -> pass
idsKeyInputReciever <$> (liftIO $ readTVarIO ideStateRef) >>= \case
Just (SomeKeyInputWidget w) -> handleInput w k
Nothing -> pure ()
idestate <- liftIO $ readTVarIO ideStateRef
case idsCodeParseError idestate of
Just (loc, _) -> modifyWRef editorRef (\ew -> ew { ewParseErrorLocation = Just loc })
Nothing -> modifyWRef editorRef (\ew -> ew { ewParseErrorLocation = Nothing })
ideRedraw
pure True
)
clearscreen
setCursorPosition 0 0
where
waitTill
:: MonadIO m
=> (DebugOut -> Bool)
-> TBQueue DebugOut
-> m DebugOut
waitTill pred_ debugOut = do
(liftIO $ atomically $ readTBQueue debugOut) >>= \case
a@(pred_ -> True) -> pure a
_ -> waitTill pred_ debugOut
processDebugOut
:: forall m. (HasCallStack, WidgetC m)
=> TChan IDEEvent
-> TVar IDEState
-> WRef LogWidget
-> WRef EditorWidget
-> TBQueue DebugIn
-> DebugOut
-> m ()
processDebugOut ideEventRef ideStateRef logRef editorRef debugIn dout = do
case dout of
-- Update the IDE debug state with the received debug state.
DebugData ds -> do
liftIO $ atomically $ writeTChan ideEventRef (IDEDebugUpdate $ Just ds)
Errored err -> do
liftIO $ atomically $ modifyTVar ideStateRef (\i -> (resetIDEState i) { idsKeyInputReciever = idsKeyInputReciever i })
modifyWRef editorRef (\ew -> ew { ewReadOnly = False })
insertLog logRef err
liftIO $ atomically $ do
writeTBQueue debugIn Stop
writeTChan ideEventRef (IDEDebugUpdate Nothing)
Finished isUserInterrupt -> do
modifyWRef editorRef (\ew -> ew { ewReadOnly = False })
liftIO $ atomically $ modifyTVar ideStateRef (\i -> (resetIDEState i) { idsKeyInputReciever = idsKeyInputReciever i })
insertLog logRef (if isUserInterrupt then "User Interrupt" else "Finished program")
liftIO $ atomically $ do
writeTBQueue debugIn Stop
writeTChan ideEventRef (IDEDebugUpdate Nothing)
updateMenuOnKey :: WidgetC m => TChan IDEEvent -> WRef MenuContainerWidget -> KeyEvent -> m Bool
updateMenuOnKey ideEventsRef ref kv = do
w <- readWRef ref
case (kv, menuActive $ mcwMenu w) of
(KeyCtrl _ _ _ Esc, Just _) -> do
modifyWRef ref (\w' -> w' { mcwMenu = (mcwMenu w) { menuActive = Nothing }})
setCursorVisibility True
pure True
(KeyCtrl _ _ _ Esc, _) -> do
liftIO $ atomically $ writeTChan ideEventsRef IDEHideAbout
pure False -- Let Esc key bubble
(KeyChar _ _ True c, _) -> do
foldM_ (\x (n, _) -> case T.uncons (T.toLower n) of
Nothing -> pure $ x + 1
Just (c1, _) ->
if c == c1
then do
modifyWRef ref (\w' -> w' { mcwMenu = (mcwMenu w) { menuActive = Just (x, 0) }})
setCursorVisibility False
pure $ x + 1
else
pure $ x + 1) 0 (menuItems $ mcwMenu w)
pure True
(KeyCtrl _ _ _ ArrowLeft, Just (x, _))
| x > 0 -> do
modifyWRef ref (\w' -> w' { mcwMenu = (mcwMenu w) { menuActive = Just (x - 1, 0) }})
pure True
| otherwise -> do
modifyWRef ref (\w' -> w' { mcwMenu = (mcwMenu w) { menuActive = Just (Prelude.length (menuItems $ mcwMenu w) - 1, 0) }})
pure True
(KeyCtrl _ _ _ ArrowRight, Just (x, _)) -> do
let menuItemsLength = Prelude.length $ menuItems $ mcwMenu w
let newX = x + 1
if newX < menuItemsLength
then do
modifyWRef ref (\w' -> w' { mcwMenu = (mcwMenu w) { menuActive = Just (newX, 0) }})
pure True
else do
modifyWRef ref (\w' -> w' { mcwMenu = (mcwMenu w) { menuActive = Just (0, 0) }})
pure True
(KeyCtrl _ _ _ ArrowUp, Just (x, y))
| y > 0 -> do
modifyWRef ref (\w' -> w' { mcwMenu = (mcwMenu w) { menuActive = Just (x, y - 1) }})
pure True
| otherwise -> do
case getSubmenuAt (mcwMenu w) x of
Nothing -> pure True
Just (SubMenu smi) -> do
modifyWRef ref (\w' -> w' { mcwMenu = (mcwMenu w) { menuActive = Just (x, Prelude.length smi - 1) }})
pure True
(KeyCtrl _ _ _ ArrowDown, Just (x, y)) -> do
case getSubmenuAt (mcwMenu w) x of
Just (SubMenu smi) -> do
let newY = y + 1
if newY < (Prelude.length smi)
then do
modifyWRef ref (\w' -> w' { mcwMenu = (mcwMenu w) { menuActive = Just (x, newY) }})
pure True
else do
modifyWRef ref (\w' -> w' { mcwMenu = (mcwMenu w) { menuActive = Just (x, 0) }})
pure True
Nothing -> pure True
(KeyCtrl _ _ _ Return, Just (x, y)) -> do
(mcwSelectionHandler w) ref (x, y)
setCursorVisibility True
pure True
_ -> pure False
scopeToWatchItems :: Scope -> IO [(Text, Text)]
scopeToWatchItems s = foldM (\o (k, v) -> do
let
vKey = case k of
SkIdentifier i -> unIdentifer i
SkOperator op -> T.pack $ show op
vText <- case v of
ErrorValue t -> pure $ Just $ "Error: " <> t
v' ->
catch (fst <$> (runInterpretM dummyIS ((Just . decodeUtf8) <$> serializeJSON v'))) (\case
UnserializeableValue -> pure Nothing
e -> pure $ Just $ "Error: " <> (T.pack $ show e))
case vText of
Just t -> pure $ (vKey, t) : o
Nothing -> pure o
) [] (Map.assocs s)
selectionHandler
:: forall m. WidgetC m
=> TChan IDEEvent
-> WRef MenuContainerWidget
-> (Int, Int)
-> m ()
selectionHandler ideEventsRef ref selection = do
case selection of
(0, 0) -> liftIO $ atomically $ writeTChan ideEventsRef IDESave
(0, 1) -> liftIO $ atomically $ writeTChan ideEventsRef IDEBeautify
(0, 2) -> liftIO $ atomically $ writeTChan ideEventsRef IDEExit
(1, 0) -> liftIO $ atomically $ writeTChan ideEventsRef (IDEEdit Cut)
(1, 1) -> liftIO $ atomically $ writeTChan ideEventsRef (IDEEdit Copy)
(1, 2) -> liftIO $ atomically $ writeTChan ideEventsRef (IDEEdit Paste)
(1, 3) -> liftIO $ atomically $ writeTChan ideEventsRef (IDEEdit SelectAll)
(2, 0) -> liftIO $ atomically $ writeTChan ideEventsRef IDERun
(2, 1) -> liftIO $ atomically $ writeTChan ideEventsRef IDEStep
(2, 2) -> liftIO $ atomically $ writeTChan ideEventsRef IDEStop
(3, 0) -> liftIO $ atomically $ writeTChan ideEventsRef IDEClearLog
(3, 1) -> liftIO $ atomically $ writeTChan ideEventsRef IDEClearOutput
(3, 2) -> liftIO $ atomically $ writeTChan ideEventsRef IDEToggleOutput
(4, 0) -> liftIO $ atomically $ writeTChan ideEventsRef IDEShowAbout
(4, 1) -> liftIO $ atomically $ writeTChan ideEventsRef IDEToggleHelp
_ -> pass
modifyWRef ref (\mcw -> mcw { mcwMenu = (mcwMenu mcw) { menuActive = Nothing } })
liftIO $ atomically $ writeTChan ideEventsRef IDEClearDraw
shortcutsHandler
:: forall m. WidgetC m
=> TChan IDEEvent
-> KeyEvent
-> m Bool
shortcutsHandler ideEventRef kv = do
case kv of
KeyCtrl _ _ _ (Fun 6) -> do
liftIO $ atomically $ writeTChan ideEventRef IDESave
pure True
KeyCtrl _ _ _ (Fun 1) -> do
liftIO $ atomically $ writeTChan ideEventRef IDEToggleHelp
pure True
KeyCtrl _ _ _ (Fun 9) -> do
liftIO $ atomically $ writeTChan ideEventRef IDEStop
pure True
KeyCtrl _ _ _ (Fun 8) -> do
liftIO $ atomically $ writeTChan ideEventRef IDEStep
pure True
KeyCtrl _ _ _ (Fun 5) -> do
liftIO $ atomically $ writeTChan ideEventRef IDERun
pure True
_ -> pure False