diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,6 +1,13 @@ # Changelog for S.P.A.D.E -## Unreleased changes +## 0.1.0.6 + +* Added an output window within IDE. +* Added 'Run > Stop' menu item to kill the interpreter thread anytime. +* Ctrl-C during interpreter execution drops to debug mode. +* Make delete key to delete the selection, if there was one. +* A fix for backward selection weirdness where the selection follows cursor. +* Add 'debug' command to debug stdin behavior. ## 0.1.0.5 * Fix bug that caused the ide to freeze when the loaded program is run for diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -26,10 +26,7 @@ sample programs in the "samples" folder in this repo. ### IDE Demo -A small screen recording of SPADE in action can be seen here. It shows writing -a small program, and then using the in-built documentation and debugger. - -[![asciicast](https://asciinema.org/a/bG7PPKj0AaJq087ZNPxSZwcCl.svg)](https://asciinema.org/a/bG7PPKj0AaJq087ZNPxSZwcCl) +A short screen recording of SPADE in action can be seen [here](https://vimeo.com/692243011). ### Installing diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,12 +1,13 @@ module Main where -import Paths_spade (version) import Control.Concurrent import Control.Concurrent.STM import Control.Monad import Control.Monad.IO.Class import Data.Text as T import Data.Text.IO as T +import Main.Utf8 (withUtf8) +import Paths_spade (version) import System.Environment import System.IO as SIO import qualified System.Terminal as TERM @@ -15,17 +16,20 @@ import Compiler.Parser import IDE.IDE import Interpreter +import Interpreter.Common import UI.Widgets.Common data CommandLineOptions = StartIDE FilePath | RunProgram FilePath + | DebugInput | Version getCommandLineOption :: IO CommandLineOptions getCommandLineOption = do getArgs >>= \case ["version"] -> pure Version + ["debug"] -> pure DebugInput ["run", filePath] -> pure $ RunProgram filePath [filePath] -> pure $ StartIDE filePath [] -> pure $ StartIDE "untitled.spd" @@ -33,12 +37,12 @@ error "Unrecognized cmd line arguments. Pass a file name (existing or new) to load the program in the IDE, or using 'spade run filename.spd' command to just run the program without starting the IDE." main :: IO () -main = do +main = withUtf8 $ do SIO.hSetEcho stdin False SIO.hSetBuffering stdin NoBuffering SIO.hSetBuffering stdout (BlockBuffering Nothing) - interpreterThreadRef <- newEmptyTMVarIO + interpreterDebugInChanRef <- newEmptyTMVarIO -- Storing the thred id for the interpreter thread that runs the program -- in the IDE seems to be the most simple way to handle ctrl-c termination of the -- interpreted program. We catch the signal in the intputForwardingThread below @@ -55,22 +59,36 @@ forever $ do keys' <- readTerminalEvent case keys' of - (TerminalInterrupt : _) -> liftIO $ do - (atomically $ tryReadTMVar interpreterThreadRef) >>= \case - Just threadId -> killThread threadId - Nothing -> pass + (TerminalInterrupt : _) -> + liftIO $ atomically $ do + (tryReadTMVar interpreterDebugInChanRef) >>= \case + Just debugInChan -> writeTBQueue debugInChan StartStep + Nothing -> pass _ -> pass liftIO $ mapM_ writeFn keys' ) getCommandLineOption >>= \case Version -> T.putStrLn $ T.pack $ show version + DebugInput -> do + -- print data read from stdin for 10 seconds. + T.putStrLn "Will print input from stdin for 10 seconds..." + SIO.hFlush stdout + threadId <- forkIO $ forever $ do + ks <- readKey + T.putStrLn $ T.pack $ show ks + SIO.hFlush stdout + -- wait for 10 sec + wait 10 + killThread threadId + RunProgram filePath -> do content <- T.readFile filePath program <- compile content - void $ interpret id program + TERM.Size h w <- TERM.withTerminal $ TERM.runTerminalT TERM.getWindowSize + void $ interpret (\is -> is { isTerminalParams = Just (ScreenPos 0 0, Dimensions w h) }) program StartIDE filePath -> do inputChan <- liftIO newTChanIO inputForwardingThread (atomically . writeTChan inputChan) - runIDE filePath inputChan interpreterThreadRef + runIDE filePath inputChan interpreterDebugInChanRef diff --git a/docs/functions/misc.md b/docs/functions/misc.md --- a/docs/functions/misc.md +++ b/docs/functions/misc.md @@ -52,3 +52,28 @@ ``` println(stringtonum("23.4") + 5) -- prints 28.4 ``` + +#### tostring + +Convert a value to a string. + +#### csinit + +Initialize character graphics + +#### csgoto + +Set current output location + +#### csprint + +Prints text at current location + + +#### csclear + +Clears the screen to start drawing next frame. + +#### csdraw + +Output instructions to update screen. diff --git a/docs/functions/string.md b/docs/functions/string.md --- a/docs/functions/string.md +++ b/docs/functions/string.md @@ -32,3 +32,7 @@ ``` let parts = join(",", ["a", "b", "c"]) -- returns "a,b,c" ``` + +#### formatamount + +Insert commas into a string according to the passed argument. diff --git a/samples/char-animation.spd b/samples/char-animation.spd new file mode 100644 --- /dev/null +++ b/samples/char-animation.spd @@ -0,0 +1,20 @@ +csinit() +loop + for i = 1 to 360 + for x = 1 to 40 + for y = 1 to 40 + csgoto(x, y) + csprint(".") + endfor + endfor + for j = 1 to 20 + let x = (30 * cos((i - (2 * j)))) + let y = (30 * sin((i - (2 * j)))) + csgoto((x + 30), (y + 30)) + csprint(j) + endfor + csdraw() + wait(0.01) + csclear() + endfor +endloop diff --git a/samples/mandelbrot.spd b/samples/mandelbrot.spd --- a/samples/mandelbrot.spd +++ b/samples/mandelbrot.spd diff --git a/spade.cabal b/spade.cabal --- a/spade.cabal +++ b/spade.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: spade -version: 0.1.0.5 +version: 0.1.0.6 synopsis: A simple programming and debugging environment. description: A simple weakly typed, dynamic, interpreted programming langauge and terminal IDE. category: language, interpreter, ide @@ -38,6 +38,7 @@ docs/functions/time.md stack.yaml stack.yaml.lock + samples/char-animation.spd samples/mandelbrot.spd samples/paratrooper.spd samples/snake.spd @@ -62,6 +63,7 @@ Compiler.Lexer.Tokens Compiler.Lexer.Whitespaces Compiler.Parser + DiffRender.DiffRender Highlighter.Highlighter IDE.Common IDE.Help @@ -94,6 +96,7 @@ UI.Widgets.LogWidget UI.Widgets.MenuContainer UI.Widgets.NullWidget + UI.Widgets.OutputContainer UI.Widgets.TextContainer UI.Widgets.TitledContainer UI.Widgets.WatchWidget @@ -178,6 +181,7 @@ , time >=1.9.3 && <1.10 , unordered-containers >=0.2.16 && <0.3 , vector >=0.12.3 && <0.13 + , with-utf8 >=1.0.2 && <1.1 default-language: Haskell2010 autogen-modules: Paths_spade @@ -265,6 +269,7 @@ , time >=1.9.3 && <1.10 , unordered-containers >=0.2.16 && <0.3 , vector >=0.12.3 && <0.13 + , with-utf8 >=1.0.2 && <1.1 default-language: Haskell2010 autogen-modules: Paths_spade @@ -370,4 +375,5 @@ , time >=1.9.3 && <1.10 , unordered-containers >=0.2.16 && <0.3 , vector >=0.12.3 && <0.13 + , with-utf8 >=1.0.2 && <1.1 default-language: Haskell2010 diff --git a/src/Common.hs b/src/Common.hs --- a/src/Common.hs +++ b/src/Common.hs @@ -6,14 +6,13 @@ import Control.Concurrent import Control.Exception import Control.Monad -import Data.Time.Clock.POSIX (getPOSIXTime) import Data.List as DL import Data.Text as T import Data.Text.IO as T +import Data.Time.Clock.POSIX (getPOSIXTime) +import Data.Time.Clock.System +import Data.Time.LocalTime import qualified Language.Haskell.TH.Syntax as TH -import System.Console.ANSI (Color(..), ColorIntensity(..), ConsoleLayer(..), - SGR(..), Underlining(..), setSGRCode) -import Test.Common class HReadable a where hReadable :: a -> Text @@ -21,6 +20,21 @@ getTimestamp :: IO Int getTimestamp = (round . (* 10e12)) <$> getPOSIXTime +getSystemTimestamp :: Num i => IO i +getSystemTimestamp = do + st <- truncateSystemTimeLeapSecond <$> getSystemTime + pure $ ((fromIntegral $ systemSeconds st) * 1e9) + (fromIntegral $ systemNanoseconds st) + +getLocalTime :: IO LocalTime +getLocalTime = + zonedTimeToLocalTime <$> getZonedTime + +getLocalTimeString :: IO Text +getLocalTimeString = (formatLocalTime . localTimeOfDay) <$> getLocalTime + +formatLocalTime :: TimeOfDay -> Text +formatLocalTime TimeOfDay {..} = (T.pack $ show todHour) <> ":" <> (T.pack $ show todMin) <> ":" <> (T.pack $ show (round todSec)) + wait :: Double -> IO () wait s = threadDelay (floor $ s * 1000_000) @@ -56,106 +70,6 @@ type IntType = Integer type FloatType = Double -data Style = FgBg Color Color| Fg Color | Bg Color | TextUnderline | NoStyle - deriving (Eq, Show) - -data StyledText = StyledText Style [StyledText] | Plain Text - deriving (Show, Eq) - -renderLines :: [[StyledText]] -> Text -renderLines st = T.intercalate "\n" $ (\i -> (T.concat $ stRender <$> i)) <$> st - -instance HasGen StyledText where - getGen = recursive choice - [Plain . T.pack <$> txGen] - [StyledText NoStyle <$> list (linear 1 100) getGen] - where - txGen = list (linear 1 100) (choice [lower, upper]) - --- Punch a hole starting from offset of size length. Columns start --- from 0. Returns chunks left and right of the hole. -punchHole :: (Int, Int) -> [StyledText] -> ([StyledText], [StyledText]) -punchHole (tk, ln) sts = (stTake tk sts, stDrop (tk + ln) sts) - -stInsert :: [StyledText] -> Int -> StyledText -> [StyledText] -stInsert sts cx t = - let (lr, rg) = punchHole (cx, stLength t) sts - in (lr <> [t] <> rg) - -stDrop :: Int -> [StyledText] -> [StyledText] -stDrop l stsIn = snd $ DL.foldl' stDrop' (l, []) stsIn - where - stDrop' :: (Int, [StyledText]) -> StyledText -> (Int, [StyledText]) - stDrop' (0, sts) st = (0, sts <> [st]) - stDrop' (s, sts) (Plain t) = let - r = T.drop s t - rlen = T.length r - in if rlen > 0 - then (s - (T.length t - rlen), sts <> [Plain r]) - else (s - T.length t, sts) - stDrop' (s, sts) (StyledText st sts') = - case DL.foldl' stDrop' (s, []) sts' of - (s', sts''@(_:_)) -> (s', sts <> [StyledText st sts'']) - (s', _) -> (s', sts) - -stTake :: Int -> [StyledText] -> [StyledText] -stTake l stsIn = snd $ DL.foldl' stTake' (l, []) stsIn - where - stTake' :: (Int, [StyledText]) -> StyledText -> (Int, [StyledText]) - stTake' (0, sts) _ = (0, sts) - stTake' (s, sts) (Plain t) = let - r = T.take s t - in (s - T.length r, sts <> [Plain r]) - stTake' (s, sts) (StyledText st sts') = let - (s', sts'') = DL.foldl' stTake' (s, []) sts' - in (s', sts <> [StyledText st sts'']) - -applyStyleToRange :: (StyledText -> StyledText) -> Int -> (Int, Int) -> [StyledText] -> [StyledText] -applyStyleToRange fn sStart (rStart, rEnd) segments = - let - sEnd = sStart + stTotalLength segments - 1 - in if rEnd >= sStart && rStart <= sEnd - then - let - r1 = max 0 (rStart - sStart) - r2 = rEnd - (max sStart rStart) + 1 - in (stTake r1 segments) <> (fn <$> (stTake r2 (stDrop r1 segments))) <> (stDrop (r1 + r2) segments) - else segments - -stLength :: StyledText -> Int -stLength (Plain t) = T.length t -stLength (StyledText _ sts) = sum (stLength <$> sts) - -stTotalLength :: [StyledText] -> Int -stTotalLength sts = sum $ stLength <$> sts - --- This implimentation is not optimal and does not correctly --- render nested styles. But this appear to be good enough for now. -styleToPrefix :: Style -> Text -styleToPrefix st = T.pack $ case st of - FgBg fg bg -> setSGRCode [SetColor Foreground Vivid fg] <> setSGRCode [SetColor Background Vivid bg] - Bg bg -> setSGRCode [SetColor Background Vivid bg] - Fg fg -> setSGRCode [SetColor Foreground Vivid fg] - TextUnderline -> setSGRCode [SetUnderlining SingleUnderline] - NoStyle -> mempty - -stRender :: StyledText -> Text -stRender st = stRender' NoStyle st - -mergeStyles :: Style -> Style -> Style -mergeStyles NoStyle a = a -mergeStyles a NoStyle = a -mergeStyles (Fg a) (Bg b) = (FgBg a b) -mergeStyles (Bg a) (Fg b) = (FgBg b a) -mergeStyles _ a = a - -stRender' :: Style -> StyledText -> Text -stRender' _ (Plain t) = T.replace "\n" " " t -stRender' pst (StyledText st sts) = let - suffix = T.pack $ setSGRCode [] - prefix = styleToPrefix (mergeStyles pst st) - in T.concat (((\x -> prefix <> x <> suffix) . stRender' st) <$> sts) - data ScreenPos = ScreenPos { sX :: Int, sY :: Int } deriving (Eq, Ord, Show) @@ -200,26 +114,6 @@ instance HasLog IO where appendLog a = void $ try @SomeException (T.appendFile "/tmp/spade.log" $ pack (show a <> "\n")) - --- Mostly for use with highlighting and not actual token parsing. --- This represent any tokens we want to show in editors with highlighting. -class Highlightable a where - getTokenLoc :: a -> Location - highlight :: (StyledText, Maybe a) -> StyledText - pairWithTokens :: [a] -> Int -> Text -> ([(Text, Maybe a)], [a]) - -- ^ Associate token type with their text sources - -- First arg is stack of tokens at current location - -- Second arg is the text offset at current location - -- Third arg is the text at the current location - -- - -- This is so that in an editor, a line of text can break at somewhere in the - -- middle of a single token. So an editor cannot display tokenwise without more - -- complex tracking of current offset in source text. - -instance Highlightable Text where - highlight (x, _) = x - pairWithTokens _ _ t = ([(t, Nothing)], []) - getTokenLoc = error "No token location for text" genericPairWithTokens :: (a -> Int) -> (a -> Location) -> Int -> Text -> [a] -> ([(Text, Maybe a)], [a]) genericPairWithTokens _ _ _ "" [] = ([], []) diff --git a/src/Compiler/AST/Common.hs b/src/Compiler/AST/Common.hs --- a/src/Compiler/AST/Common.hs +++ b/src/Compiler/AST/Common.hs @@ -85,14 +85,14 @@ mandatory :: AstParser a -> AstParser a mandatory (ParserM name fn) = ParserM ("mandatory " <> name) $ \s -> do case (astInput s) of - [] -> pure (Left $ FatalError $ CustomError $ "Expecting " <> name <> " but ran out of input ", s) + [] -> pure (Left $ FatalError $ CustomError $ "Expecting '" <> name <> "' but ran out of input ", s) _ -> fn s >>= \case r@(Right _, _) -> pure r (Left fe@(FatalError _), _) -> pure (Left fe, s) (Left fe@(FatalErrorWithLocation _ _), _) -> pure (Left fe, s) (Left e, s'') -> case astInput s'' of [] -> pure (Left e, s) - (h: _) -> pure (Left $ FatalErrorWithLocation (tkLocation h) $ CustomError $ "Expecting " <> name <> " but got " <> (pack $ show h), s) + (h: _) -> pure (Left $ FatalErrorWithLocation (tkLocation h) $ CustomError $ "Expecting '" <> name <> "' but got '" <> (toSource h) <> "'", s) nonEmptyGen :: Gen a -> Gen (NonEmpty a) nonEmptyGen p = do h <- p; t <- list (linear 0 3) p; pure (h :| t) diff --git a/src/Compiler/AST/FunctionStatement.hs b/src/Compiler/AST/FunctionStatement.hs --- a/src/Compiler/AST/FunctionStatement.hs +++ b/src/Compiler/AST/FunctionStatement.hs @@ -27,7 +27,7 @@ toSourcePretty i (FunctionStatementWithLoc fs _) = toSourcePretty i fs instance HasAstParser FunctionStatementWithLoc where - astParser = nameParser "FunctionStatement" $ do + astParser = nameParser "Statement" $ do loc <- getParserLocation fsr <- astParser pure $ FunctionStatementWithLoc fsr loc diff --git a/src/Compiler/Lexer/Tokens.hs b/src/Compiler/Lexer/Tokens.hs --- a/src/Compiler/Lexer/Tokens.hs +++ b/src/Compiler/Lexer/Tokens.hs @@ -15,6 +15,8 @@ import Compiler.Lexer.Whitespaces import Parser import Test.Common +import DiffRender.DiffRender +import Highlighter.Highlighter data Token = Token { tkRaw :: TokenRaw diff --git a/src/DiffRender/DiffRender.hs b/src/DiffRender/DiffRender.hs new file mode 100644 --- /dev/null +++ b/src/DiffRender/DiffRender.hs @@ -0,0 +1,194 @@ +module DiffRender.DiffRender where + +import Common +import Control.Monad.IO.Class +import Data.List as DL +import Data.Text as T +import Data.Text.IO as T +import Data.Vector.Mutable (IOVector) +import qualified Data.Vector.Mutable as MV +import System.Console.ANSI (Color(..), ColorIntensity(..), ConsoleLayer(..), + SGR(..), Underlining(..), setSGRCode) +import qualified System.Console.ANSI as A +import qualified System.IO as S +import Test.Common + +data DiffRender = DiffRender + { dfScreenStateBack :: ScreenState + , dfScreenState :: ScreenState + } + +emptyDiffRender :: Dimensions -> IO DiffRender +emptyDiffRender Dimensions { diH = rows, diW = cols } = do + ss <- emptyScreenState rows cols + ssBack <- emptyScreenState rows cols + pure $ DiffRender { dfScreenStateBack = ssBack, dfScreenState = ss } + +emptyScreenState :: Int -> Int -> IO ScreenState +emptyScreenState rows cols = do + stLines <- MV.generate rows (\_ -> [Plain (T.replicate cols " ")]) + pure (ScreenState stLines (ScreenPos 0 0) cols True) + +dfSetCursorPosition :: Int -> Int -> DiffRender -> DiffRender +dfSetCursorPosition x y dfr = + let + screenState = dfScreenStateBack dfr + screenLines = ssLines screenState + screenColumns = ssColumns screenState + in if (x >= 0 && x < screenColumns) && (y >= 0 && y < (MV.length screenLines)) + then dfr { dfScreenStateBack = screenState { ssCursorOverflow = False, ssCursorPos = ScreenPos x y }} + else dfr { dfScreenStateBack = screenState { ssCursorOverflow = True }} + +dfPutText :: MonadIO m => StyledText -> DiffRender -> m () +dfPutText t (DiffRender { dfScreenStateBack = ScreenState {ssLines = ssLns, ssCursorOverflow = cursorOverflow, ssCursorPos = ScreenPos cx cy} }) = do + -- Write stuff to the backbuffer. If the cursor is in an overflow position, then do nothing. + if cursorOverflow + then pure () + else liftIO $ flip (MV.modify ssLns) cy $ \l -> stInsert l cx t + +dfDraw :: MonadIO m => Maybe (ScreenPos, Dimensions) -> DiffRender -> m DiffRender +dfDraw mScreenParams dfr@(DiffRender { dfScreenStateBack = (ssLines -> ssb), dfScreenState = (ssLines -> ss) }) = do + let + (screenOffsetX, screenOffsetY) = case mScreenParams of + Just (sp, _) -> (sX sp, sY sp) + Nothing -> (0, 0) + + liftIO $ MV.imapM_ (\idx neLine -> do + oldLine <- MV.read ss idx + if (oldLine /= neLine) + then do + A.setCursorPosition (idx + screenOffsetY) screenOffsetX + -- mapM_ (\x -> do T.putStr x; S.hFlush stdout; threadDelay 10000;) (stRender <$> neLine) + mapM_ T.putStr (stRender <$> neLine) + S.hFlush S.stdout + else pure () + ) ssb + pure $ dfr { dfScreenState = dfScreenStateBack dfr, dfScreenStateBack = dfScreenState dfr } + +dfClear :: MonadIO m => DiffRender -> m () +dfClear dfIn = do + let bb = dfScreenStateBack dfIn + liftIO $ MV.set (ssLines bb) [Plain (T.replicate (ssColumns bb) " ")] + +dfInitialize :: MonadIO m => Dimensions -> DiffRender -> m DiffRender +dfInitialize (Dimensions cols rows) dfIn = do + -- Initialize the screen memory for the dimensions + -- and initialize to whitespaces. + (ss, ssBack) <- liftIO $ do + ss <- emptyScreenState rows cols + ssBack <- emptyScreenState rows cols + pure (ss, ssBack) + pure $ dfIn { dfScreenStateBack = ssBack, dfScreenState = ss} + +data ScreenState = ScreenState + { ssLines :: IOVector [StyledText] + , ssCursorPos :: ScreenPos + , ssColumns :: Int + , ssCursorOverflow :: Bool + } + +screenStateDimension :: ScreenState -> Dimensions +screenStateDimension ScreenState {..} = Dimensions ssColumns (MV.length ssLines) + +diffRenderToDimension :: DiffRender -> Dimensions +diffRenderToDimension DiffRender {..} = screenStateDimension dfScreenState + +data Style = FgBg Color Color| Fg Color | Bg Color | TextUnderline | NoStyle + deriving (Eq, Show) + +data StyledText = StyledText Style [StyledText] | Plain Text + deriving (Show, Eq) + +renderLines :: [[StyledText]] -> Text +renderLines st = T.intercalate "\n" $ (\i -> (T.concat $ stRender <$> i)) <$> st + +instance HasGen StyledText where + getGen = recursive choice + [Plain . T.pack <$> txGen] + [StyledText NoStyle <$> list (linear 1 100) getGen] + where + txGen = list (linear 1 100) (choice [lower, upper]) + +-- Punch a hole starting from offset of size length. Columns start +-- from 0. Returns chunks left and right of the hole. +punchHole :: (Int, Int) -> [StyledText] -> ([StyledText], [StyledText]) +punchHole (tk, ln) sts = (stTake tk sts, stDrop (tk + ln) sts) + +stInsert :: [StyledText] -> Int -> StyledText -> [StyledText] +stInsert sts cx t = + let (lr, rg) = punchHole (cx, stLength t) sts + in (lr <> [t] <> rg) + +stDrop :: Int -> [StyledText] -> [StyledText] +stDrop l stsIn = snd $ DL.foldl' stDrop' (l, []) stsIn + where + stDrop' :: (Int, [StyledText]) -> StyledText -> (Int, [StyledText]) + stDrop' (0, sts) st = (0, sts <> [st]) + stDrop' (s, sts) (Plain t) = let + r = T.drop s t + rlen = T.length r + in if rlen > 0 + then (s - (T.length t - rlen), sts <> [Plain r]) + else (s - T.length t, sts) + stDrop' (s, sts) (StyledText st sts') = + case DL.foldl' stDrop' (s, []) sts' of + (s', sts''@(_:_)) -> (s', sts <> [StyledText st sts'']) + (s', _) -> (s', sts) + +stTake :: Int -> [StyledText] -> [StyledText] +stTake l stsIn = snd $ DL.foldl' stTake' (l, []) stsIn + where + stTake' :: (Int, [StyledText]) -> StyledText -> (Int, [StyledText]) + stTake' (0, sts) _ = (0, sts) + stTake' (s, sts) (Plain t) = let + r = T.take s t + in (s - T.length r, sts <> [Plain r]) + stTake' (s, sts) (StyledText st sts') = let + (s', sts'') = DL.foldl' stTake' (s, []) sts' + in (s', sts <> [StyledText st sts'']) + +applyStyleToRange :: (StyledText -> StyledText) -> Int -> (Int, Int) -> [StyledText] -> [StyledText] +applyStyleToRange fn sStart (rStart, rEnd) segments = + let + sEnd = sStart + stTotalLength segments - 1 + in if rEnd >= sStart && rStart <= sEnd + then + let + r1 = max 0 (rStart - sStart) + r2 = rEnd - (max sStart rStart) + 1 + in (stTake r1 segments) <> (fn <$> (stTake r2 (stDrop r1 segments))) <> (stDrop (r1 + r2) segments) + else segments + +stLength :: StyledText -> Int +stLength (Plain t) = T.length t +stLength (StyledText _ sts) = sum (stLength <$> sts) + +stTotalLength :: [StyledText] -> Int +stTotalLength sts = sum $ stLength <$> sts + +-- This implimentation is not optimal and does not correctly +-- render nested styles. But this appear to be good enough for now. +styleToPrefix :: Style -> Text +styleToPrefix st = T.pack $ case st of + FgBg fg bg -> setSGRCode [SetColor Foreground Vivid fg] <> setSGRCode [SetColor Background Vivid bg] + Bg bg -> setSGRCode [SetColor Background Vivid bg] + Fg fg -> setSGRCode [SetColor Foreground Vivid fg] + TextUnderline -> setSGRCode [SetUnderlining SingleUnderline] + NoStyle -> mempty + +stRender :: StyledText -> Text +stRender st = stRender' NoStyle st + +mergeStyles :: Style -> Style -> Style +mergeStyles NoStyle a = a +mergeStyles a NoStyle = a +mergeStyles (Fg a) (Bg b) = (FgBg a b) +mergeStyles (Bg a) (Fg b) = (FgBg b a) +mergeStyles _ a = a + +stRender' :: Style -> StyledText -> Text +stRender' _ (Plain t) = T.replace "\n" " " t +stRender' pst (StyledText st sts) = let + suffix = T.pack $ setSGRCode [] + prefix = styleToPrefix (mergeStyles pst st) + in T.concat (((\x -> prefix <> x <> suffix) . stRender' st) <$> sts) diff --git a/src/Highlighter/Highlighter.hs b/src/Highlighter/Highlighter.hs --- a/src/Highlighter/Highlighter.hs +++ b/src/Highlighter/Highlighter.hs @@ -3,6 +3,27 @@ import Data.Text import Common import System.Console.ANSI (Color(..), Underlining(..), SGR(..), setSGRCode) +import DiffRender.DiffRender + +-- Mostly for use with highlighting and not actual token parsing. +-- This represent any tokens we want to show in editors with highlighting. +class Highlightable a where + getTokenLoc :: a -> Location + highlight :: (StyledText, Maybe a) -> StyledText + pairWithTokens :: [a] -> Int -> Text -> ([(Text, Maybe a)], [a]) + -- ^ Associate token type with their text sources + -- First arg is stack of tokens at current location + -- Second arg is the text offset at current location + -- Third arg is the text at the current location + -- + -- This is so that in an editor, a line of text can break at somewhere in the + -- middle of a single token. So an editor cannot display tokenwise without more + -- complex tracking of current offset in source text. + +instance Highlightable Text where + highlight (x, _) = x + pairWithTokens _ _ t = ([(t, Nothing)], []) + getTokenLoc = error "No token location for text" underlineText :: Text -> Text underlineText t = let diff --git a/src/IDE/Common.hs b/src/IDE/Common.hs --- a/src/IDE/Common.hs +++ b/src/IDE/Common.hs @@ -16,15 +16,19 @@ | IDEReqEditorContent | IDEParseErrorUpdate (Maybe (Location, Text)) | IDEACUpdateIdentifiers [Text] + | IDEClearDraw | IDEDraw | IDEToggleHelp + | IDEToggleOutput | IDESave | IDEExit | IDEEdit EditAction | IDEBeautify | IDEClearLog + | IDEClearOutput | IDEAppendLog Text | IDEStep + | IDEStop | IDEShowAbout | IDEHideAbout | IDEDebugUpdate (Maybe DebugState) diff --git a/src/IDE/Help.hs b/src/IDE/Help.hs --- a/src/IDE/Help.hs +++ b/src/IDE/Help.hs @@ -200,7 +200,7 @@ HelpWidget { hwIdeEventsChan = ideEventRef, hwContentWidget = ewRef, hwTokensRef = tokensRef} <- readWRef helpWidgetRef liftIO $ writeIORef tokensRef dtTokens modifyWRef ewRef (\ew -> (resetCursor ew) { ewContent = contentText, ewShowVirtualCursor = True }) - liftIO $ atomically $ writeTChan ideEventRef IDEDraw + liftIO $ atomically $ writeTChan ideEventRef IDEClearDraw collectLinks :: Map.Map FilePath (Text, V.Vector DisplayToken) @@ -246,7 +246,7 @@ tokenProcessing ideEventRef cursorRef tokensRef = forever $ do cursor <- takeMVar cursorRef modifyIORef tokensRef (V.map (mapFn cursor)) - liftIO $ atomically $ writeTChan ideEventRef IDEDraw + liftIO $ atomically $ writeTChan ideEventRef IDEClearDraw where mapFn :: Int -> DisplayToken -> DisplayToken mapFn cursor dt = if cursor >= (lcOffset $ dtLocation dt) && cursor <= (dtOffsetEnd dt) @@ -296,8 +296,8 @@ cursorRef <- liftIO $ newMVar @Int 0 searchResultRef <- liftIO newEmptyMVar searchChan <- liftIO (newTChanIO @SearchPage) - helpLayoutRef <- layoutWidget Vertical helpWidgetDimDistrbution Nothing - helptopLayoutRef <- layoutWidget Horizontal helpWidgetTopDimDistrbution Nothing + helpLayoutRef <- layoutWidget Vertical helpWidgetDimDistrbution + helptopLayoutRef <- layoutWidget Horizontal helpWidgetTopDimDistrbution helpSearchInput <- editor (\_ -> pure []) Nothing tokensRef <- liftIO $ newIORef @(V.Vector DisplayToken) V.empty @@ -305,7 +305,7 @@ tokenProcessingThreadId <- liftIO $ forkIO (tokenProcessing ideEventRef cursorRef tokensRef) helpContent <- editor (\_ -> pure []) (Just $ SomeTokenStream (V.toList <$> readIORef tokensRef)) - modifyWRef helpSearchInput (\hw -> hw { ewParams = (ewParams hw) { epLineNos = False} }) + modifyWRef helpSearchInput (\hw -> hw { ewParams = (ewParams hw) { epBorder = True, epGutterSize = 0, epLineNos = False} }) modifyWRef helpContent (\hw -> hw { ewShowVirtualCursor = True, ewParams = (ewParams hw) { epLineNos = False} }) addWidget helptopLayoutRef "helpsearchinput" helpSearchInput (newWRef nullWidget) >>= addWidget helptopLayoutRef "helpsearchspacer" diff --git a/src/IDE/Help/Parser.hs b/src/IDE/Help/Parser.hs --- a/src/IDE/Help/Parser.hs +++ b/src/IDE/Help/Parser.hs @@ -10,6 +10,8 @@ import qualified Compiler.Lexer.Tokens as CT import Parser.Lib import Parser.Parser +import DiffRender.DiffRender +import Highlighter.Highlighter data DisplayTokenRaw = DTPlain Text diff --git a/src/IDE/IDE.hs b/src/IDE/IDE.hs --- a/src/IDE/IDE.hs +++ b/src/IDE/IDE.hs @@ -6,6 +6,7 @@ import Compiler.Parser import Control.Concurrent import Control.Concurrent.STM +import Control.Concurrent.STM.TSem import Control.Exception import Control.Monad import Data.IORef @@ -33,12 +34,17 @@ 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 @@ -100,13 +106,6 @@ fn :: (Text, Text) -> Bool fn (i, _) = T.isPrefixOf key i -getTerminalSize' :: IO Dimensions -getTerminalSize' = do - s <- getTerminalSizeIO - case s of - Just (xs, ys) -> pure $ Dimensions xs ys - _ -> error "Cannot read terminal size" - -- 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. @@ -141,8 +140,8 @@ show RouteIDE = "Route To IDE" show (RouteProgram _) = "Route To Program" -runIDE :: FilePath -> TChan TerminalEvent -> TMVar ThreadId -> IO () -runIDE filePath inputChan interpreterThreadRef = do +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 "" @@ -175,10 +174,22 @@ 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 (ScreenPos 0 0) (Dimensions 0 0) (SomeWidgetRef watchWidgetRef) " Watch " + 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] @@ -187,7 +198,7 @@ a -> error $ "Unsupported widget count:" <> show a logRef <- logWidget - titledLogRef <- titledContainer (ScreenPos 0 0) (Dimensions 0 0) (SomeWidgetRef logRef) " Log " + titledLogRef <- titledContainer (SomeWidgetRef logRef) " Log " helpWidgetRef <- helpWidget ((Prelude.head . T.split (== '.'). fst) <$> builtIns) ideEventsRef -- The autocomplete widget @@ -196,49 +207,58 @@ -- 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\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 14) (SomeWidgetRef aboutText) + aboutBox <- borderBox (ScreenPos 10 16) (Dimensions 60 16) (SomeWidgetRef aboutText) setVisibility aboutBox False -- The Outermost layout - layoutRef <- layoutWidget Vertical dimensionDistributionFn (Just $ SomeKeyInputWidget editorRef) - modifyWRef layoutRef (\lw -> lw { lowFloatingContent = [SomeWidgetRef ac, SomeWidgetRef aboutBox] }) + 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 - setTextFocus layoutRef editorId -- The menu let menu = Menu [ ("File", SubMenu ["Save (F6)", "Beautify", "Exit"]) , ("Edit", SubMenu ["Cut", "Copy", "Paste", "Select All"]) - , ("Run", SubMenu ["Run (F5)", "Step (F8)"]) - , ("Windows", SubMenu ["Clear log"]) + , ("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) + menuContainerRef <- menuContainer (SomeWidgetRef layoutRef') menu (selectionHandler ideEventsRef) - modify (\ws -> ws { wsCursorWidget = Just $ SomeKeyInputWidget editorRef }) + modify $ liftWSMod (\ws -> ws { wsCursorWidget = Just $ SomeKeyInputWidget editorRef }) - -- A snippet that refresh the screen. + -- A snippet that refresh the screen. let ideRedraw :: WidgetC m => m () ideRedraw = do - csClear - draw menuContainerRef - csDraw + csClear + draw menuContainerRef + csDraw let getActiveEditor :: WidgetC m => m (WRef EditorWidget) @@ -251,9 +271,19 @@ let launchProgram :: forall m. WidgetC m - => m (Either Text IDEDebugEnv) + => 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 @@ -263,10 +293,13 @@ 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 - osThreadId <- forkOS $ do + let ideDebugEnv = IDEDebugEnv debugIn debugOut programInputHandleR programInputHandleW Nothing + void $ forkOS $ do + thisThreadId <- myThreadId + startMode <- atomically $ do -- Initialize IDE debuggins state dIn <- readTBQueue debugIn @@ -274,7 +307,7 @@ modifyTVar ideStateRef (\idestate -> idestate - { idsDebugEnv = Just ideDebugEnv + { idsDebugEnv = Just $ ideDebugEnv { ideDebugThreadId = Just thisThreadId } }) pure dIn let @@ -282,10 +315,16 @@ StartStep -> (\is -> is { isInputHandle = programInputHandleR , isRunMode = DebugMode $ DebugEnv SingleStep debugIn debugOut + , isOutputHandle = pOutHandle + , isTerminalParams = Just (outputScreenOffset, outputScreenSize) + , isStdoutLock = mOutBufLock }) Start -> (\is -> is - { isRunMode = NormalMode (Just $ DebugEnv SingleStep debugIn debugOut) + { isRunMode = DebugMode (DebugEnv Continue debugIn debugOut) , isInputHandle = programInputHandleR + , isOutputHandle = pOutHandle + , isTerminalParams = Just (outputScreenOffset, outputScreenSize) + , isStdoutLock = mOutBufLock }) _ -> error "Impossible!" @@ -296,18 +335,17 @@ -- Reset IDE debuggins state void $ atomically $ do readTBQueue debugIn >>= (check . (== Stop)) -- Wait till the stop command - void $ takeTMVar interpreterThreadRef + void $ takeTMVar interpreterDebugInChanRef modifyTVar ideStateRef (\idestate -> idestate { idsDebugEnv = Nothing }) - - atomically $ putTMVar interpreterThreadRef osThreadId - pure $ Right ideDebugEnv + atomically $ putTMVar interpreterDebugInChanRef debugIn + pure (Right ideDebugEnv, mOutBufLock) Left err -> do - pure $ Left (hReadable err) + pure (Left (hReadable err), mOutBufLock) uiLoop ideEventsRef (\case IDEShowAbout -> do @@ -317,6 +355,12 @@ 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 @@ -327,19 +371,31 @@ setVisibility helpWidgetRef False setVisibility editorRef True setVisibility watchWidgetRef True - modify (\ws -> ws { wsCursorWidget = Just $ SomeKeyInputWidget editorRef }) + 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 (\ws -> ws { wsCursorWidget = Just $ SomeKeyInputWidget helpWidgetRef }) + 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 @@ -347,7 +403,7 @@ pure True IDEEdit Copy -> do ew <- getActiveEditor >>= readWRef - case ewSelection ew of + case selectionToTuple <$> (ewSelection ew) of Just (r1, r2) -> let contents = ewContent ew removeLength = (r2 - r1 + 1) @@ -356,7 +412,7 @@ Nothing -> pass pure True IDEEdit Cut -> do - modifyWRefM editorRef (\ew -> case ewSelection ew of + modifyWRefM editorRef (\ew -> case (selectionToTuple <$> ewSelection ew) of Just (r1, r2) -> let contents = ewContent ew (p1, p2) = T.splitAt r1 contents @@ -383,12 +439,15 @@ ideRedraw pure True IDEEdit SelectAll -> do - modifyWRef editorRef (\ew -> ew { ewSelection = Just (0, (T.length $ ewContent ew) - 1) }) + 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 @@ -398,10 +457,12 @@ (liftIO $ compileEither @Program code) >>= \case Right a -> do setContent editorRef (T.strip $ toSource a) - liftIO $ atomically $ writeTChan ideEventsRef IDEDraw + 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 @@ -435,27 +496,51 @@ waitTill (\_ -> True) (ideDebugOut ideDebugEnv) >>= processDebugOut ideEventsRef ideStateRef logRef editorRef (ideDebugIn ideDebugEnv) liftIO $ atomically $ do - writeTChan ideEventsRef IDEDraw + writeTChan ideEventsRef IDEClearDraw writeTVar inputRouteToRef RouteIDE _ -> do -- Or else launch a new run of the program. - clearscreen setCursorPosition 0 0 launchProgram >>= \case - Right ideDebugEnv -> do + (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 IDEDraw + writeTChan ideEventsRef IDEClearDraw writeTVar inputRouteToRef RouteIDE - Left err -> do - insertLog logRef $ "Compile Error:" <> err - liftIO $ atomically $ writeTChan ideEventsRef IDEDraw + (Left err, _) -> do + insertLog logRef $ "Compile Error: " <> err + liftIO $ atomically $ writeTChan ideEventsRef IDEClearDraw pure True IDEStep -> do csSetCursorPosition 0 0 @@ -480,7 +565,7 @@ _ -> do -- No debugging session exist. Launch one. launchProgram >>= \case - Right ideDebugEnv -> do + (Right ideDebugEnv, _) -> do liftIO $ atomically $ do writeTBQueue (ideDebugIn ideDebugEnv) StartStep writeTBQueue (ideDebugIn ideDebugEnv) StepIn @@ -493,7 +578,7 @@ liftIO $ atomically $ do writeTVar inputRouteToRef RouteIDE - Left err -> insertLog logRef $ "Compile Error:" <> err + (Left err, _) -> insertLog logRef $ "Compile Error: " <> err pure True IDEDebugUpdate mds -> do case mds of @@ -511,7 +596,7 @@ modifyWRef titledWatchRef (\twr -> setTitle twr "Watch") modifyWRef editorRef (\ew -> ew { ewReadOnly = False, ewDebugLocation = Nothing }) setVisibility titledWatchRef False - liftIO $ atomically $ writeTChan ideEventsRef IDEDraw + liftIO $ atomically $ writeTChan ideEventsRef IDEClearDraw pure True IDETerminalEvent TerminalInterrupt -> pure False IDETerminalEvent (TerminalResize w h) -> do @@ -531,9 +616,13 @@ True -> pure () False -> shortcutsHandler ideEventsRef k >>= \case True -> pure () - False -> idsKeyInputReciever <$> (liftIO $ readTVarIO ideStateRef) >>= \case - Just (SomeKeyInputWidget w) -> handleInput w k - Nothing -> 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 }) @@ -690,12 +779,15 @@ (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 IDEDraw + liftIO $ atomically $ writeTChan ideEventsRef IDEClearDraw shortcutsHandler :: forall m. WidgetC m @@ -710,6 +802,10 @@ 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 diff --git a/src/Interpreter/Common.hs b/src/Interpreter/Common.hs --- a/src/Interpreter/Common.hs +++ b/src/Interpreter/Common.hs @@ -4,6 +4,7 @@ import Control.Concurrent.STM.TBQueue import Control.Concurrent.STM.TChan import Control.Concurrent.STM.TMVar +import Control.Concurrent.STM.TSem import Control.Exception import Control.Monad.Catch (MonadCatch, MonadThrow, throwM) import qualified Data.ByteString as BS @@ -25,10 +26,12 @@ import qualified SDL as SDL import qualified SDL.Mixer as SDLM import qualified System.IO as SIO +import Text.Hex (encodeHex) import Common import Compiler.AST.Program import Compiler.Lexer +import DiffRender.DiffRender import UI.Widgets.Common audioSampleCount :: Int @@ -135,6 +138,26 @@ | Void deriving Show +toStringVal :: Value -> Text +toStringVal = \case + StringValue t -> t + NumberValue (NumberInt i) -> pack $ show i + NumberValue (NumberFractional i) -> pack $ show i + BoolValue True -> "true" + BoolValue False -> "false" + BytesValue b -> "0x" <> encodeHex b + ArrayValue _ -> "[array]" + ObjectValue _ -> "[object]" + ProcedureValue _ -> "(procedure)" + ThreadRef _ -> "(thread_ref)" + Channel _ -> "(concurrency_channel)" + Ref _ -> "(mutable_ref)" + UnnamedFnValue _ -> "(unnamed_function)" + Void -> "(void)" + BuiltIn _ -> "(builtin)" + s@(ErrorValue _) -> pack $ show s + SDLValue s -> pack $ show s + instance Ord Value where compare (NumberValue x) (NumberValue y) = compare x y compare _ _ = error "Cannot be compared" @@ -172,7 +195,7 @@ type Scope = Map ScopeKey Value data RunMode - = NormalMode (Maybe DebugEnv) + = NormalMode | DebugMode DebugEnv deriving Show @@ -222,6 +245,14 @@ , isInputHandle :: SIO.Handle , isOutputHandle :: SIO.Handle , isThreadName :: Text + , isDiffRender :: Maybe DiffRender + , isWidgetState :: Maybe WidgetState + , isTerminalParams :: Maybe (ScreenPos, Dimensions) + , isStdoutLock :: Maybe TSem + , isDefaultPrintParams :: Maybe (Text, Int, [Int]) + -- ^ This lock is required to sync stdout writing when the program + -- is run from within the IDE and both IDE code and the interepreted + -- program wants to write to stdout concurrently. } instance Show InterpreterState where @@ -230,7 +261,7 @@ dummyIS :: InterpreterState dummyIS = InterpreterState { isLocal = mempty - , isRunMode = NormalMode Nothing + , isRunMode = NormalMode , isGlobalScope = mempty , isDefaultRenderer = Nothing , isAccelerated = Nothing @@ -239,12 +270,17 @@ , isInputHandle = SIO.stdin , isOutputHandle = SIO.stdout , isThreadName = "MAIN" + , isDiffRender = Nothing + , isTerminalParams = Nothing + , isStdoutLock = Nothing + , isWidgetState = Nothing + , isDefaultPrintParams = Nothing } emptyIs :: IORef [SDL.Window] -> InterpreterState emptyIs sdlWindowsRef = InterpreterState { isLocal = mempty - , isRunMode = NormalMode Nothing + , isRunMode = NormalMode , isGlobalScope = mempty , isDefaultRenderer = Nothing , isAccelerated = Nothing @@ -253,6 +289,11 @@ , isInputHandle = SIO.stdin , isOutputHandle = SIO.stdout , isThreadName = "MAIN" + , isDiffRender = Nothing + , isTerminalParams = Nothing + , isStdoutLock = Nothing + , isWidgetState = Nothing + , isDefaultPrintParams = Just (".", 2, [3, 2, 2, 2, 2, 2, 2]) } interpreterOutput :: Text -> InterpretM () @@ -649,3 +690,21 @@ fn is@(InterpreterState { isGlobalScope, isLocal }) = case isLocal of [] -> is { isGlobalScope = M.insert sk val isGlobalScope } (s : rst) -> is { isLocal = (M.insert sk val s) : rst } + +-- | Separates the given text using the decimal separator +-- and inserts commas as specivied by the positions list +-- into the non-fractional part. +amountFormat :: Text -> [Int] -> Text -> Text +amountFormat sep pos v = let + (n, f) = T.breakOn sep v + in (putCommas pos n) <> f + where + putCommas :: [Int] -> Text -> Text + putCommas pos' v' = T.reverse $ T.intercalate "," (splitPos pos' (T.reverse v')) + + splitPos :: [Int] -> Text -> [Text] + splitPos [] "" = [] + splitPos [] v' = [v'] + splitPos _ "" = [] + splitPos (p: rs) v' = (T.take p v') : (splitPos rs (T.drop p v')) + diff --git a/src/Interpreter/Initialize.hs b/src/Interpreter/Initialize.hs --- a/src/Interpreter/Initialize.hs +++ b/src/Interpreter/Initialize.hs @@ -44,6 +44,7 @@ insertBuiltInWithDoc (SkIdentifier $ Identifier "concat") (SomeBuiltin builtInConcat) insertBuiltInWithDoc (SkIdentifier $ Identifier "join") (SomeBuiltin builtInJoin) insertBuiltInWithDoc (SkIdentifier $ Identifier "split") (SomeBuiltin builtInSplit) + insertBuiltInWithDoc (SkIdentifier $ Identifier "formatamount") (SomeBuiltin builtInAmountFormat) -- Keyboard insertBuiltInWithDoc (SkIdentifier $ Identifier "getkey") (SomeBuiltin waitForKey) @@ -82,6 +83,12 @@ insertBuiltInWithDoc (SkIdentifier $ Identifier "print") (SomeBuiltin printVal) insertBuiltInWithDoc (SkIdentifier $ Identifier "inputline") (SomeBuiltin builtinInputLine) insertBuiltInWithDoc (SkIdentifier $ Identifier "stringtonum") (SomeBuiltin numberFromString) + insertBuiltInWithDoc (SkIdentifier $ Identifier "tostring") (SomeBuiltin builtInToString) + insertBuiltInWithDoc (SkIdentifier $ Identifier "csinit") (SomeBuiltin initCharScreen) + insertBuiltInWithDoc (SkIdentifier $ Identifier "csgoto") (SomeBuiltin charScreenGoto) + insertBuiltInWithDoc (SkIdentifier $ Identifier "csprint") (SomeBuiltin charScreenPrint) + insertBuiltInWithDoc (SkIdentifier $ Identifier "csclear") (SomeBuiltin charScreenClear) + insertBuiltInWithDoc (SkIdentifier $ Identifier "csdraw") (SomeBuiltin charScreenDraw) -- SDL Sound insertBuiltInWithDoc (SkIdentifier $ Identifier "maketone") (SomeBuiltin builtInMakeTone) diff --git a/src/Interpreter/Interpreter.hs b/src/Interpreter/Interpreter.hs --- a/src/Interpreter/Interpreter.hs +++ b/src/Interpreter/Interpreter.hs @@ -260,17 +260,24 @@ executeDebugStepable :: Show a => DebugStepable a b => a -> InterpretM b executeDebugStepable dbs = do isRunMode <$> get >>= \case - NormalMode _ -> do + NormalMode -> do execute dbs DebugMode debugEnv@(DebugEnv { deInQueue = isDebugIn, deOutQueue = isDebugOut, deStepMode = stepMode }) -> do - case stepMode of + stepMode' <- case stepMode of + Continue -> + (liftIO $ atomically $ tryReadTBQueue isDebugIn) >>= \case + Just StartStep -> pure SingleStep + -- Only StartStep will trigger a break to step debugging here. + _ -> pure Continue + SingleStep -> pure SingleStep + case stepMode' of Continue -> execute dbs SingleStep -> do -- Send location of current instruction, and wait for command. sendDebugOut isDebugOut (liftIO $ atomically $ readTBQueue isDebugIn) >>= \case Run -> do - modify (\is -> is { isRunMode = NormalMode (Just debugEnv) }) + modify (\is -> is { isRunMode = DebugMode $ debugEnv { deStepMode = Continue } }) execute dbs StepIn -> do modify (\is -> is { isRunMode = DebugMode (DebugEnv SingleStep isDebugIn isDebugOut) }) diff --git a/src/Interpreter/Lib/Misc.hs b/src/Interpreter/Lib/Misc.hs --- a/src/Interpreter/Lib/Misc.hs +++ b/src/Interpreter/Lib/Misc.hs @@ -1,8 +1,9 @@ module Interpreter.Lib.Misc where +import Control.Concurrent.STM.TSem +import Control.Concurrent.STM (atomically) import Control.Monad.IO.Class import Control.Monad.State.Strict as SM -import Text.Read (readMaybe) import qualified Data.Aeson as A import qualified Data.Aeson.Key as A import qualified Data.Aeson.KeyMap as A @@ -14,29 +15,90 @@ import Data.Text as T import Data.Text.Encoding import Data.Text.IO as T -import Data.Time.Clock.System import Data.Vector as V import qualified System.IO as S import qualified System.IO as SIO -import Text.Hex (encodeHex) +import Text.Read (readMaybe) +import Text.Printf (printf) +import Common +import DiffRender.DiffRender import Interpreter.Common import UI.Widgets.Common -import Common +initCharScreen :: BuiltInFnWithDoc '[] +initCharScreen _ = do + isTerminalParams <$> get >>= \case + Just (_, dm) -> do + dfr <- liftIO $ emptyDiffRender dm + SM.modify (\is -> is { isDiffRender = Just dfr }) + Nothing -> throwErr $ CustomRTE "Unknown terminal size" + pure Nothing + +charScreenGoto :: BuiltInFnWithDoc '[ '("x", Int), '("y", Int)] +charScreenGoto ((coerce -> x) :> (coerce -> y) :> _) = do + isDiffRender <$> get >>= \case + Just dm -> SM.modify (\is -> is { isDiffRender = Just $ dfSetCursorPosition x y dm }) + Nothing -> throwErr $ CustomRTE "Char screen not initialized" + pure Nothing + +charScreenPrint :: BuiltInFnWithDoc '[ '("values", Variadic)] +charScreenPrint ((coerce -> Variadic vals) :> _) = do + isDiffRender <$> get >>= \case + Just dm -> dfPutText (Plain (T.concat $ toStringVal <$> vals)) dm + Nothing -> throwErr $ CustomRTE "Char screen not initialized" + pure Nothing + +charScreenClear :: BuiltInFnWithDoc '[] +charScreenClear _ = do + isDiffRender <$> get >>= \case + Just dm -> dfClear dm + Nothing -> throwErr $ CustomRTE "Char screen not initialized" + pure Nothing + +charScreenDraw :: BuiltInFnWithDoc '[] +charScreenDraw _ = do + isDiffRender <$> get >>= \case + Just dm -> do + tp <- isTerminalParams <$> get + dfr' <- do + isStdoutLock <$> get >>= \case + Just sem -> do + liftIO $ atomically $ waitTSem sem + d' <- dfDraw tp dm + liftIO $ atomically $ signalTSem sem + pure d' + Nothing -> dfDraw tp dm + SM.modify (\is -> is { isDiffRender = Just dfr' }) + Nothing -> throwErr $ CustomRTE "Char screen not initialized" + pure Nothing + +toStringValFmt :: (Text, Int, [Int]) -> Value -> Text +toStringValFmt (s, _, p) v@(NumberValue (NumberInt _)) = amountFormat s p $ toStringVal v +toStringValFmt (s, f, p) (NumberValue (NumberFractional x)) = amountFormat s p $ T.pack $ printf ("%0." Prelude.++ show f Prelude.++ "f") x +toStringValFmt _ v = toStringVal v + printValLn :: BuiltInFnWithDoc '[ '("value", Variadic)] printValLn ((coerce -> (Variadic vals)) :> EmptyArgs) = do + outH <- isOutputHandle <$> get + tstrFn <- isDefaultPrintParams <$> get >>= \case + Just p -> pure $ toStringValFmt p + Nothing -> pure toStringVal liftIO $ do - UI.Widgets.Common.mapM_ T.putStr (toStringVal <$> vals) - T.putStrLn "" - S.hFlush S.stdout + UI.Widgets.Common.mapM_ (T.hPutStr outH) (tstrFn <$> vals) + T.hPutStrLn outH "" + S.hFlush outH pure Nothing printVal :: BuiltInFnWithDoc '[ '("value", Variadic)] printVal ((coerce -> (Variadic vals)) :> EmptyArgs) = do + outH <- isOutputHandle <$> get + tstrFn <- isDefaultPrintParams <$> get >>= \case + Just p -> pure $ toStringValFmt p + Nothing -> pure toStringVal liftIO $ do - UI.Widgets.Common.mapM_ T.putStr (toStringVal <$> vals) - S.hFlush S.stdout + UI.Widgets.Common.mapM_ (T.hPutStr outH) (tstrFn <$> vals) + S.hFlush outH pure Nothing numberFromString :: BuiltInFnWithDoc '[ '("string", Text)] @@ -80,7 +142,7 @@ contains ((coerce -> v1) :> (coerce -> v2) :> EmptyArgs) = case v1 of TCText t -> case v2 of StringValue v -> pure $ Just $ BoolValue $ T.isInfixOf v t - v -> throwBadArgs [v] "string" + v -> throwBadArgs [v] "string" TCList lst -> pure $ Just $ BoolValue $ V.foldl' fn False lst where fn :: Bool -> Value -> Bool @@ -122,7 +184,7 @@ builtInReadTextFile :: BuiltInFnWithDoc '[ '("filename", FilePath)] builtInReadTextFile ((coerce -> filepath) :> _) = do - c <- liftIO $ T.readFile filepath + c <- decodeUtf8 <$> (liftIO $ BS.readFile filepath) pure $ Just $ StringValue c builtInHead :: BuiltInFnWithDoc '[ '("source_list", Vector Value)] @@ -132,13 +194,13 @@ builtInTry :: BuiltInFnWithDoc '[ '("evaluation", EitherError Value), '("alternate", Value)] builtInTry ((coerce -> evaluation) :> (coerce -> alternate) :> _) = case evaluation of - EitherError (Left _) -> pure $ Just alternate + EitherError (Left _) -> pure $ Just alternate EitherError (Right v) -> pure $ Just v builtInTimestamp :: BuiltInFnWithDoc '[] builtInTimestamp _ = do - st <- liftIO $ truncateSystemTimeLeapSecond <$> getSystemTime - pure $ Just $ NumberValue $ NumberInt $ ((fromIntegral $ systemSeconds st) * 1e9) + (fromIntegral $ systemNanoseconds st) + st <- liftIO getSystemTimestamp + pure $ Just $ NumberValue $ NumberInt st serializeJSON :: Value -> InterpretM BS.ByteString serializeJSON v = @@ -168,7 +230,7 @@ builtInDebug :: BuiltInFnWithDoc '[] builtInDebug _ = do SM.modify (\is -> case isRunMode is of - NormalMode (Just debugEnv) -> is { isRunMode = DebugMode (debugEnv { deStepMode = SingleStep }) } + DebugMode debugEnv -> is { isRunMode = DebugMode (debugEnv { deStepMode = SingleStep }) } _ -> is ) pure Nothing @@ -209,26 +271,6 @@ interpreterOutput prompt interpreterOutputFlush (Just . StringValue) <$> readInterpreterInputLine - -toStringVal :: Value -> Text -toStringVal = \case - StringValue t -> t - NumberValue (NumberInt i) -> pack $ show i - NumberValue (NumberFractional i) -> pack $ show i - BoolValue True -> "true" - BoolValue False -> "false" - BytesValue b -> "0x" <> encodeHex b - ArrayValue _ -> "[array]" - ObjectValue _ -> "[object]" - ProcedureValue _ -> "(procedure)" - ThreadRef _ -> "(thread_ref)" - Channel _ -> "(concurrency_channel)" - Ref _ -> "(mutable_ref)" - UnnamedFnValue _ -> "(unnamed_function)" - Void -> "(void)" - BuiltIn _ -> "(builtin)" - s@(ErrorValue _) -> pack $ show s - SDLValue s -> pack $ show s valueSize :: BuiltInFnWithDoc '[ '("list_or_map", Value)] valueSize ((coerce -> v1) :> _) = case v1 of diff --git a/src/Interpreter/Lib/String.hs b/src/Interpreter/Lib/String.hs --- a/src/Interpreter/Lib/String.hs +++ b/src/Interpreter/Lib/String.hs @@ -24,3 +24,11 @@ builtInSplit :: BuiltInFnWithDoc '[ '("divider", Text), '("text", Text)] builtInSplit ((coerce -> b) :> (coerce -> d) :> EmptyArgs) = pure $ Just $ ArrayValue $ V.fromList $ StringValue <$> T.splitOn b d + +builtInToString :: BuiltInFnWithDoc '[ '("value", Value)] +builtInToString ((coerce -> b) :> EmptyArgs) = + pure $ Just $ StringValue $ toStringVal b + +builtInAmountFormat :: BuiltInFnWithDoc '[ '("separator", Text), '("positions", [Int]), '("value", Value)] +builtInAmountFormat ((coerce -> (sep :: Text)) :> (coerce -> (positions :: [Int])) :> (coerce -> (v :: Value)) :> EmptyArgs) = + pure $ Just $ StringValue $ amountFormat sep positions (toStringVal v) diff --git a/src/Parser/Parser.hs b/src/Parser/Parser.hs --- a/src/Parser/Parser.hs +++ b/src/Parser/Parser.hs @@ -15,7 +15,7 @@ } deriving (Eq, Show) instance HReadable (ParseErrorWithParsed a) where - hReadable ParseErrorWithParsed {..} = "Incomplete parse: Error at: " <> (hReadable errorAt) <> " Error:" <> (hReadable parseError) + hReadable ParseErrorWithParsed {..} = "Incomplete parse: Error at: " <> (hReadable errorAt) <> ", " <> (hReadable parseError) data FatalParseError = IncompleteParse @@ -25,7 +25,7 @@ instance HReadable FatalParseError where hReadable = \case IncompleteParse -> "Input does not match any known pattern at location" - CustomError msg -> "Fatal parse error:" <> msg + CustomError msg -> msg moveLines :: Location -> Int -> Location moveLines Location {..} lc = let @@ -48,8 +48,8 @@ hReadable = \case CantHandle -> "Parser can't handle this input" Empty -> "The input was empty" - FatalErrorWithLocation l fp -> "Fatal parse error:" <> (hReadable fp) <> " at:" <> (hReadable l) - FatalError fp -> "Fatal parse error:" <> (hReadable fp) + FatalErrorWithLocation l fp -> (hReadable fp) <> " at: " <> (hReadable l) + FatalError fp -> hReadable fp class HaveLocation a where getLocation :: a -> Location @@ -138,7 +138,7 @@ a -> pure a ) empty = ParserM "empty" (\s -> pure (Left Empty, s)) many p@(ParserM name _) = let (ParserM _ fn) = ((some p) <|> (pure [])) in ParserM ("many of " <> name) fn - some (ParserM name fn) = ParserM ("some of " <> name) (\s -> collect ([], s) >>= \case + some (ParserM name fn) = ParserM ("one or more " <> name) (\s -> collect ([], s) >>= \case (Right [], _) -> pure (Left CantHandle, s) (Right (r@(_:_)), rst) -> pure (Right (Prelude.reverse r), rst) (Left err, rst) -> pure (Left err, rst)) diff --git a/src/UI/Widgets/Common.hs b/src/UI/Widgets/Common.hs --- a/src/UI/Widgets/Common.hs +++ b/src/UI/Widgets/Common.hs @@ -13,11 +13,9 @@ import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TChan import Control.Exception -import qualified System.IO as SIO import Control.Monad.IO.Class import Control.Monad.Loops (iterateWhile) import Data.Bits -import Data.Word import Data.Constraint import Data.Kind (Type) import Data.Map.Strict as M hiding (keys) @@ -27,56 +25,65 @@ import qualified Data.Text as C import Data.Text.IO as T import Data.Typeable (Proxy(..), Typeable, cast, typeRep) -import Data.Vector.Mutable (IOVector) import qualified Data.Vector.Mutable as MV +import Data.Word import GHC.Stack +import qualified System.IO as SIO import System.Random import qualified System.Terminal as TERM import UI.Chars import UI.Terminal.IO -import Highlighter.Highlighter import Control.Monad import Control.Monad.State.Strict +import DiffRender.DiffRender +import Highlighter.Highlighter import qualified System.Console.ANSI as A import qualified System.IO as S data WidgetState = WidgetState - { wsWidgets :: Map Int SomeWidget - , wsCursorWidget :: Maybe SomeKeyInputWidget -- Widget that authoritativly decide the status/location of cursor. Does not decide what widgets receive keyboard input - , wsScreenState :: ScreenState - , wsCursorVisible :: Bool - , wsScreenStateBack :: ScreenState + { wsWidgets :: Map Int SomeWidget + , wsCursorWidget :: Maybe SomeKeyInputWidget -- Widget that authoritativly decide the status/location of cursor. Does not decide what widgets receive keyboard input + , wsCursorVisible :: Bool } -data ScreenState = ScreenState - { ssLines :: IOVector [StyledText] - , ssCursorPos :: ScreenPos - , ssColumns :: Int - , ssCursorOverflow :: Bool +data UIState = UIState + { usWidgetState :: WidgetState + , usDiffRender :: DiffRender } +liftWSMod :: (WidgetState -> WidgetState) -> (UIState -> UIState) +liftWSMod fn = (\us -> us { usWidgetState = fn $ usWidgetState us }) + +class HasCharScreen m where + csInitialize :: Dimensions -> m () + csClear :: m () + csDraw :: m () + csPutText :: StyledText -> m () + csSetCursorPosition :: Int -> Int -> m () + setCursorVisibility :: WidgetC m => Bool -> m () -setCursorVisibility b = modify (\ws -> ws { wsCursorVisible = b }) +setCursorVisibility b = modify $ liftWSMod (\ws -> ws { wsCursorVisible = b }) -emptyScreenState :: Int -> Int -> IO ScreenState -emptyScreenState rows cols = do - stLines <- MV.generate rows (\_ -> [Plain (T.replicate cols " ")]) - pure (ScreenState stLines (ScreenPos 0 0) cols True) +emptyWidgetState :: WidgetState +emptyWidgetState = do + WidgetState mempty Nothing True -emptyWidgetState :: Int -> Int -> IO WidgetState -emptyWidgetState lineCount columns = do - ss <- emptyScreenState lineCount columns - ssBack <- emptyScreenState lineCount columns - pure $ WidgetState mempty Nothing ss True ssBack +emptyUIState :: Dimensions -> IO UIState +emptyUIState dim = do + dfr <- emptyDiffRender dim + pure $ UIState emptyWidgetState dfr -type WidgetM m a = MonadIO m => StateT WidgetState m a +type WidgetM m a = MonadIO m => StateT UIState m a -runWidgetM' :: MonadIO m => WidgetM m a -> m (a, WidgetState) +runWidgetM' :: MonadIO m => WidgetM m a -> m (a, UIState) runWidgetM' act = do - ws <- liftIO $ emptyWidgetState 0 0 - flip runStateT ws act + ws <- liftIO $ emptyUIState $ Dimensions 0 0 + runWidgetM'' ws act +runWidgetM'' :: MonadIO m => UIState -> WidgetM m a -> m (a, UIState) +runWidgetM'' ws act = flip runStateT ws act + runWidgetM :: MonadIO m => WidgetM m a -> m a runWidgetM act = fst <$> runWidgetM' act @@ -86,82 +93,48 @@ , HasRandom m , HasLog m , HasTerminal m - , MonadState WidgetState m + , MonadState UIState m , MonadIO m ) getScreenBounds :: WidgetC m => m Dimensions getScreenBounds = do - screenState <- wsScreenState <$> get + screenState <- (dfScreenState . usDiffRender) <$> get let screenLines = ssLines screenState screenColumns = ssColumns screenState pure $ Dimensions screenColumns (MV.length screenLines) -instance MonadIO m => HasRandom (StateT WidgetState m) where +instance MonadIO m => HasRandom (StateT UIState m) where getRandom = liftIO randomIO -instance MonadIO m => HasCharScreen (StateT WidgetState m) where - csInitialize (Dimensions cols rows) = do - -- Initialize the screen memory for the dimensions - -- and initialize to whitespaces. - (ss, ssBack) <- liftIO $ do - ss <- emptyScreenState rows cols - ssBack <- emptyScreenState rows cols - pure (ss, ssBack) - modify (\ws -> ws { wsScreenState = ss, wsScreenStateBack = ssBack }) +instance MonadIO m => HasCharScreen (StateT UIState m) where + csInitialize dim = do + emptyDfr <- liftIO $ emptyDiffRender dim + modify (\ws -> ws { usDiffRender = emptyDfr }) - csClear = do - -- Clears the back buffer before starting to write - -- stuff. - bb <- wsScreenStateBack <$> get - liftIO $ MV.set (ssLines bb) [Plain (T.replicate (ssColumns bb) " ")] + csClear = usDiffRender <$> get >>= dfClear csDraw = do - -- ^ Compares the stuff that has been written to backbuffer - -- with the stuff already on frontbuffer, and send the instructions - -- to draw the changes. Then switch frontbuffer and backbuffers to - -- prepare for the next draw cycle. - WidgetState { wsScreenState = (ssLines -> ss), wsScreenStateBack = (ssLines -> ssb) } <- get - liftIO $ MV.imapM_ (\idx neLine -> do - oldLine <- MV.read ss idx - if (oldLine /= neLine) - then do - A.setCursorPosition idx 0 - -- mapM_ (\x -> do T.putStr x; S.hFlush stdout; threadDelay 10000;) (stRender <$> neLine) - mapM_ T.putStr (stRender <$> neLine) - S.hFlush stdout - else pure () - ) ssb - wsCursorVisible <$> get >>= \case + nDfr <- usDiffRender <$> get >>= dfDraw Nothing + modify (\ws -> ws { usDiffRender = nDfr }) + + (wsCursorVisible . usWidgetState) <$> get >>= \case False -> pure () True -> - (wsCursorWidget <$> get) >>= \case + ((wsCursorWidget . usWidgetState) <$> get) >>= \case Just (SomeKeyInputWidget fref) -> getCursorInfo fref >>= \case Just (cl, csst) -> do liftIO $ A.setCursorPosition (sY cl) (sX cl) putTextFlush $ cursorStyleCode csst Nothing -> pure () Nothing -> pure () - modify (\ws -> ws { wsScreenStateBack = wsScreenState ws, wsScreenState = wsScreenStateBack ws }) - csPutText t = do - -- Write stuff to the backbuffer. If the cursor is in an overflow position, then do nothing. - (ScreenState {ssLines = ssLns, ssCursorOverflow = cursorOverflow, ssCursorPos = ScreenPos cx cy}) <- wsScreenStateBack <$> get - if cursorOverflow - then pure () - else liftIO $ flip (MV.modify ssLns) cy $ \l -> stInsert l cx t + csPutText t = usDiffRender <$> get >>= dfPutText t csSetCursorPosition x y = do - -- Sets the cursor position in the backbuffer. - modify (\ws -> - let - screenState = wsScreenStateBack ws - screenLines = ssLines screenState - screenColumns = ssColumns screenState - in if (x >= 0 && x < screenColumns) && (y >= 0 && y < (MV.length screenLines)) - then ws { wsScreenStateBack = screenState { ssCursorOverflow = False, ssCursorPos = ScreenPos x y }} - else ws { wsScreenStateBack = screenState { ssCursorOverflow = True }}) + dfr <- usDiffRender <$> get + modify (\ws -> ws { usDiffRender = dfSetCursorPosition x y dfr }) getTerminalSizeIO :: IO (Maybe (Int, Int)) getTerminalSizeIO = do @@ -169,7 +142,7 @@ Just (y, x) -> pure $ Just (x, y) Nothing -> pure Nothing -instance MonadIO m => HasTerminal (StateT WidgetState m) where +instance MonadIO m => HasTerminal (StateT UIState m) where setCursorPosition x y = do liftIO $ A.setCursorPosition y x hFlush @@ -192,7 +165,7 @@ hFlush clearline = liftIO $ A.hClearFromCursorToLineEnd stdout -instance MonadIO m => HasLog (StateT WidgetState m) where +instance MonadIO m => HasLog (StateT UIState m) where appendLog a = liftIO (appendLog a) -- Below, the type parameter `a` is left in case we need to use tagged @@ -302,22 +275,22 @@ readWRef :: forall a m. (WidgetC m, Widget a) => WRef a -> m a readWRef (WRef ref) = do - (fromMaybe (error "not found") . M.lookup ref . wsWidgets) <$> get >>= \case + (fromMaybe (error "not found") . M.lookup ref . wsWidgets . usWidgetState) <$> get >>= \case SomeWidget w -> case cast w of Just a -> pure a Nothing -> error "Unexpected type" modifyWRef :: (WidgetC m, Widget a) => WRef a -> (a -> a) -> m () modifyWRef (WRef ref) fn = - modify $ \s -> s { wsWidgets = M.update (Just . (modifySomeWidget fn)) ref $ wsWidgets s } + modify $ liftWSMod $ \s -> s { wsWidgets = M.update (Just . (modifySomeWidget fn)) ref $ wsWidgets s } modifyWRefM :: (WidgetC m, Widget a) => WRef a -> (a -> m a) -> m () modifyWRefM (WRef ref) fn = do - m <- wsWidgets <$> get + m <- (wsWidgets . usWidgetState) <$> get case M.lookup ref m of Just sw -> do nSw <- modifySomeWidgetM fn sw - modify $ \s -> s { wsWidgets = M.update (\_ -> Just nSw) ref $ wsWidgets s } + modify $ liftWSMod $ \s -> s { wsWidgets = M.update (\_ -> Just nSw) ref $ wsWidgets s } Nothing -> pure () modifySomeWidget :: Widget a => (a -> a) -> SomeWidget -> SomeWidget @@ -337,7 +310,7 @@ newWRef :: (WidgetC m, Widget a) => a -> m (WRef a) newWRef a = do ref <- getRandom - modify $ \s -> s { wsWidgets = M.insert ref (SomeWidget a) $ wsWidgets s } + modify $ liftWSMod $ \s -> s { wsWidgets = M.insert ref (SomeWidget a) $ wsWidgets s } pure (WRef ref) data CtrlKey @@ -394,19 +367,11 @@ class HasCursor m where getCursor :: m CursorInfo -class HasCharScreen m where - csInitialize :: Dimensions -> m () - csClear :: m () - csDraw :: m () - csPutText :: StyledText -> m () - csSetCursorPosition :: Int -> Int -> m () - class Layout a where addWidget :: (WidgetC m, Widget child) => WRef a -> Text -> WRef child -> m () - setTextFocus :: WidgetC m => WRef a -> Text -> m () class Drawable a where - draw :: (WidgetC m) => WRef a -> m () + draw :: WidgetC m => WRef a -> m () setVisibility :: WidgetC m => WRef a -> Bool -> m () getVisibility :: WidgetC m => WRef a -> m Bool @@ -465,6 +430,26 @@ wSetCursor sp let titleLength = T.length title csPutText $ StyledText NoStyle [Plain $ C.concat [C.replicate (titleOffset - 1) (C.singleton horizontalLine), C.singleton verticalRight], colorText A.White A.Blue title, Plain (C.singleton verticalLeft <> C.replicate (width - titleLength - titleOffset - 1) (C.singleton horizontalLine)) ] + +drawTitleLineVertical :: WidgetC m => ScreenPos -> Int -> Int -> Maybe Text -> m () +drawTitleLineVertical sp height titleOffset (fromMaybe "" -> title) = do + wSetCursor sp + let titleLength = T.length title + + forM_ [0..(titleOffset - 1)] (\r -> do + wSetCursor $ moveDown r sp + csPutText $ Plain $ C.concat [C.singleton verticalLine] + ) + + forM_ (Prelude.zip [titleOffset ..] (T.unpack title)) (\(r, c) -> do + wSetCursor $ moveDown r sp + csPutText $ colorText A.White A.Blue $ C.singleton c + ) + + forM_ [(titleOffset + titleLength) .. (height - 1)] (\r -> do + wSetCursor $ moveDown r sp + csPutText $ Plain $ C.concat [C.singleton verticalLine] + ) drawBorderBox :: WidgetC m => ScreenPos -> Dimensions -> m () drawBorderBox sp Dimensions {..} = do diff --git a/src/UI/Widgets/Editor.hs b/src/UI/Widgets/Editor.hs --- a/src/UI/Widgets/Editor.hs +++ b/src/UI/Widgets/Editor.hs @@ -9,6 +9,7 @@ import System.Console.ANSI (Color(..)) import Text.Printf +import DiffRender.DiffRender import Common import Highlighter.Highlighter import UI.Widgets.Common @@ -20,6 +21,15 @@ data SomeTokenStream where SomeTokenStream :: (Show a, Highlightable a) => IO [a] -> SomeTokenStream +data SelectionInfo = SelectionInfo + { slStart :: Int + , slRangeStart :: Int + , slRangeEnd :: Int + } + +selectionToTuple :: SelectionInfo -> (Int, Int) +selectionToTuple SelectionInfo {..} = (slRangeStart, slRangeEnd) + data EditorWidget = EditorWidget { ewContent :: Text , ewDim :: Dimensions @@ -37,7 +47,7 @@ , ewAutocompleteSuggestions :: (forall m. MonadIO m => Text -> m [(Text, Text)]) , ewReadOnly :: Bool , ewCursorInfo :: CursorInfo -- Cursor info (location relative to the begining of text) - , ewSelection :: Maybe (Int, Int) + , ewSelection :: Maybe SelectionInfo , ewShowVirtualCursor :: Bool , ewParams :: EditorParams , ewCursorLine :: Int -- Line on which the cursor is currently. 1 based @@ -84,7 +94,9 @@ getTextContentStart :: Dimensions -> EditorParams -> ScreenPos getTextContentStart d ep = let (tp, _) = getTextPaddingAndSoftLineLength d ep - in addSp (ScreenPos (tp - 1) 0) (getContentStart ep) + epBorderSize = if epBorder ep then 1 else 0 + gutterBorder = epBorderSize + epGutterSize ep + in addSp (ScreenPos (tp - gutterBorder) 0) (getContentStart ep) resetCursor :: EditorWidget -> EditorWidget resetCursor ew = ew { ewScrollOffset = 0, ewCursor = 0, ewCursorInfo = (ScreenPos 0 0, Bar) } @@ -117,7 +129,7 @@ let mDlocation = ewDebugLocation w let mElocation = ewParseErrorLocation w - let mSelection = ewSelection w + let mSelection = selectionToTuple <$> ewSelection w let mCursorLoc = if (ewShowVirtualCursor w) then Just (ewCursor w) else Nothing let contentStartPos = addSp (getContentStart params) (ewPos w) case ewTokenStream w of @@ -350,7 +362,10 @@ pure (newContent, (replacementLen - lastWordLen)) mkRange :: (Int, Int) -> (Int, Int) -mkRange (r1, r2) = (min r1 r2, max r1 r2) +mkRange (r1, r2) + | (r2 > r1 && r2 > 0) = (r1, r2 - 1) + | (r2 < r1 && r1 > 0) = (r2, r1 - 1) + | otherwise = (r1, r2) data CursorMovement = CVert CursorMovementVertical | CRIGHT Int | CLEFT | CHOME | CEND @@ -375,9 +390,8 @@ in case offsetToScreenPos contentWidth lineLengths nc of Just (newsp, cl) -> let newEw = ew { ewCursorLine = cl, ewCursorInfo = (newsp, cStyle), ewCursor = nc } - newScrollOffset = if (sY currentCursorSp /= sY newsp) - then computeScrollOffset newEw newsp - else ewScrollOffset newEw + newScrollOffset = + computeScrollOffset newEw newsp in newEw { ewScrollOffset = newScrollOffset } Nothing -> ew where @@ -506,13 +520,16 @@ isAutoCompleting ew ev >>= \case True -> pure ew False -> do - let oldCursor = ewCursor ew let newEw = moveCursor ew cm let newCursor = ewCursor newEw let newSelection = if sh - then case ewSelection ew of - Just (ss, _) -> Just $ mkRange (ss, newCursor - 1) - Nothing -> Just $ mkRange (oldCursor, newCursor - 1) + then + let + selectionStart = case ewSelection ew of + Just (SelectionInfo s _ _) -> s + Nothing -> ewCursor ew + (rs, re) = mkRange (selectionStart, newCursor) + in Just $ SelectionInfo selectionStart rs re else Nothing pure $ newEw { ewSelection = newSelection } diff --git a/src/UI/Widgets/Layout.hs b/src/UI/Widgets/Layout.hs --- a/src/UI/Widgets/Layout.hs +++ b/src/UI/Widgets/Layout.hs @@ -19,7 +19,6 @@ , lowPos :: ScreenPos , lowContent :: OMap ContentId SomeWidgetRef , lowOrientation :: Orientation - , lowTextFocus :: Maybe SomeKeyInputWidget , lowVisibility :: Bool , lowFloatingContent :: [SomeWidgetRef] , lowDimensionDistribution :: Int -> [Double] @@ -28,26 +27,10 @@ instance Layout LayoutWidget where addWidget ref (coerce -> contentId) child = modifyWRef ref (\low -> low { lowContent = (lowContent low) |> (contentId, (SomeWidgetRef child)) }) - setTextFocus ref (coerce -> child) = do - w <- readWRef ref - case OMap.lookup child (lowContent w) of - Nothing -> pure () - Just (SomeWidgetRef ti) -> - withCapability (KeyInputCap ti) $ - modifyWRef ref (\low -> low { lowTextFocus = Just $ SomeKeyInputWidget ti }) -instance KeyInput LayoutWidget where - getCursorInfo _ = pure Nothing - handleInput ref kv = do - w <- readWRef ref - case lowTextFocus w of - Just (SomeKeyInputWidget tr) -> handleInput tr kv - Nothing -> pure () - instance Widget LayoutWidget where hasCapability (DrawableCap _) = Just Dict hasCapability (MoveableCap _) = Just Dict - hasCapability (KeyInputCap _) = Just Dict hasCapability _ = Nothing instance Moveable LayoutWidget where @@ -119,16 +102,14 @@ :: WidgetC m => Orientation -> (Int -> [Double]) - -> Maybe SomeKeyInputWidget -> m (WRef LayoutWidget) -layoutWidget ori distr tif = do +layoutWidget ori distr = do newWRef $ LayoutWidget { lowDim = Dimensions 0 0 , lowPos = origin , lowContent = OMap.empty , lowOrientation = ori - , lowTextFocus = tif , lowVisibility = True , lowFloatingContent = [] , lowDimensionDistribution = distr diff --git a/src/UI/Widgets/LogWidget.hs b/src/UI/Widgets/LogWidget.hs --- a/src/UI/Widgets/LogWidget.hs +++ b/src/UI/Widgets/LogWidget.hs @@ -15,14 +15,8 @@ insertLog :: WidgetC m => WRef LogWidget -> Text -> m () insertLog ref l = do - lw' <- readWRef ref - modifyWRef ref (\lw -> - let - h = diH $ lwDim lw - ln = Prelude.length (lwContent lw) - newContent = (lwContent lw) ++ [l] - in if ln > h then lw { lwContent = Prelude.drop (ln - h) newContent } else lw { lwContent = newContent }) - scrollToBottom (lwContentWidget lw') + timestr <- liftIO getLocalTimeString + modifyWRef ref (\lw -> lw { lwContent = Prelude.take 20 $ (timestr <> ": " <> l) : lwContent lw }) instance Moveable LogWidget where getPos ref = lwPos <$> readWRef ref @@ -48,7 +42,8 @@ True -> do move (lwContentWidget w) (lwPos w) resize (lwContentWidget w) (\_ -> (lwDim w)) - setContent (lwContentWidget w) (T.intercalate "\n" (lwContent w)) + setContent (lwContentWidget w) (T.intercalate "\n" (Prelude.reverse $ lwContent w)) + scrollToBottom (lwContentWidget w) draw (lwContentWidget w) logWidget diff --git a/src/UI/Widgets/OutputContainer.hs b/src/UI/Widgets/OutputContainer.hs new file mode 100644 --- /dev/null +++ b/src/UI/Widgets/OutputContainer.hs @@ -0,0 +1,69 @@ +module UI.Widgets.OutputContainer where + +import Control.Concurrent +import qualified Control.Concurrent.STM as STM +import qualified Data.List as DL +import qualified Data.Text as T +import qualified System.IO as SIO + +import Common +import DiffRender.DiffRender +import UI.Widgets.Common + +data OutputContainer = OutputContainer + { ocwHandle :: SIO.Handle + , ocwDim :: Dimensions + , ocwPos :: ScreenPos + , ocwVisibility :: Bool + , ocwBufferRef :: STM.TVar Text + } + +clearOutput :: WidgetC m => WRef OutputContainer -> m () +clearOutput ref = do + w <- readWRef ref + liftIO $ STM.atomically $ STM.writeTVar (ocwBufferRef w) "" + +instance Widget OutputContainer where + hasCapability (DrawableCap _) = Just Dict + hasCapability (MoveableCap _) = Just Dict + hasCapability _ = Nothing + +instance Moveable OutputContainer where + getPos ref = ocwPos <$> readWRef ref + move ref pos = + modifyWRef ref (\ocw -> ocw { ocwPos = pos }) + getDim ref = ocwDim <$> readWRef ref + resize ref cb = do + modifyWRef ref (\ocw -> ocw { ocwDim = cb $ ocwDim ocw }) + +dropExceptLast :: Int -> Text -> Text +dropExceptLast s l = T.drop (T.length l - s) l + +dropExceptLastList :: Int -> [Text] -> [Text] +dropExceptLastList s l = DL.drop (DL.length l - s) l + +instance Drawable OutputContainer where + setVisibility ref v = modifyWRef ref (\b -> b { ocwVisibility = v }) + getVisibility ref = ocwVisibility <$> readWRef ref + draw ref = do + ocw <- readWRef ref + let pos = ocwPos ocw + + stdOutChars <- liftIO (STM.readTVarIO (ocwBufferRef ocw)) + let stdOutLines = dropExceptLastList (diH $ ocwDim ocw) (T.split (== '\n') stdOutChars) + forM_ (Prelude.zip [0..] stdOutLines) (\(idx, ln) -> do + csSetCursorPosition (sX pos) (sY pos + idx) + csPutText (Plain (T.take (diW $ ocwDim ocw) ln)) + ) + +outputContainer + :: WidgetC m + => SIO.Handle + -> m (WRef OutputContainer) +outputContainer handle = do + bufRef <- liftIO $ STM.newTVarIO "" + void $ liftIO $ forkIO $ do + forever $ do + newChar <- liftIO $ SIO.hGetChar handle + STM.atomically $ STM.modifyTVar bufRef (\ln -> T.snoc ln newChar) + newWRef $ OutputContainer handle (Dimensions 0 0) (ScreenPos 0 0) True bufRef diff --git a/src/UI/Widgets/TextContainer.hs b/src/UI/Widgets/TextContainer.hs --- a/src/UI/Widgets/TextContainer.hs +++ b/src/UI/Widgets/TextContainer.hs @@ -3,6 +3,7 @@ import Data.Typeable import qualified Data.Text as T +import DiffRender.DiffRender import UI.Widgets.Common import Common diff --git a/src/UI/Widgets/TitledContainer.hs b/src/UI/Widgets/TitledContainer.hs --- a/src/UI/Widgets/TitledContainer.hs +++ b/src/UI/Widgets/TitledContainer.hs @@ -1,23 +1,27 @@ module UI.Widgets.TitledContainer where -import UI.Widgets.Common import Common +import UI.Widgets.Common data TitledContainer = TitledContainer - { ttcwTitle :: Text + { ttcwTitle :: Text , ttcwContent :: SomeWidgetRef , ttcwDim :: Dimensions , ttcwPos :: ScreenPos , ttcwVisibility :: Bool + , ttcwVertical :: Bool } setTitle :: TitledContainer -> Text -> TitledContainer setTitle tc t = tc { ttcwTitle = t } +setVertical :: TitledContainer -> TitledContainer +setVertical tc = tc { ttcwVertical = True } + instance Widget TitledContainer where hasCapability (DrawableCap _) = Just Dict hasCapability (MoveableCap _) = Just Dict - hasCapability _ = Nothing + hasCapability _ = Nothing instance Moveable TitledContainer where getPos ref = ttcwPos <$> readWRef ref @@ -32,19 +36,24 @@ getVisibility ref = ttcwVisibility <$> readWRef ref draw ref = do w <- readWRef ref - drawTitleLine (ttcwPos w) (diW $ ttcwDim w) 3 (Just $ ttcwTitle w) + case (ttcwVertical w) of + True -> drawTitleLineVertical (ttcwPos w) (diH $ ttcwDim w) 3 (Just $ ttcwTitle w) + _ -> drawTitleLine (ttcwPos w) (diW $ ttcwDim w) 3 (Just $ ttcwTitle w) case (ttcwContent w) of SomeWidgetRef cw -> do withCapability (MoveableCap cw) $ do - move cw (moveDown 1 (ttcwPos w)) - resize cw (\_ -> amendHeight (\x -> x - 1) (ttcwDim w)) + case (ttcwVertical w) of + True -> do + move cw (moveRight 1 (ttcwPos w)) + resize cw (\_ -> amendWidth (\x -> x - 1) (ttcwDim w)) + _ -> do + move cw (moveDown 1 (ttcwPos w)) + resize cw (\_ -> amendHeight (\x -> x - 1) (ttcwDim w)) withCapability (DrawableCap cw) $ draw cw titledContainer - :: ScreenPos - -> Dimensions - -> SomeWidgetRef + :: SomeWidgetRef -> Text -> WidgetM m (WRef TitledContainer) -titledContainer sp dim cont title = newWRef $ TitledContainer title cont dim sp True +titledContainer cont title = newWRef $ TitledContainer title cont (Dimensions 0 0) (ScreenPos 0 0) True False diff --git a/test/UI/EditorSpec.hs b/test/UI/EditorSpec.hs --- a/test/UI/EditorSpec.hs +++ b/test/UI/EditorSpec.hs @@ -16,6 +16,8 @@ import UI.Widgets.Common as C import UI.Widgets.Editor import UI.Widgets.Editor.Cursor +import DiffRender.DiffRender +import Highlighter.Highlighter data ReferenceScreenState = ReferenceScreenState { rssLines :: [[StyledText]] @@ -25,7 +27,7 @@ assertReferenceScreenState :: ReferenceScreenState -> WRef EditorWidget -> WidgetM IO () assertReferenceScreenState ReferenceScreenState {..} ewRef = do EditorWidget {..} <- readWRef ewRef - ss <- wsScreenState <$> get + ss <- (dfScreenState . usDiffRender) <$> get let linesRef = (ssLines ss) lines' <- MV.foldr'(:) [] linesRef liftIO $ if lines' == rssLines then do @@ -38,7 +40,7 @@ runWidgetM $ do csInitialize $ Dimensions 18 10 ewRef <- editor (\_ -> pure []) Nothing - modifyWRef ewRef (\ew -> ew { ewPos = ScreenPos 0 0, ewDim = Dimensions 18 10, ewContent = content }) + modifyWRef ewRef (\ew -> ew { ewParams = (ewParams ew) { epLinenumberRightPad = 1 }, ewPos = ScreenPos 0 0, ewDim = Dimensions 18 10, ewContent = content }) csClear mapM_ (handleInput ewRef) kEvents draw ewRef @@ -177,6 +179,22 @@ describe "Editor reverse cursor positioning" $ do it "test1" $ do (screenPosToOffset [2,5] 5 (ScreenPos 5 0)) `shouldBe` (Just (2, 1, ScreenPos 2 0)) + + describe "Editor bottom cursor positioning" $ do + it "test1" $ do + let + test :: Expectation + test = do + ew <- runWidgetM $ do + csInitialize $ Dimensions 18 10 + ewRef <- editor (\_ -> pure []) Nothing + modifyWRef ewRef (\ew' -> ew' { ewDim = Dimensions 100 10, ewParams = (ewParams ew') { epBorder = False, epGutterSize = 0, epLinenumberRightPad = 0, epLineNos = False }}) + -- setContent ewRef (T.intercalate "\n" $ Prelude.take 20 $ repeat "abcdefgh") + setContent ewRef "20:53:35: Starting...\n20:53:37: Evaluating: csclear()\n20:53:40: Continuing debug session to end...\n20:53:42: Evaluating: csclear()\n20:53:43: thread killed\n20:53:44: Starting...\n20:53:45: Evaluating: wait(0.01)\n20:53:46: thread killed\n20:53:47: Starting...\n20:53:48: Evaluating: csclear()\n20:53:48: thread killed\n20:53:49: Starting...\n20:53:50: Evaluating: wait(0.01)\n20:53:51: thread killed\n20:53:51: Starting...\n20:53:53: Evaluating: wait(0.01)\n20:53:53: thread killed\n20:53:54: Starting...\n20:53:55: Evaluating: csclear()\n20:53:56: thread killed" + scrollToBottom ewRef + readWRef ewRef + (ewScrollOffset ew) `shouldBe` 10 + test mkSimpleToken :: Text -> Int -> SimpleToken mkSimpleToken x offset = NormalToken x (Location 0 0 offset) (offset + T.length x - 1) diff --git a/test/UI/WidgetSpec.hs b/test/UI/WidgetSpec.hs --- a/test/UI/WidgetSpec.hs +++ b/test/UI/WidgetSpec.hs @@ -3,9 +3,9 @@ import qualified Data.Text as T import Test.Hspec -import "spade" Common import Test.Hspec.Hedgehog import Test.Common +import DiffRender.DiffRender spec :: Spec spec =