spade 0.1.0.5 → 0.1.0.6
raw patch · 33 files changed
+882/−394 lines, 33 filesdep +with-utf8
Dependencies added: with-utf8
Files
- ChangeLog.md +8/−1
- README.md +1/−4
- app/Main.hs +27/−9
- docs/functions/misc.md +25/−0
- docs/functions/string.md +4/−0
- samples/char-animation.spd +20/−0
- samples/mandelbrot.spd +0/−0
- spade.cabal +7/−1
- src/Common.hs +18/−124
- src/Compiler/AST/Common.hs +2/−2
- src/Compiler/AST/FunctionStatement.hs +1/−1
- src/Compiler/Lexer/Tokens.hs +2/−0
- src/DiffRender/DiffRender.hs +194/−0
- src/Highlighter/Highlighter.hs +21/−0
- src/IDE/Common.hs +4/−0
- src/IDE/Help.hs +5/−5
- src/IDE/Help/Parser.hs +2/−0
- src/IDE/IDE.hs +150/−54
- src/Interpreter/Common.hs +62/−3
- src/Interpreter/Initialize.hs +7/−0
- src/Interpreter/Interpreter.hs +10/−3
- src/Interpreter/Lib/Misc.hs +77/−35
- src/Interpreter/Lib/String.hs +8/−0
- src/Parser/Parser.hs +5/−5
- src/UI/Widgets/Common.hs +79/−94
- src/UI/Widgets/Editor.hs +28/−11
- src/UI/Widgets/Layout.hs +1/−20
- src/UI/Widgets/LogWidget.hs +4/−9
- src/UI/Widgets/OutputContainer.hs +69/−0
- src/UI/Widgets/TextContainer.hs +1/−0
- src/UI/Widgets/TitledContainer.hs +19/−10
- test/UI/EditorSpec.hs +20/−2
- test/UI/WidgetSpec.hs +1/−1
ChangeLog.md view
@@ -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
README.md view
@@ -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.--[](https://asciinema.org/a/bG7PPKj0AaJq087ZNPxSZwcCl)+A short screen recording of SPADE in action can be seen [here](https://vimeo.com/692243011). ### Installing
app/Main.hs view
@@ -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
docs/functions/misc.md view
@@ -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.
docs/functions/string.md view
@@ -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.
+ samples/char-animation.spd view
@@ -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
samples/mandelbrot.spd view
spade.cabal view
@@ -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
src/Common.hs view
@@ -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 _ _ _ "" [] = ([], [])
src/Compiler/AST/Common.hs view
@@ -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)
src/Compiler/AST/FunctionStatement.hs view
@@ -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
src/Compiler/Lexer/Tokens.hs view
@@ -15,6 +15,8 @@ import Compiler.Lexer.Whitespaces import Parser import Test.Common+import DiffRender.DiffRender+import Highlighter.Highlighter data Token = Token { tkRaw :: TokenRaw
+ src/DiffRender/DiffRender.hs view
@@ -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)
src/Highlighter/Highlighter.hs view
@@ -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
src/IDE/Common.hs view
@@ -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)
src/IDE/Help.hs view
@@ -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"
src/IDE/Help/Parser.hs view
@@ -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
src/IDE/IDE.hs view
@@ -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
src/Interpreter/Common.hs view
@@ -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'))+
src/Interpreter/Initialize.hs view
@@ -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)
src/Interpreter/Interpreter.hs view
@@ -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) })
src/Interpreter/Lib/Misc.hs view
@@ -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
src/Interpreter/Lib/String.hs view
@@ -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)
src/Parser/Parser.hs view
@@ -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))
src/UI/Widgets/Common.hs view
@@ -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
src/UI/Widgets/Editor.hs view
@@ -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 }
src/UI/Widgets/Layout.hs view
@@ -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
src/UI/Widgets/LogWidget.hs view
@@ -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
+ src/UI/Widgets/OutputContainer.hs view
@@ -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
src/UI/Widgets/TextContainer.hs view
@@ -3,6 +3,7 @@ import Data.Typeable import qualified Data.Text as T +import DiffRender.DiffRender import UI.Widgets.Common import Common
src/UI/Widgets/TitledContainer.hs view
@@ -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
test/UI/EditorSpec.hs view
@@ -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)
test/UI/WidgetSpec.hs view
@@ -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 =