spade 0.1.0.2 → 0.1.0.3
raw patch · 39 files changed
+1738/−662 lines, 39 filesdep +terminaldep −Win32dep −vtydep ~Decimaldep ~WAVEdep ~aeson
Dependencies added: terminal
Dependencies removed: Win32, vty
Dependency ranges changed: Decimal, WAVE, aeson, ansi-terminal, bytestring, constraints, containers, exceptions, file-embed, hedgehog, hex-text, hspec, hspec-hedgehog, monad-loops, mtl, ordered-containers, process, random, scientific, sdl2, sdl2-mixer, stm, template-haskell, text, time, unordered-containers, vector
Files
- README.md +57/−14
- app/Main.hs +38/−14
- docs/functions/math.md +4/−0
- docs/functions/misc.md +10/−0
- docs/functions/string.md +25/−0
- docs/ide.md +11/−0
- samples/mandelbrot.spd +132/−0
- samples/paratrooper.spd +212/−0
- samples/snake.spd +88/−0
- spade.cabal +94/−102
- src/Common.hs +4/−4
- src/Compiler/Lexer/Literals.hs +17/−2
- src/IDE/Common.hs +3/−1
- src/IDE/Help.hs +33/−18
- src/IDE/IDE.hs +267/−149
- src/Interpreter.hs +6/−27
- src/Interpreter/Common.hs +137/−42
- src/Interpreter/Initialize.hs +12/−4
- src/Interpreter/Interpreter.hs +77/−58
- src/Interpreter/Lib/Concurrency.hs +5/−3
- src/Interpreter/Lib/Math.hs +3/−0
- src/Interpreter/Lib/Misc.hs +79/−76
- src/Interpreter/Lib/SDL.hs +61/−4
- src/Interpreter/Lib/String.hs +26/−0
- src/UI/Chars.hs +6/−0
- src/UI/Widgets/BorderBox.hs +10/−7
- src/UI/Widgets/Common.hs +66/−41
- src/UI/Widgets/Editor.hs +36/−21
- src/UI/Widgets/Layout.hs +4/−7
- src/UI/Widgets/LogWidget.hs +21/−36
- src/UI/Widgets/MenuContainer.hs +19/−11
- src/UI/Widgets/TextContainer.hs +15/−6
- src/UI/Widgets/TitledContainer.hs +50/−0
- src/UI/Widgets/WatchWidget.hs +15/−5
- stack.yaml +10/−9
- stack.yaml.lock +82/−0
- test/Compiler/Lexer/LiteralSpec.hs +1/−0
- test/Interpreter/InterpreterSpec.hs +1/−1
- test/UI/EditorSpec.hs +1/−0
README.md view
@@ -21,25 +21,74 @@ The entire language and function reference is available in the IDE in an easily searchable way. Press F1 or use the help menu to access it. +NOTE: This is still a very early version. The standard library is virtually non+existent, and those function present are the only ones that were required to write the+sample programs in the "samples" folder in this repo.+ ### IDE Demo-A small screen recording of SPADE in action can be seen here+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/SM9tZ2ZiJofikPRxHCQyqDvRY)+[](https://asciinema.org/a/bG7PPKj0AaJq087ZNPxSZwcCl) ### Installing -You can download the source package and use `stack` tool to build and install it.+#### Linux -After extracting the source to a folder, running the following command in the folder-should install it.+##### Run from a portable binary. +The easiest way to run spade on Linux is to download the portable executable+from [here](https://sras.me/releases). The latest release will be named+`spade.run`. After downloading the required `.run` file, make it executable+and run it.+ ```+chmod +x spade.run+./spade.run+```++The file is a self extraction archive containing most of the shared dependencies, so it should+hopefully work on most of the linux distros.++#### From source++##### Dependencies++To install depdendencies:++```+ apt-get install libsdl2-dev+ apt-get install libsdl2-mixer-dev+ apt-get install libtinfo-dev+```++You can download the source package '.tar.gz' file from hackage, and use cabal+or stack tool to build and install it. After extracting the source to a+folder, running either of the following commands in the folder should build and install+it.++```+cabal build && cabal install++```++``` stack build && stack install ``` -For the time being, this does not seem to build on Windows operating system.+#### Building on Raspberry PI +You should be able to install this in a Raspberry Pi 3 or later iterations. The following steps appear to+work for a succesful build on a Raspberry Pi 3.++1. Install GHC version 9.0.1 following steps described https://www.haskell.org/ghc/blog/20200515-ghc-on-arm.html+2. Install `stack tool` using `apt-get install haskell-stack`+3. Increase the swap space to 2GB, disable GUI by booting into terminal mode, and then build the program using `stack build --system-ghc`.++Depending on your setup, the initial build can take a very long time, like a couple of days.++ ### Getting started The program should be started by providing a file name. For example,@@ -63,12 +112,6 @@ Will execute the program without opening the IDE. -### Dependencies--To install depdendencies:+### Reporting bugs/issues -```- apt-get install libsdl2-dev- apt-get install libsdl2-mixer-dev- apt-get install libtinfo-dev-```+Please use the issue tracker [here](https://bitbucket.org/sras/spade/issues).
app/Main.hs view
@@ -1,28 +1,34 @@ 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 System.Environment import System.IO as SIO+import qualified System.Terminal as TERM +import Common import Compiler.Parser-import UI.Widgets.Common import IDE.IDE import Interpreter-import Interpreter.Common+import UI.Widgets.Common data CommandLineOptions = StartIDE FilePath | RunProgram FilePath+ | Version getCommandLineOption :: IO CommandLineOptions getCommandLineOption = do getArgs >>= \case+ ["version"] -> pure Version ["run", filePath] -> pure $ RunProgram filePath [filePath] -> pure $ StartIDE filePath+ [] -> pure $ StartIDE "untitled.spd" _ -> do 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." @@ -32,21 +38,39 @@ SIO.hSetBuffering stdin NoBuffering SIO.hSetBuffering stdout (BlockBuffering Nothing) - vty <- initializeVty- inputBroadcastChan <- liftIO newBroadcastTChanIO- void $ forkIO $ forever $ do- keys' <- readVtyEvent vty- mapM (atomically . writeTChan inputBroadcastChan) keys'+ interpreterThreadRef <- 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+ -- and just kills the thread id stored in this reference (which will be populated+ -- on starting the interpreter thread, in the IDE) + let+ inputForwardingThread :: (TerminalEvent -> IO ()) -> IO ()+ inputForwardingThread writeFn = do+ void $ forkIO $ TERM.withTerminal $ TERM.runTerminalT (do+ TERM.Size h w <- TERM.getWindowSize+ liftIO $ mapM_ writeFn [TerminalResize w h]++ forever $ do+ keys' <- readTerminalEvent+ case keys' of+ (TerminalInterrupt : _) -> liftIO $ do+ (atomically $ tryReadTMVar interpreterThreadRef) >>= \case+ Just threadId -> killThread threadId+ Nothing -> pass+ _ -> pass+ liftIO $ mapM_ writeFn keys'+ )+ getCommandLineOption >>= \case+ Version -> T.putStrLn $ T.pack $ show version RunProgram filePath -> do content <- T.readFile filePath program <- compile content- inputChan <- liftIO $ atomically $ dupTChan inputBroadcastChan- is <- interpret_ inputChan program- tryTakeMVar (isDebugOut is) >>= \case- Just (Errored t) -> T.putStrLn t- _ -> pure ()+ void $ interpret id program - StartIDE filePath -> runIDE filePath inputBroadcastChan- liftIO $ shutdownVty vty+ StartIDE filePath -> do+ inputChan <- liftIO newTChanIO+ inputForwardingThread (atomically . writeTChan inputChan)+ runIDE filePath inputChan interpreterThreadRef
docs/functions/math.md view
@@ -40,3 +40,7 @@ Rounds the argument to the nearest integer. +#### pow++Power of function.+
docs/functions/misc.md view
@@ -42,3 +42,13 @@ ``` wait(0.5) -- Waits for half second. ```++#### stringtonum++Convert a string to a number.++Example:++```+println(stringtonum("23.4") + 5) -- prints 28.4+```
docs/functions/string.md view
@@ -7,3 +7,28 @@ #### encodeutf8 Accepts a string argument and returns the bytes that represent its UTF-8 encoding.++#### concat++Concats two strings.++#### split++Splits a string using a separator++Example:++```+let parts = split(",", "a,b,c") -- returns ["a", "b", "c"]+```++#### join++Join string in the first argument by placing the string in the second argument+in between.++Example:++```+let parts = join(",", ["a", "b", "c"]) -- returns "a,b,c"+```
docs/ide.md view
@@ -1,5 +1,16 @@ ### IDE Reference +#### Starting the IDE++Pass a file name (existing or new) to load the program in the IDE.+For example "spade myprog.spd" loads the program from file "myprog.spd" into the+IDE. If such a file does not exist, then it is created upon saving the program.++#### Running a program without starting IDE++Use the "spade run" command to just run the interpreter on the spade program.+For example 'spade run myprog.spd' just runs the "myprog.spd" spade program.+ ##### Menu Menus are activated using Alt key combinations. 'Alt + f' opens file menu, 'Alt + r' opens run menu etc.
+ samples/mandelbrot.spd view
@@ -0,0 +1,132 @@+graphicswindow(800, 800, false)+let params = {"height":800,"scale":2.63331,"start":{"img":-1.54217315,"real":-2.0421},"step":0.0101525597994770,"width":800}+let params_ref = newref(params)+loop+ let ws = getwindowsize()+ setcolor(0, 0, 0)+ clearscreen()+ let params = readref(params_ref)+ writefile("/tmp/params.json", jsonencode(params))+ let n = drawmandelbrot(params)+ if (n == "exit") then+ break+ endif+endloop++proc drawmandelbrot(params)+ for x = 0 to round((params.width / params.scale))+ let n = drawonecol(params, x)+ if (n == "exit") then+ return n+ elseif (n == "redraw") then+ break+ endif+ endfor+ return "continue"+endproc++proc drawonecol(params, x)+ let real = (params.start.real + (x * params.step))+ for y = 0 to round((params.height / params.scale))+ let n = processkeys(params, getkeypresses())+ if (n !== "continue") then+ return n+ endif+ let current = {img: (params.start.img + (y * params.step)), real: real}+ let ds = isinset(current)+ setcolor((ds * 240), 0, 0)+ point((x * params.scale), (y * params.scale))+ endfor+ return "continue"+endproc++proc modifydict(dict, key, callback)+ let c = dict[key]+ let dict[key] = callback(c)+ return dict+endproc++proc modifykey(ref, key, callback)+ modifyref(ref, fn (x) modifydict(x, key, callback) endfn)+endproc++proc amendscale(params, mult)+ let current_center_x = (params.start.real + ((params.width / (2 * params.scale)) * params.step))+ let current_center_y = (params.start.img + ((params.height / (2 * params.scale)) * params.step))+ let newscale = (params.scale * mult)+ let new_center_x = (params.start.real + ((params.width / (2 * newscale)) * params.step))+ let new_center_y = (params.start.img + ((params.height / (2 * newscale)) * params.step))+ let params.start.real = (params.start.real + (current_center_x - new_center_x))+ let params.start.img = (params.start.img + (current_center_y - new_center_y))+ let params.scale = newscale+ return params+endproc++proc amendstep(params, mult)+ let current_center_x = (params.start.real + ((params.width / (2 * params.scale)) * params.step))+ let current_center_y = (params.start.img + ((params.height / (2 * params.scale)) * params.step))+ let newstep = (params.step * mult)+ let new_center_x = (params.start.real + ((params.width / (2 * params.scale)) * newstep))+ let new_center_y = (params.start.img + ((params.height / (2 * params.scale)) * newstep))+ let params.start.real = (params.start.real + (current_center_x - new_center_x))+ let params.start.img = (params.start.img + (current_center_y - new_center_y))+ let params.step = newstep+ return params+endproc++proc processkeys(range_start, keys)+ if contains(keys, keycodes.q) then+ return "exit"+ elseif contains(keys, keycodes.up) then+ modifykey(params_ref, "start", fn (x) modifydict(x, "img", fn (x) (x + 0.1) endfn) endfn)+ return "redraw"+ elseif contains(keys, keycodes.down) then+ modifykey(params_ref, "start", fn (x) modifydict(x, "img", fn (x) (x - 0.1) endfn) endfn)+ return "redraw"+ elseif contains(keys, keycodes.left) then+ modifykey(params_ref, "start", fn (x) modifydict(x, "real", fn (x) (x - 0.1) endfn) endfn)+ return "redraw"+ elseif contains(keys, keycodes.right) then+ modifykey(params_ref, "start", fn (x) modifydict(x, "real", fn (x) (x + 0.1) endfn) endfn)+ return "redraw"+ elseif contains(keys, keycodes.a) then+ modifyref(params_ref, fn (x) amendscale(x, (1 / 1.1)) endfn)+ return "redraw"+ elseif contains(keys, keycodes.z) then+ modifyref(params_ref, fn (x) amendscale(x, 1.1) endfn)+ return "redraw"+ elseif contains(keys, keycodes.s) then+ modifyref(params_ref, fn (x) amendstep(x, (1 / 1.1)) endfn)+ return "redraw"+ elseif contains(keys, keycodes.x) then+ modifyref(params_ref, fn (x) amendstep(x, 1.1) endfn)+ return "redraw"+ endif+ return "continue"+endproc++proc isinset(c)+ let r = false+ let current = {img: 0, real: 0}+ for i = 0 to 100+ let current = addcomplex(sqcomplex(current), c)+ if (magcomplex(current) > 100) then+ return i+ endif+ endfor+ return 0+endproc++proc magcomplex(c)+ return (pow(c.real, 2) + pow(c.img, 2))+endproc++proc addcomplex(c, d)+ return {img: (c.img + d.img), real: (c.real + d.real)}+endproc++proc sqcomplex(c)+ let real = (pow(c.real, 2) - pow(c.img, 2))+ let img = (2 * (c.real * c.img))+ return {img: img, real: real}+endproc
+ samples/paratrooper.spd view
@@ -0,0 +1,212 @@+graphics(true)+let windowsize = getwindowsize()+let ar = (windowsize.width / windowsize.height)+let lw = 2000+let ws = {height: (lw / ar), width: lw}+setlogicalsize(ws.width, ws.height)+let cannon = {angle: 0, x: (ws.width / 2), y: (ws.height - 90)}+let gamestate = {bullets: [], cannon: cannon, fragments: [], helicopters: [], troopers: []}+let lasttime = 0+let gatlingsound = maketone(355) -- loadsound("/home/sras/temp/gatling.aud.wav")+let helicopterpoints = [[1920, 1076], [1920, 1076], [1920, 1052], [1920, 1052], [1979, 1015], [1979, 1015], [2056, 1015], [2056, 1015], [2063, 1049], [2063, 1049], [2208, 1049], [2208, 1049], [2221, 1000], [2221, 1000], [2269, 1000], [2269, 1000], [2269, 1053], [2269, 1053], [1922, 1077], [1922, 1077]]+let trooperpoints = [[1920, 1034], [1920, 1034], [1920, 1012], [1920, 1012], [1933, 1012], [1933, 1012], [1933, 1034], [1933, 1034], [1947, 1034], [1947, 1034], [1952, 1051], [1952, 1051], [1946, 1053], [1946, 1053], [1946, 1043], [1946, 1043], [1939, 1058], [1939, 1058], [1945, 1080], [1945, 1080], [1935, 1080], [1935, 1080], [1933, 1058], [1933, 1058], [1924, 1078], [1924, 1078], [1916, 1078], [1916, 1078], [1920, 1058], [1920, 1058], [1913, 1041], [1913, 1041], [1911, 1055], [1911, 1055], [1901, 1055], [1901, 1055], [1909, 1035], [1909, 1035], [1921, 1035], [1921, 1035]]+let helicopterpoints_rl = scaleandnormalize(helicopterpoints, 1)+let helicopterpoints_lr = scaleandnormalize(helicopterpoints, -1)+let trooperpoints_s = scaleandnormalize(trooperpoints, 1)+playsound(gatlingsound, 0)+setvolume(0, 0)+loop+ drawworld(gamestate)+ let keys = getkeystate()+ if inkeystate(keys, scancodes.up) then+ setvolume(0, 128)+ let gamestate.bullets = insertleft(makebullet(gamestate.cannon.angle, 14000), gamestate.bullets)+ else+ setvolume(0, 0)+ endif+ if inkeystate(keys, scancodes.q) then+ break+ endif+ let nowtime = timestamp()+ let d = random(0, 2000)+ if ((d > 10) and (d < 13)) then+ if (d == 11) then+ let gamestate.helicopters = insertleft(makehelicopter(-30, (ws.height / 10), 1), gamestate.helicopters)+ else+ let gamestate.helicopters = insertleft(makehelicopter((ws.width + 30), (ws.height / 10), -1), gamestate.helicopters)+ endif+ else+ if ((d > 20) and ((d < 25) and (size(gamestate.helicopters) > 0))) then+ let randomheli = gamestate.helicopters[random(1, size(gamestate.helicopters))]+ let gamestate.troopers = insertleft(maketrooper(randomheli.x, randomheli.y), gamestate.troopers)+ endif+ endif+ if (lasttime > 0) then+ let et = ((nowtime - lasttime) / 1000000000)+ if inkeystate(keys, scancodes.left) then+ let gamestate.cannon.angle = (gamestate.cannon.angle + (100 * et))+ endif+ if inkeystate(keys, scancodes.right) then+ let gamestate.cannon.angle = (gamestate.cannon.angle - (100 * et))+ endif+ let gamestate = movegamestate(gamestate, et)+ endif+ let lasttime = nowtime+endloop++proc scaleandnormalize(pi, dir)+ let total_x = 0+ let total_y = 0+ let p = []+ foreach pi as i + let p = insertright(p, [(i[1] / 4), (i[2] / 4)])+ endforeach+ for i = 1 to size(p)+ let total_x = (total_x + p[i][1])+ let total_y = (total_y + p[i][2])+ endfor+ let median_x = (total_x / size(p))+ let median_y = (total_y / size(p))+ let r = []+ for i = 1 to size(p)+ let r = insertright(r, [(dir * (p[i][1] - median_x)), (p[i][2] - median_y)])+ endfor+ return r+endproc++proc makehelicopter(x, y, d)+ return {bladepos: 0, color: [0, 0, 255], destroyed: false, direction: d, x: x, y: y}+endproc++proc maketrooper(x, y)+ return {state: 0, x: x, y: y, destroyed: false}+endproc++proc makefragments(x, y, d)+ let r = []+ for i = 0 to 6+ let r = insertleft({age: 0, vx: (d * random(100, 450)), vy: 200, x: x, y: y}, r)+ endfor+ return r+endproc++proc drawtrooper(trooper)+ setcolor(0, 255, 0)+ let tps = []+ foreach trooperpoints_s as tp + let tps = insertright(tps, [(tp[1] + trooper.x), (tp[2] + trooper.y)])+ endforeach+ lines(tps)+endproc++proc drawhelicopter(helicopter)+ setcolor(255, 0, 0)+ let theli = []+ let hp = (if ((helicopter.direction == 1)) then helicopterpoints_lr else helicopterpoints_rl)+ for i = 1 to size(hp)+ let p = hp[i]+ let theli = insertright(theli, [(p[1] + helicopter.x), (p[2] + helicopter.y)])+ endfor+ lines(theli)+ let bladelength = (mod(helicopter.bladepos, 4) * 10)+ let prop_x = (helicopter.x + (helicopter.direction * 20))+ line((prop_x - bladelength), (helicopter.y - 15), (prop_x + bladelength), (helicopter.y - 15))+endproc++proc movegamestate(gs, et)+ for i = 1 to size(gs.bullets)+ let gs.bullets[i].x = (gs.bullets[i].x + (gs.bullets[i].v.x * et))+ let gs.bullets[i].y = (gs.bullets[i].y - (gs.bullets[i].v.y * et))+ let gs.bullets[i].v.y = (gs.bullets[i].v.y - (19000 * et))+ endfor+ for i = 1 to size(gs.helicopters)+ let h = gs.helicopters[i]+ let gs.helicopters[i].x = (h.x + (h.direction * (100 * et)))+ let gs.helicopters[i].bladepos = (gs.helicopters[i].bladepos + 1)+ foreach gs.bullets as b + let dx = (b.x - gs.helicopters[i].x)+ let dy = (b.y - gs.helicopters[i].y)+ if (((dx * dx) + (dy * dy)) < 2050) then+ let gs.helicopters[i].destroyed = true+ let gs.fragments = (gs.fragments + makefragments(gs.helicopters[i].x, gs.helicopters[i].y, gs.helicopters[i].direction))+ break+ endif+ endforeach+ endfor+ for i = 1 to size(gs.troopers)+ let gs.troopers[i].y = (gs.troopers[i].y + (100 * et))+ foreach gs.bullets as b + let dx = (b.x - gs.troopers[i].x)+ let dy = (b.y - gs.troopers[i].y)+ if (((dx * dx) + (dy * dy)) < 2050) then+ let gs.troopers[i].destroyed = true+ let gs.fragments = (gs.fragments + makefragments(gs.troopers[i].x, gs.troopers[i].y, 1))+ break+ endif+ endforeach+ endfor+ for i = 1 to size(gs.fragments)+ let t = gs.fragments[i]+ let gs.fragments[i].x = (t.x + (t.vx * et))+ let gs.fragments[i].y = (t.y - (t.vy * et))+ let gs.fragments[i].vy = (t.vy - (1000 * et))+ let gs.fragments[i].age = (gs.fragments[i].age + 0.01)+ endfor+ let gs.helicopters = filter(gs.helicopters, fn (h) (h.x > -40) and (h.x < (ws.width + 40)) and not(h.destroyed) endfn)+ let gs.bullets = filter(gs.bullets, fn (b) ((b.y > -1000) and ((b.x < ws.width) and ((b.x > 0) and (b.y < ws.height)))) endfn)+ let gs.fragments = filter(gs.fragments, fn (fr) (fr.y < 2000) endfn)+ let gs.troopers = filter(gs.troopers, fn (t) (t.y < ws.height and not(t.destroyed)) endfn)+ return gs+endproc++proc makebullet(angle, v)+ return {color: [255, random(0, 255), random(0, 255)], v: {x: (cos(angle) * v), y: (sin(angle) * v)}, x: cannon.x, y: cannon.y}+endproc++proc drawcannon(cannon)+ setcolor(0, 255, 0)+ let c = cos((cannon.angle * -1))+ let s = sin((cannon.angle * -1))+ let half_base = 10+ let length = 100+ let center = [cannon.x, cannon.y]+ let top_left = [(cannon.x - 10), (cannon.y - 10)]+ let top_right = [(cannon.x + length), (cannon.y - 10)]+ let bottom_left = [(cannon.x - 10), (cannon.y + 10)]+ let bottom_right = [(cannon.x + length), (cannon.y + 10)]+ let top_left_rotated = rotate(top_left, center, s, c)+ lines([top_left_rotated, rotate(top_right, center, s, c), rotate(bottom_right, center, s, c), rotate(bottom_left, center, s, c), top_left_rotated])+endproc++proc rotate(cords, center, angle_sin, angle_cos)+ let tx = (cords[1] - center[1])+ let ty = (cords[2] - center[2])+ let newx = ((tx * angle_cos) - (ty * angle_sin))+ let newy = ((tx * angle_sin) + (ty * angle_cos))+ return [(newx + center[1]), (newy + center[2])]+endproc++proc drawworld(gs)+ setcolor(0, 0, 0)+ clearscreen()+ drawcannon(gs.cannon)+ for i = 1 to size(gs.bullets)+ setcolor(gs.bullets[i].color[1], gs.bullets[i].color[2], gs.bullets[i].color[3])+ -- point(gs.bullets[i].x, gs.bullets[i].y)+ box(gs.bullets[i].x, gs.bullets[i].y, 5, 5, true)+ endfor+ line(90645, 8067, 1056, 7045)+ setcolor(0, 244, 215, 44)+ for i = 1 to size(gs.helicopters)+ drawhelicopter(gs.helicopters[i], 1000)+ endfor+ foreach gs.troopers as trooper + drawtrooper(trooper)+ endforeach+ foreach gs.fragments as f + let c = (255 / f.age)+ setcolor(c, c, c)+ box(f.x, f.y, random(4, 25), random(4, 25), true)+ endforeach+ drawscreen()+endproc
+ samples/snake.spd view
@@ -0,0 +1,88 @@+graphicswindow(900, 900, true)+let headPos = { x : 100, y : 100}+let segmentCount = 5+let segments = makeSnake(headPos, segmentCount)+let snake =+ { segments: segments+ , direction : "right"+ }+let food = {x : random(0, 900), y : random(0, 900)}+loop+setcolor(0, 0, 0)+clearscreen()+setcolor(255, 0, 0)+drawSnake(snake)+drawfood(food)+let headpos = head(snake.segments)+if (haseaten(headpos, food))+ then let snake = growsnake(snake)+ let food = {x : random(0, 900), y: random(0, 900) }+endif+drawscreen()+let keys = getkeystate()+if inkeystate(keys, scancodes.q) then break endif+if inkeystate(keys, scancodes.down) then+ let snake.direction = "down"+endif+if inkeystate(keys, scancodes.up) then+ let snake.direction = "up"+endif+if inkeystate(keys, scancodes.left) then+ let snake.direction = "left"+endif+if inkeystate(keys, scancodes.right) then+ let snake.direction = "right"+endif+let snake = moveSnake(snake)+wait(0.02)+endloop++proc haseaten(headpos, food)+ let xdiff = headpos.x - food.x+ let ydiff = headpos.y - food.y+ return ((xdiff * xdiff) + (ydiff * ydiff)) < 100+endproc++proc moveSnake(snake)+ let nextHeadPos = snake.segments[1]+ let snakeLength = size(snake.segments)+ if snake.direction == "right" then+ let nextHeadPos.x = nextHeadPos.x + 8+ endif+ if snake.direction == "left" then+ let nextHeadPos.x = nextHeadPos.x - 8+ endif+ if snake.direction == "up" then+ let nextHeadPos.y = nextHeadPos.y - 8+ endif+ if snake.direction == "down" then+ let nextHeadPos.y = nextHeadPos.y + 8+ endif+ let snake.segments = [nextHeadPos] + take(snake.segments, snakeLength - 1)+ return snake+endproc++proc makeSnake(headPos, segmentCount)+ let segments = [headPos]+ for i = 1 to segmentCount+ let segments = segments + [{x : headPos.x - i*10, y: headPos.y}]+ endfor+ return segments+endproc++proc drawfood(food)+ setcolor(0, 200, 0)+ box(food.x, food.y, 8, 8)+endproc++proc growsnake(snake)+ let snake.segments = insertleft(head(moveSnake(snake).segments), snake.segments)+ return snake+endproc++proc drawSnake(snake)+ let segmentCount = size(snake.segments)+ for i = 1 to segmentCount+ box(snake.segments[i].x, snake.segments[i].y, 8, 8)+ endfor+endproc
spade.cabal view
@@ -1,11 +1,11 @@ cabal-version: 2.2 --- This file has been generated from package.yaml by hpack version 0.34.4.+-- This file has been generated from package.yaml by hpack version 0.34.6. -- -- see: https://github.com/sol/hpack name: spade-version: 0.1.0.2+version: 0.1.0.3 synopsis: A simple programming and debugging environment. description: A simple weakly typed, dynamic, interpreted programming langauge and terminal IDE. category: language, interpreter, ide@@ -37,6 +37,10 @@ docs/functions/string.md docs/functions/time.md stack.yaml+ stack.yaml.lock+ samples/mandelbrot.spd+ samples/paratrooper.spd+ samples/snake.spd library exposed-modules:@@ -72,6 +76,7 @@ Interpreter.Lib.Math Interpreter.Lib.Misc Interpreter.Lib.SDL+ Interpreter.Lib.String Parser Parser.Lib Parser.Parser@@ -90,6 +95,7 @@ UI.Widgets.MenuContainer UI.Widgets.NullWidget UI.Widgets.TextContainer+ UI.Widgets.TitledContainer UI.Widgets.WatchWidget other-modules: Paths_spade@@ -141,42 +147,37 @@ ViewPatterns PackageImports InstanceSigs+ ghc-options: -Wall -Wno-type-defaults build-depends:- Decimal- , WAVE- , aeson- , ansi-terminal+ Decimal >=0.5.2 && <0.6+ , WAVE >=0.1.6 && <0.2+ , aeson >=2.0.2 && <2.1+ , ansi-terminal >=0.11.1 && <0.12 , base >=4.9 && <5- , bytestring- , constraints- , containers- , exceptions- , file-embed- , hedgehog- , hex-text- , hspec- , hspec-hedgehog- , monad-loops- , mtl- , ordered-containers- , process- , random- , scientific- , sdl2- , sdl2-mixer- , stm- , template-haskell- , text- , time- , unordered-containers- , vector- , vty- if os(windows)- ghc-options: -optl-mwindows -optl-mconsole -Wall -Wno-type-defaults- build-depends:- Win32 >=2.10.0.1- else- ghc-options: -Wall -Wno-type-defaults+ , bytestring >=0.10.12 && <0.11+ , constraints >=0.13.2 && <0.14+ , containers >=0.6.4 && <0.7+ , exceptions >=0.10.4 && <0.11+ , file-embed >=0.0.15 && <0.1+ , hedgehog >=1.0.5 && <1.1+ , hex-text >=0.1.0 && <0.2+ , hspec >=2.9.4 && <2.10+ , hspec-hedgehog >=0.0.1 && <0.1+ , monad-loops >=0.4.3 && <0.5+ , mtl >=2.2.2 && <2.3+ , ordered-containers >=0.2.2 && <0.3+ , process >=1.6.11 && <1.7+ , random >=1.2.1 && <1.3+ , scientific >=0.3.7 && <0.4+ , sdl2 >=2.5.3 && <2.6+ , sdl2-mixer >=1.2.0 && <1.3+ , stm >=2.5.0 && <2.6+ , template-haskell >=2.17.0 && <2.18+ , terminal >=0.2.0 && <0.3+ , text >=1.2.4 && <1.3+ , time >=1.9.3 && <1.10+ , unordered-containers >=0.2.16 && <0.3+ , vector >=0.12.3 && <0.13 default-language: Haskell2010 autogen-modules: Paths_spade @@ -232,44 +233,38 @@ ViewPatterns PackageImports InstanceSigs- ghc-options: -threaded+ ghc-options: -Wall -Wno-type-defaults -threaded -fPIC build-depends:- Decimal- , WAVE- , aeson- , ansi-terminal+ Decimal >=0.5.2 && <0.6+ , WAVE >=0.1.6 && <0.2+ , aeson >=2.0.2 && <2.1+ , ansi-terminal >=0.11.1 && <0.12 , base >=4.9 && <5- , bytestring- , constraints- , containers- , exceptions- , file-embed- , hedgehog- , hex-text- , hspec- , hspec-hedgehog- , monad-loops- , mtl- , ordered-containers- , process- , random- , scientific- , sdl2- , sdl2-mixer+ , bytestring >=0.10.12 && <0.11+ , constraints >=0.13.2 && <0.14+ , containers >=0.6.4 && <0.7+ , exceptions >=0.10.4 && <0.11+ , file-embed >=0.0.15 && <0.1+ , hedgehog >=1.0.5 && <1.1+ , hex-text >=0.1.0 && <0.2+ , hspec >=2.9.4 && <2.10+ , hspec-hedgehog >=0.0.1 && <0.1+ , monad-loops >=0.4.3 && <0.5+ , mtl >=2.2.2 && <2.3+ , ordered-containers >=0.2.2 && <0.3+ , process >=1.6.11 && <1.7+ , random >=1.2.1 && <1.3+ , scientific >=0.3.7 && <0.4+ , sdl2 >=2.5.3 && <2.6+ , sdl2-mixer >=1.2.0 && <1.3 , spade- , stm- , template-haskell- , text- , time- , unordered-containers- , vector- , vty- if os(windows)- ghc-options: -optl-mwindows -optl-mconsole -Wall -Wno-type-defaults- build-depends:- Win32 >=2.10.0.1- else- ghc-options: -Wall -Wno-type-defaults+ , stm >=2.5.0 && <2.6+ , template-haskell >=2.17.0 && <2.18+ , terminal >=0.2.0 && <0.3+ , text >=1.2.4 && <1.3+ , time >=1.9.3 && <1.10+ , unordered-containers >=0.2.16 && <0.3+ , vector >=0.12.3 && <0.13 default-language: Haskell2010 autogen-modules: Paths_spade @@ -290,6 +285,8 @@ UI.EditorSpec UI.WidgetSpec Paths_spade+ autogen-modules:+ Paths_spade hs-source-dirs: test default-extensions:@@ -338,44 +335,39 @@ ViewPatterns PackageImports InstanceSigs+ ghc-options: -Wall -Wno-type-defaults build-depends:- Decimal- , WAVE- , aeson- , ansi-terminal+ Decimal >=0.5.2 && <0.6+ , WAVE >=0.1.6 && <0.2+ , aeson >=2.0.2 && <2.1+ , ansi-terminal >=0.11.1 && <0.12 , base >=4.9 && <5- , bytestring- , constraints- , containers- , exceptions- , file-embed+ , bytestring >=0.10.12 && <0.11+ , constraints >=0.13.2 && <0.14+ , containers >=0.6.4 && <0.7+ , exceptions >=0.10.4 && <0.11+ , file-embed >=0.0.15 && <0.1 , hedgehog- , hex-text+ , hex-text >=0.1.0 && <0.2 , hspec , hspec-discover , hspec-hedgehog- , monad-loops- , mtl+ , monad-loops >=0.4.3 && <0.5+ , mtl >=2.2.2 && <2.3 , neat-interpolation- , ordered-containers- , process- , random- , scientific- , sdl2- , sdl2-mixer+ , ordered-containers >=0.2.2 && <0.3+ , process >=1.6.11 && <1.7+ , random >=1.2.1 && <1.3+ , scientific >=0.3.7 && <0.4+ , sdl2 >=2.5.3 && <2.6+ , sdl2-mixer >=1.2.0 && <1.3 , spade- , stm+ , stm >=2.5.0 && <2.6 , strip-ansi-escape- , template-haskell- , text- , time- , unordered-containers- , vector- , vty- if os(windows)- ghc-options: -optl-mwindows -optl-mconsole -Wall -Wno-type-defaults- build-depends:- Win32 >=2.10.0.1- else- ghc-options: -Wall -Wno-type-defaults+ , template-haskell >=2.17.0 && <2.18+ , terminal >=0.2.0 && <0.3+ , text >=1.2.4 && <1.3+ , time >=1.9.3 && <1.10+ , unordered-containers >=0.2.16 && <0.3+ , vector >=0.12.3 && <0.13 default-language: Haskell2010
src/Common.hs view
@@ -32,11 +32,11 @@ , diH :: Int } deriving (Eq, Show) -amendHeight :: Dimensions -> (Int -> Int) -> Dimensions-amendHeight d fn = d { diH = fn $ diH d }+amendHeight :: (Int -> Int) -> Dimensions -> Dimensions+amendHeight fn d = d { diH = fn $ diH d } -amendWidth :: Dimensions -> (Int -> Int) -> Dimensions-amendWidth d fn = d { diW = fn $ diW d }+amendWidth :: (Int -> Int) -> Dimensions -> Dimensions+amendWidth fn d = d { diW = fn $ diW d } moveLeft :: Int -> ScreenPos -> ScreenPos moveLeft i d = d { sX = sX d - i }
src/Compiler/Lexer/Literals.hs view
@@ -33,7 +33,7 @@ instance ToSource Literal where toSource = \case LitBytes t -> "0x" <> (encodeHex t) <> ""- LitString t -> "\"" <> t <> "\""+ LitString t -> "\"" <> (escapeQuotes t) <> "\"" LitNumber n -> (T.pack $ show n) LitFloat n -> let o = T.pack $ show n in if T.isInfixOf "." o then o else o <> ".0"@@ -47,12 +47,27 @@ <|> intLiteralParser <|> boolLiteralParser +escapeQuotes :: Text -> Text+escapeQuotes = T.replace "\n" "\\n" . T.replace "\"" "\\\""+ strLiteralParser :: Parser Literal strLiteralParser = do void $ pChar '"'- c <- many (pAny (\c -> c /= '"'))+ c <- many parseEscapedChar void $ pChar '"' pure $ LitString (pack c)+ where+ parseEscapedChar :: Parser Char+ parseEscapedChar = ParserM "Escaped Char" (\s ->+ case T.uncons (twText s) of+ Just ('\\', rst) -> case T.uncons rst of+ Just ('n', rst') -> pure (Right '\n', TextWithOffset rst' (moveCols (twLocation s) 2))+ Just (h, rst') -> pure (Right h, TextWithOffset rst' (moveCols (twLocation s) 2))+ _ -> pure (Left CantHandle, s)+ Just ('"', _) -> pure (Left CantHandle, s)+ Just (c, rst') -> pure (Right c, TextWithOffset rst' (moveCols (twLocation s) 1))+ _ -> pure (Left CantHandle, s)+ ) hexLiteralParser :: Parser Literal hexLiteralParser = do
src/IDE/Common.hs view
@@ -23,8 +23,10 @@ | IDEEdit EditAction | IDEBeautify | IDEClearLog+ | IDEAppendLog Text | IDEStep+ | IDEShowAbout+ | IDEHideAbout | IDEDebugUpdate (Maybe DebugState) | IDERun deriving Show-
src/IDE/Help.hs view
@@ -26,7 +26,7 @@ import UI.Widgets.NullWidget newtype SearchPage = SearchPage Text- deriving Show+ deriving (Show, Eq) type HelpPage = Either SearchPage FilePath @@ -93,34 +93,49 @@ in newEw { ewScrollOffset = if newSo /= ewScrollOffset x then newSo + (div (diH $ ewDim newEw) 2) else newSo } ) case ke of- KeyCtrl _ _ _ Esc -> do+ KeyCtrl False False False Esc -> do case hwHistory w of- [] -> pure ()+ [] -> liftIO $ atomically $ writeTChan (hwIdeEventsChan w) IDEToggleHelp ((p, o) :rst) -> do modifyWRef r (\hw -> hw { hwHistory = rst }) loadPage' p o- KeyCtrl _ _ _ ArrowUp -> handleInput (hwContentWidget w) ke- KeyCtrl _ _ _ ArrowDown -> handleInput (hwContentWidget w) ke- KeyCtrl _ _ _ ArrowRight -> handleInput (hwContentWidget w) ke- KeyCtrl _ _ _ ArrowLeft -> handleInput (hwContentWidget w) ke- KeyCtrl _ _ _ Return -> do+ -- In the matches below don't insist that shift is not pressed+ -- so that shift+arrow key selections are possible.+ KeyCtrl False _ False ArrowUp -> handleInput (hwContentWidget w) ke+ KeyCtrl False _ False ArrowDown -> handleInput (hwContentWidget w) ke+ KeyCtrl False _ False ArrowRight -> handleInput (hwContentWidget w) ke+ KeyCtrl False _ False ArrowLeft -> handleInput (hwContentWidget w) ke+ KeyCtrl False False False Return -> do tokens <- liftIO $ readIORef (hwTokensRef w) case V.find (\case+ -- True in the first field signifies cursor is over this link DisplayToken (DTLink True _) _ _ -> True _ -> False) tokens of- Just (DisplayToken (DTLink _ n) _ _) -> case Map.lookup n (hwContentIndex w) of- Just (page, idx) -> do- pushCurrentPageToHistory- loadPage' (Right page) idx- Nothing -> pure ()+ Just (DisplayToken (DTLink _ n) _ _) -> do+ case Map.lookup n (hwContentIndex w) of+ Just (page, idx) -> do+ pushCurrentPageToHistory+ loadPage' (Right page) idx+ Nothing -> pure () _ -> pure () _ -> do- handleInput (hwSearchWidget w) ke- swr <- readWRef (hwSearchWidget w)- loadPage' (Left (SearchPage $ ewContent swr)) 0+ if hasKeyCombination ke+ -- This check prevents unintendend, redundant firing of search.+ -- which was causing a loaded page to immediately replaced by+ -- the search results that precedded the loading of this page.+ then pass+ else do+ handleInput (hwSearchWidget w) ke+ swr <- readWRef (hwSearchWidget w)+ let newPage = Left $ SearchPage $ ewContent swr+ loadPage' newPage 0 ew <- readWRef (hwContentWidget w) void $ liftIO $ tryPutMVar (hwCursorRef w) (ewCursor ew)+ where+ hasKeyCombination (KeyCtrl False False False _) = False+ hasKeyCombination (KeyChar False False False _) = False+ hasKeyCombination _ = True instance Moveable HelpWidget where move r pos = do@@ -184,7 +199,7 @@ loadTokens helpWidgetRef (contentText, dtTokens) = do HelpWidget { hwIdeEventsChan = ideEventRef, hwContentWidget = ewRef, hwTokensRef = tokensRef} <- readWRef helpWidgetRef liftIO $ writeIORef tokensRef dtTokens- modifyWRef ewRef (\ew -> ew { ewScrollOffset = 0, ewContent = contentText, ewShowVirtualCursor = True })+ modifyWRef ewRef (\ew -> (resetCursor ew) { ewContent = contentText, ewShowVirtualCursor = True }) liftIO $ atomically $ writeTChan ideEventRef IDEDraw collectLinks@@ -303,7 +318,7 @@ let builtinKeywords = (\x -> toSource $ toEnum @Keyword x) <$> [0 .. fromEnum $ maxBound @Keyword] let linksInDocs = Set.fromList $ collectLinks docs let linksInIndex = Set.fromList $ Map.keys docIndex- let builtinSymbols = Set.fromList builtins+ let builtinSymbols = Set.fromList (T.dropWhileEnd (\c -> c == '(' || c == ')') <$> builtins) let missingLinks = Set.difference linksInDocs linksInIndex let missingDocs = Set.difference (Set.difference builtinSymbols (Set.fromList (builtinKeywords <> builtinOperators))) linksInIndex if (Set.size(missingLinks) > 0)
src/IDE/IDE.hs view
@@ -1,12 +1,11 @@ module IDE.IDE where import Common+import Data.Text.Encoding (decodeUtf8) import Compiler.Lexer import Compiler.Parser import Control.Concurrent-import Control.Concurrent.STM (TChan, TVar, atomically, dupTChan, modifyTVar,- newTChan, newTChanIO, newTVarIO, readTChan,- readTVar, readTVarIO, writeTChan, writeTVar)+import Control.Concurrent.STM import Control.Exception import Control.Monad import Data.IORef@@ -16,33 +15,45 @@ import qualified Data.Set as S import Data.Text as T import Data.Text.IO as T+import System.Process (createPipe)+import qualified System.IO as SIO import Compiler.AST.Program import IDE.Common import IDE.Help import Interpreter import Interpreter.Common+import Interpreter.Lib.Misc import Interpreter.Initialize import Parser.Parser import UI.Widgets import UI.Widgets.AutoComplete import UI.Widgets.Layout+import UI.Widgets.TextContainer import UI.Widgets.LogWidget import UI.Widgets.WatchWidget+import UI.Widgets.TitledContainer +data IDEDebugEnv = IDEDebugEnv+ { ideDebugIn :: TBQueue DebugIn+ , ideDebugOut :: TBQueue DebugOut+ , ideDebugThreadInputR :: SIO.Handle+ , ideDebugThreadInputW :: SIO.Handle+ }+ data IDEState = IDEState- { idsDebugThreadId :: Maybe ThreadId- , idsDebugIn :: Maybe (MVar DebugIn)- , idsDebugOut :: Maybe (MVar DebugOut)- , idsDebugThreadInput :: Maybe (TChan TerminalEvent)+ { idsDebugEnv :: Maybe IDEDebugEnv , idsCodeAutocompletions :: [(Text, Text)] , idsCodeParseError :: Maybe (Location, Text) , idsKeyInputReciever :: Maybe SomeKeyInputWidget } ideStartState :: IDEState-ideStartState = IDEState Nothing Nothing Nothing Nothing [] Nothing Nothing+ideStartState = IDEState Nothing [] Nothing Nothing +resetIDEState :: IDEState -> IDEState+resetIDEState ids = ids { idsDebugEnv = Nothing, idsCodeParseError = Nothing, idsKeyInputReciever = Nothing }+ type Clipboard = (Text -> IO (), IO (Maybe Text)) type IDEM a = WidgetM IO a@@ -53,21 +64,24 @@ watchWidgetId :: Text watchWidgetId = "watch" +putStrLnFlush :: Text -> IO ()+putStrLnFlush s = do+ T.putStrLn s+ SIO.hFlush stdout+ extractBuiltIns :: IO ([(Text, Text)], [(Text, Text)]) extractBuiltIns = do- debugIn <- newEmptyMVar- debugOut <- newEmptyMVar sdlWindowsRef <- newIORef []- scope <- isGlobalScope . snd <$> runStateT loadBuiltIns (emptyIs sdlWindowsRef debugIn debugOut (error "Input stream not available"))+ scope <- isGlobalScope . snd <$> runStateT loadBuiltIns (emptyIs sdlWindowsRef) let keywords = (\x -> let s = toSource $ toEnum @Keyword x in (s, s)) <$> [0 .. fromEnum $ maxBound @Keyword] let builtIns = DL.foldl' extractOneDoc [] (Map.assocs scope)- pure $ (keywords, builtIns)+ pure (keywords, builtIns) where extractOneDoc :: [(Text, Text)] -> (ScopeKey, Value) -> [(Text, Text)] extractOneDoc in_ (SkIdentifier (unIdentifer ->ide), BuiltIn (BuiltinVal (ObjectValue m))) = in_ <> ((\k -> let a = ide <> "." <> k in (a, a)) <$> Map.keys m) extractOneDoc in_ (SkIdentifier ide, BuiltIn (BuiltinCallWithDoc s)) =- (unIdentifer ide, T.concat [+ (unIdentifer ide <> "()", T.concat [ unIdentifer ide, "(", T.intercalate ", " ((\(l, r) -> T.concat [l, ": ", r]) <$> extractDoc s),@@ -97,7 +111,7 @@ -- tokens and ast. And then fills some autocomplete suggestions and -- makes any parse error location. codeProcessingThread :: IORef [Token] -> TChan IDEEvent -> MVar Text -> IO ()-codeProcessingThread tokensRef ideEventRef editorContentRef = forever $ do+codeProcessingThread tokensRef ideEventRef editorContentRef = forever $ flip catch handler $ do liftIO $ atomically $ writeTChan ideEventRef IDEReqEditorContent code <- takeMVar editorContentRef tokens <- tokenize code@@ -110,6 +124,9 @@ liftIO $ atomically $ writeTChan ideEventRef $ IDEACUpdateIdentifiers $ S.toList $ S.fromList $ catMaybes $ filterIdentifiers <$> tokens wait 1 where+ handler :: SomeException -> IO ()+ handler e = liftIO $ atomically $ writeTChan ideEventRef $ IDEAppendLog (T.pack $ show e)+ filterIdentifiers :: Token -> Maybe Text filterIdentifiers Token { tkRaw = (TkIdentifier (unIdentifer -> idf))} = Just idf filterIdentifiers _ = Nothing@@ -118,21 +135,21 @@ -- need to be fed to the interpreted program, and not to the IDE. data InputRouting = RouteIDE- | RouteProgram (TChan TerminalEvent)+ | RouteProgram SIO.Handle instance Show InputRouting where- show RouteIDE = "Route To IDE"+ show RouteIDE = "Route To IDE" show (RouteProgram _) = "Route To Program" -runIDE :: FilePath -> TChan TerminalEvent -> IO ()-runIDE filePath inputBroadcastChan = do- dim <- getTerminalSize'+runIDE :: FilePath -> TChan TerminalEvent -> TMVar ThreadId -> IO ()+runIDE filePath inputChan interpreterThreadRef = do content <- try (T.readFile filePath) >>= \case Right c -> pure c Left (_ :: SomeException) -> pure "" (keywords, builtIns) <- extractBuiltIns ideStateRef <- newTVarIO ideStartState- ideEventsRef <- liftIO newTChanIO+ ideEventsRef <- newTChanIO+ atomically $ writeTChan ideEventsRef (IDEAppendLog ("Loaded file: " <> (T.pack filePath))) clipboardRef <- newIORef @(Maybe Text) Nothing let clipboard = (\t -> modifyIORef clipboardRef (\_ -> Just t), readIORef clipboardRef)@@ -144,124 +161,173 @@ inputRouteToRef <- newTVarIO RouteIDE - inputChan <- liftIO $ atomically $ dupTChan inputBroadcastChan- void $ liftIO $ forkIO $ forever $ do- (atomically $ readTVar inputRouteToRef) >>= appendLog- atomically $ do- kv <- readTChan inputChan- readTVar inputRouteToRef >>= \case- RouteIDE -> writeTChan ideEventsRef (IDETerminalEvent kv)- RouteProgram chan -> writeTChan chan kv+ kv <- atomically $ readTChan inputChan+ (atomically $ readTVar inputRouteToRef) >>= \case+ RouteIDE -> atomically $ writeTChan ideEventsRef (IDETerminalEvent kv)+ RouteProgram handle' -> pushTerminalEventToHandle handle' kv void $ runWidgetM $ do -- The editor- editorRef <- editor (getAutocompleteSuggestions ideStateRef (keywords <> ((\(a, b) -> (a <>"()", b)) <$> builtIns))) (Just $ SomeTokenStream (readIORef tokensRef))+ editorRef <- editor (getAutocompleteSuggestions ideStateRef (keywords <> builtIns)) (Just $ SomeTokenStream (readIORef tokensRef))+ modifyWRef editorRef (\ew' -> ew' { ewParams = (ewParams ew') { epLinenumberRightPad = 1, epBorder = False }}) setContent editorRef content liftIO $ atomically $ modifyTVar ideStateRef (\ids -> ids { idsKeyInputReciever = Just $ SomeKeyInputWidget editorRef }) -- Watch widget watchWidgetRef <- watchWidget+ titledWatchRef <- titledContainer (ScreenPos 0 0) (Dimensions 0 0) (SomeWidgetRef watchWidgetRef) " Watch " let dimensionDistributionFn = \case 1 -> [1] 2 -> [0.85, 0.15] 3 -> [0.70, 0.15, 0.15]+ 4 -> [0.55, 0.15, 0.15, 0.15] a -> error $ "Unsupported widget count:" <> show a - watchAndLogLayout <- layoutWidget Horizontal dimensionDistributionFn Nothing logRef <- logWidget- insertLog logRef "Welcome to S.P.A.D.E: The Simple Programming And Debugging Environment."- insertLog logRef "By Sandeep.C.R"- addWidget watchAndLogLayout "log" logRef- addWidget watchAndLogLayout watchWidgetId watchWidgetRef+ titledLogRef <- titledContainer (ScreenPos 0 0) (Dimensions 0 0) (SomeWidgetRef logRef) " Log " helpWidgetRef <- helpWidget ((Prelude.head . T.split (== '.'). fst) <$> builtIns) ideEventsRef -- The autocomplete widget ac <- autoComplete modifyWRef editorRef (\ed -> ed { ewAutocompleteWidget = Just $ SomeWidgetRef ac }) + -- The aboutbox widget+ aboutText <- textContainer (ScreenPos 0 0) (Dimensions 58 12)+ let 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"+ <> " 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)+ setVisibility aboutBox False+ -- The Outermost layout layoutRef <- layoutWidget Vertical dimensionDistributionFn (Just $ SomeKeyInputWidget editorRef)- modifyWRef layoutRef (\lw -> lw { lowFloatingContent = Just $ SomeWidgetRef ac })+ modifyWRef layoutRef (\lw -> lw { lowFloatingContent = [SomeWidgetRef ac, SomeWidgetRef aboutBox] }) addWidget layoutRef editorId editorRef addWidget layoutRef "helpwidget" helpWidgetRef- addWidget layoutRef "watchandlog" watchAndLogLayout+ addWidget layoutRef "watch" titledWatchRef+ addWidget layoutRef "log" titledLogRef 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 (Ctrl+F8)"])+ , ("Run", SubMenu ["Run (F5)", "Step (F8)"]) , ("Windows", SubMenu ["Clear log"])- , ("Help", SubMenu ["Contents"])- ] Nothing+ , ("Help", SubMenu ["About", "Contents"])+ ] Nothing (Just $ T.pack filePath) menuContainerRef <- menuContainer (SomeWidgetRef layoutRef) menu (selectionHandler ideEventsRef) - modifyWRef menuContainerRef (\mc -> mc { mcwDim = dim })- modify (\ws -> ws { wsCursorWidget = Just $ SomeKeyInputWidget editorRef }) - -- Initial screen paint- csInitialize dim- draw menuContainerRef- csDraw- -- A snippet that refresh the screen.- let ideRedraw = do++ let+ ideRedraw :: WidgetC m => m ()+ ideRedraw = do csClear draw menuContainerRef csDraw - let getActiveEditor = do+ let+ getActiveEditor :: WidgetC m => m (WRef EditorWidget)+ getActiveEditor = do (getVisibility editorRef) >>= \case True -> pure editorRef _ -> getVisibility helpWidgetRef >>= \case True -> hwContentWidget <$> (readWRef helpWidgetRef) _ -> error "No visible editor" let+ launchProgram+ :: forall m. WidgetC m+ => m (Either Text IDEDebugEnv) launchProgram = do source <- getContent editorRef- liftIO (compileEither source >>= \case+ liftIO $ do+ compileEither source >>= \case Right p -> do- debugIn <- newEmptyMVar- debugOut <- newEmptyMVar- programInputChan <- liftIO $ atomically newTChan- threadId <- forkOS (void $ do- liftIO $ atomically $ do- writeTVar inputRouteToRef (RouteProgram programInputChan)- interpret debugIn debugOut programInputChan p)- atomically $- modifyTVar ideStateRef- (\idestate ->- idestate- { idsDebugThreadId = Just threadId- , idsDebugIn = Just debugIn- , idsDebugOut = Just debugOut- , idsDebugThreadInput = Just programInputChan- })- pure $ Right (threadId, debugIn, debugOut, programInputChan)+ debugIn <- atomically (newTBQueue 10)+ debugOut <- atomically (newTBQueue 10)+ let+ handler :: SomeException -> IO ()+ handler e = do+ atomically (writeTBQueue debugOut (Errored (T.pack $ show e)))+ (programInputHandleR, programInputHandleW) <- liftIO createPipe+ let ideDebugEnv = IDEDebugEnv debugIn debugOut programInputHandleR programInputHandleW+ osThreadId <- forkOS $ do++ startMode <- atomically $ do+ -- Initialize IDE debuggins state+ dIn <- readTBQueue debugIn+ check (dIn == Start || dIn == StartStep) -- Wait till the Start command+ pure dIn+ let+ stateFn = case startMode of+ StartStep -> (\is -> is+ { isInputHandle = programInputHandleR+ , isRunMode = DebugMode $ DebugEnv SingleStep debugIn debugOut+ })+ Start -> (\is -> is+ { isRunMode = NormalMode (Just $ DebugEnv SingleStep debugIn debugOut)+ , isInputHandle = programInputHandleR+ })+ _ -> error "Impossible!"++ flip catch handler (void $ do+ void $ interpret stateFn p+ atomically (writeTBQueue debugOut (Finished False))+ )+ -- Reset IDE debuggins state+ void $ atomically $ do+ readTBQueue debugIn >>= (check . (== Stop)) -- Wait till the stop command++ modifyTVar ideStateRef+ (\idestate ->+ idestate+ { idsDebugEnv = Nothing+ })+++ atomically $ putTMVar interpreterThreadRef osThreadId+ pure $ Right ideDebugEnv Left err -> do pure $ Left (hReadable err)- ) uiLoop ideEventsRef (\case+ IDEShowAbout -> do+ mc <- readWRef menuContainerRef+ setVisibility aboutBox True+ adim <- getDim aboutBox+ move aboutBox (ScreenPos ((div (diW $ mcwDim mc) 2) - (div (diW adim) 2)) 20)+ ideRedraw+ pure True+ IDEHideAbout -> do+ setVisibility aboutBox False+ ideRedraw+ pure True IDEToggleHelp -> do getVisibility helpWidgetRef >>= \case True -> do setVisibility helpWidgetRef False setVisibility editorRef True- setVisibility watchAndLogLayout True+ setVisibility watchWidgetRef True modify (\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 watchAndLogLayout False+ setVisibility watchWidgetRef False modify (\ws -> ws { wsCursorWidget = Just $ SomeKeyInputWidget helpWidgetRef }) liftIO $ atomically (modifyTVar ideStateRef (\is -> is { idsKeyInputReciever = Just $ SomeKeyInputWidget helpWidgetRef })) d <- getScreenBounds@@ -316,8 +382,11 @@ ideRedraw pure True IDEClearLog -> do- modifyWRef logRef (\lw -> lw { lwContent = [], lwScrollOffset = 0 })+ modifyWRef logRef (\lw -> lw { lwContent = [] }) pure True+ IDEAppendLog msg -> do+ insertLog logRef msg+ pure True IDEBeautify -> do insertLog logRef "Formatting..." code <- getContent editorRef@@ -351,66 +420,109 @@ IDEExit -> do pure False IDERun -> do- (\x' -> (idsDebugThreadId x', idsDebugIn x', idsDebugOut x', idsDebugThreadInput x')) <$> liftIO (readTVarIO ideStateRef) >>= \case+ idsDebugEnv <$> liftIO (readTVarIO ideStateRef) >>= \case -- If we are in a debug session, just run to completion.- (Just threadId, Just debugIn, Just debugOut, Just programInputChan) -> do+ (Just ideDebugEnv) -> do insertLog logRef "Continuing debug session to end..."- executeAndUpdateIDEDebugState inputRouteToRef logRef editorRef ideEventsRef ideStateRef (Just Run) threadId debugIn debugOut programInputChan+ liftIO $ atomically $ do+ writeTBQueue (ideDebugIn ideDebugEnv) Run+ writeTVar inputRouteToRef (RouteProgram $ ideDebugThreadInputW ideDebugEnv)+ waitTill (\_ -> True) (ideDebugOut ideDebugEnv) >>=+ processDebugOut ideEventsRef ideStateRef logRef editorRef (ideDebugIn ideDebugEnv)+ liftIO $ atomically $ do+ writeTChan ideEventsRef IDEDraw+ writeTVar inputRouteToRef RouteIDE _ -> do -- Or else launch a new run of the program. clearscreen setCursorPosition 0 0 launchProgram >>= \case- Right (threadId, debugIn, debugOut, programInputChan) -> do+ Right ideDebugEnv -> do insertLog logRef "Starting..."- executeAndUpdateIDEDebugState inputRouteToRef logRef editorRef ideEventsRef ideStateRef (Just Run) threadId debugIn debugOut programInputChan+ liftIO $ atomically $ do+ writeTBQueue (ideDebugIn ideDebugEnv) Start+ writeTVar inputRouteToRef (RouteProgram $ ideDebugThreadInputW ideDebugEnv)++ waitTill (\_ -> True) (ideDebugOut ideDebugEnv) >>=+ processDebugOut ideEventsRef ideStateRef logRef editorRef (ideDebugIn ideDebugEnv)+ liftIO $ atomically $ do+ writeTChan ideEventsRef IDEDraw+ writeTVar inputRouteToRef RouteIDE Left err -> do insertLog logRef $ "Compile Error:" <> err liftIO $ atomically $ writeTChan ideEventsRef IDEDraw pure True IDEStep -> do csSetCursorPosition 0 0- (\x' -> (idsDebugThreadId x', idsDebugIn x', idsDebugOut x', idsDebugThreadInput x')) <$> liftIO (readTVarIO ideStateRef) >>= \case+ idsDebugEnv <$> liftIO (readTVarIO ideStateRef) >>= \case -- A debugging session exists already. -- Send the step command, wait for updated state to arrive.- (Just threadId, Just debugIn, Just debugOut, Just programInputChan) ->- executeAndUpdateIDEDebugState inputRouteToRef logRef editorRef ideEventsRef ideStateRef (Just StepIn) threadId debugIn debugOut programInputChan+ (Just ideDebugEnv) -> do+ -- Get current interpreter statement location+ (liftIO $ atomically $ tryReadTBQueue (ideDebugOut ideDebugEnv)) >>= \case+ Just debugOut -> do+ processDebugOut ideEventsRef ideStateRef logRef editorRef (ideDebugIn ideDebugEnv) debugOut+ Nothing -> pass+ liftIO $ atomically $ do+ writeTBQueue (ideDebugIn ideDebugEnv) StepIn+ writeTVar inputRouteToRef (RouteProgram $ ideDebugThreadInputW ideDebugEnv)+ -- Wait till the interpreter moves to the next location+ (liftIO $ atomically $ readTBQueue (ideDebugOut ideDebugEnv)) >>=+ processDebugOut ideEventsRef ideStateRef logRef editorRef (ideDebugIn ideDebugEnv)+ liftIO $ atomically $ do+ writeTVar inputRouteToRef RouteIDE+ _ -> do -- No debugging session exist. Launch one. launchProgram >>= \case- Right (threadId, debugIn, debugOut, programInputChan) -> do- insertLog logRef "Starting..."- executeAndUpdateIDEDebugState inputRouteToRef logRef editorRef ideEventsRef ideStateRef Nothing threadId debugIn debugOut programInputChan+ Right ideDebugEnv -> do+ liftIO $ atomically $ do+ writeTBQueue (ideDebugIn ideDebugEnv) StartStep+ writeTBQueue (ideDebugIn ideDebugEnv) StepIn+ writeTVar inputRouteToRef (RouteProgram $ ideDebugThreadInputW ideDebugEnv)++ -- Wait till the interpreter moves to the first location+ (liftIO $ atomically $ readTBQueue (ideDebugOut ideDebugEnv)) >>=+ processDebugOut ideEventsRef ideStateRef logRef editorRef (ideDebugIn ideDebugEnv)++ liftIO $ atomically $ do+ writeTVar inputRouteToRef RouteIDE+ Left err -> insertLog logRef $ "Compile Error:" <> err pure True- IDETerminalEvent (TerminalResize w h) -> do- let dim' = Dimensions w h- csInitialize dim'- modifyWRef menuContainerRef (\mc -> mc { mcwDim = dim' })- draw menuContainerRef- adjustScrollOffset editorRef- draw menuContainerRef- csDraw- pure True IDEDebugUpdate mds -> do case mds of Just ds -> do- modifyWRef editorRef (\ew -> ew { ewReadOnly = True, ewDebugLocation = Just $ dsLocation ds, ewCursor = lcOffset (dsLocation ds) - 1 })- modifyWRef watchWidgetRef (\ww -> ww { wwVisible = True, wwContent = scopeToWatchItems $ dsScope ds })+ items <- liftIO $ scopeToWatchItems $ dsScope ds+ modifyWRef editorRef (\ew -> putCursor Nothing (lcOffset (dsLocation ds)) $ ew { ewReadOnly = True, ewDebugLocation = Just $ dsLocation ds })+ modifyWRef titledWatchRef (\twr -> setTitle twr $ wrapInSpace ("Watching Thread: " <> dsThreadName ds))+ setVisibility titledWatchRef True+ modifyWRef watchWidgetRef (\ww -> ww { wwVisible = True, wwContent = items }) case dsCurrenEvaluation ds of Just cv -> insertLog logRef ("Evaluating: " <> cv) Nothing -> pass Nothing -> do+ modifyWRef titledWatchRef (\twr -> setTitle twr "Watch") modifyWRef editorRef (\ew -> ew { ewReadOnly = False, ewDebugLocation = Nothing })- modifyWRef watchWidgetRef (\ww -> ww { wwVisible = False })+ setVisibility titledWatchRef False liftIO $ atomically $ writeTChan ideEventsRef IDEDraw pure True+ IDETerminalEvent TerminalInterrupt -> pure False+ IDETerminalEvent (TerminalResize w h) -> do+ let dim' = Dimensions w h+ csInitialize dim'+ modifyWRef menuContainerRef (\mc -> mc { mcwDim = dim' })+ draw menuContainerRef+ adjustScrollOffset editorRef+ draw menuContainerRef+ csDraw+ pure True IDETerminalEvent (TerminalKey ev) -> case ev of KeyChar True _ _ 'c' -> pure False KeyChar True _ _ 'C' -> pure False k -> do- updateMenuOnKey menuContainerRef k >>= \case+ updateMenuOnKey ideEventsRef menuContainerRef k >>= \case True -> pure () False -> shortcutsHandler ideEventsRef k >>= \case True -> pure ()@@ -424,53 +536,60 @@ ideRedraw pure True )+ clearscreen+ setCursorPosition 0 0 where- executeAndUpdateIDEDebugState inputRouteToRef logRef editorRef ideEventRef ideStateRef mcmd threadId debugIn debugOut programInputChan = do- case mcmd of- Just cmd -> do- liftIO $ do- -- Empty out any pending debug message, and discard it.- void $ tryTakeMVar debugOut- -- before sending in a debug input.- atomically $ writeTVar inputRouteToRef (RouteProgram programInputChan)- putMVar debugIn cmd- _ -> pure ()- (liftIO (catch (do- dd <- takeMVar debugOut- atomically $ writeTVar inputRouteToRef RouteIDE- pure dd- )- -- Possibly handle a control-c triggered by user to break- -- a long runing operation.- (\(e :: SomeException) -> do- killThread threadId- pure $ Errored $ T.pack $ show e- )- )) >>= \case- -- Update the IDE debug state with the received debug state.- DebugData ds -> do- liftIO $ atomically $ writeTChan ideEventRef (IDEDebugUpdate $ Just ds)- Errored err -> do- liftIO $ atomically $ modifyTVar ideStateRef (\i -> ideStartState { idsKeyInputReciever = idsKeyInputReciever i })- modifyWRef editorRef (\ew -> ew { ewReadOnly = False })- insertLog logRef err- liftIO $ atomically $ do- writeTChan ideEventRef (IDEDebugUpdate Nothing)- Finished -> do- modifyWRef editorRef (\ew -> ew { ewReadOnly = False })- liftIO $ atomically $ modifyTVar ideStateRef (\i -> ideStartState { idsKeyInputReciever = idsKeyInputReciever i })- insertLog logRef "Finished program"- liftIO $ atomically $ do- writeTChan ideEventRef (IDEDebugUpdate Nothing) -updateMenuOnKey :: WidgetC m => WRef MenuContainerWidget -> KeyEvent -> m Bool-updateMenuOnKey ref kv = do+ waitTill+ :: MonadIO m+ => (DebugOut -> Bool)+ -> TBQueue DebugOut+ -> m DebugOut+ waitTill pred_ debugOut = do+ (liftIO $ atomically $ readTBQueue debugOut) >>= \case+ a@(pred_ -> True) -> pure a+ _ -> waitTill pred_ debugOut++ processDebugOut+ :: forall m. (HasCallStack, WidgetC m)+ => TChan IDEEvent+ -> TVar IDEState+ -> WRef LogWidget+ -> WRef EditorWidget+ -> TBQueue DebugIn+ -> DebugOut+ -> m ()+ processDebugOut ideEventRef ideStateRef logRef editorRef debugIn dout = do+ case dout of+ -- Update the IDE debug state with the received debug state.+ DebugData ds -> do+ liftIO $ atomically $ writeTChan ideEventRef (IDEDebugUpdate $ Just ds)+ Errored err -> do+ liftIO $ atomically $ modifyTVar ideStateRef (\i -> (resetIDEState i) { idsKeyInputReciever = idsKeyInputReciever i })+ modifyWRef editorRef (\ew -> ew { ewReadOnly = False })+ insertLog logRef err+ liftIO $ atomically $ do+ writeTBQueue debugIn Stop+ writeTChan ideEventRef (IDEDebugUpdate Nothing)+ Finished isUserInterrupt -> do+ modifyWRef editorRef (\ew -> ew { ewReadOnly = False })+ liftIO $ atomically $ modifyTVar ideStateRef (\i -> (resetIDEState i) { idsKeyInputReciever = idsKeyInputReciever i })+ insertLog logRef (if isUserInterrupt then "User Interrupt" else "Finished program")+ liftIO $ atomically $ do+ writeTBQueue debugIn Stop+ writeTChan ideEventRef (IDEDebugUpdate Nothing)++updateMenuOnKey :: WidgetC m => TChan IDEEvent -> WRef MenuContainerWidget -> KeyEvent -> m Bool+updateMenuOnKey ideEventsRef ref kv = do w <- readWRef ref case (kv, menuActive $ mcwMenu w) of (KeyCtrl _ _ _ Esc, Just _) -> do modifyWRef ref (\w' -> w' { mcwMenu = (mcwMenu w) { menuActive = Nothing }}) setCursorVisibility True pure True+ (KeyCtrl _ _ _ Esc, _) -> do+ liftIO $ atomically $ writeTChan ideEventsRef IDEHideAbout+ pure False -- Let Esc key bubble (KeyChar _ _ True c, _) -> do foldM_ (\x (n, _) -> case T.uncons (T.toLower n) of Nothing -> pure $ x + 1@@ -531,25 +650,23 @@ pure True _ -> pure False -scopeToWatchItems :: Scope -> [(Text, Text)]-scopeToWatchItems s = Map.foldlWithKey' (\o k v ->+scopeToWatchItems :: Scope -> IO [(Text, Text)]+scopeToWatchItems s = foldM (\o (k, v) -> do let vKey = case k of SkIdentifier i -> unIdentifer i SkOperator op -> T.pack $ show op- vText = case v of- StringValue t -> Just t- NumberValue (NumberInt t) -> Just $ T.pack $ show t- NumberValue (NumberFractional t) -> Just $ T.pack $ show t- BoolValue t -> Just $ T.pack $ show t- ArrayValue t -> Just $ T.pack $ show t- ObjectValue t -> Just $ T.pack $ show t- _ -> Nothing+ vText <- case v of+ ErrorValue t -> pure $ Just $ "Error: " <> t+ v' ->+ catch (fst <$> (runInterpretM dummyIS ((Just . decodeUtf8) <$> serializeJSON v'))) (\case+ UnserializeableValue -> pure Nothing+ e -> pure $ Just $ "Error: " <> (T.pack $ show e)) - in case vText of- Just t -> (vKey, t) : o- Nothing -> o- ) [] s+ case vText of+ Just t -> pure $ (vKey, t) : o+ Nothing -> pure o+ ) [] (Map.assocs s) selectionHandler :: forall m. WidgetC m@@ -569,7 +686,8 @@ (2, 0) -> liftIO $ atomically $ writeTChan ideEventsRef IDERun (2, 1) -> liftIO $ atomically $ writeTChan ideEventsRef IDEStep (3, 0) -> liftIO $ atomically $ writeTChan ideEventsRef IDEClearLog- (4, 0) -> liftIO $ atomically $ writeTChan ideEventsRef IDEToggleHelp+ (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@@ -589,7 +707,7 @@ liftIO $ atomically $ writeTChan ideEventRef IDEToggleHelp pure True - KeyCtrl True _ _ (Fun 8) -> do+ KeyCtrl _ _ _ (Fun 8) -> do liftIO $ atomically $ writeTChan ideEventRef IDEStep pure True
src/Interpreter.hs view
@@ -2,14 +2,10 @@ import Prelude hiding (map) -import Control.Concurrent.MVar-import Control.Exception (SomeException, displayException)-import Control.Concurrent.STM import Control.Monad-import Control.Monad.Catch (catch)+import Control.Monad.Catch (finally) import Data.IORef (newIORef) import Data.Map as M hiding (map)-import Data.Text as T hiding (index, map) import Compiler.AST.Program import Control.Monad.State.Strict@@ -17,33 +13,16 @@ import Interpreter.Initialize import Interpreter.Interpreter import Interpreter.Lib.SDL-import UI.Widgets.Common -interpret_ :: TChan TerminalEvent -> Program -> IO InterpreterState-interpret_ teventChan prg = do- debugIn <- newEmptyMVar- debugOut <- newEmptyMVar- sdlWindowsRef <- newIORef []- let istate = emptyIs sdlWindowsRef debugIn debugOut teventChan- interpret' (istate { isRunMode = NormalMode }) prg--interpret :: MVar DebugIn -> MVar DebugOut -> TChan TerminalEvent -> Program -> IO InterpreterState-interpret debugIn debugOut teventsChan prg = do+interpret :: (InterpreterState -> InterpreterState) -> Program -> IO InterpreterState+interpret stFn prg = snd <$> do sdlWindowsRef <- newIORef []- interpret' (emptyIs sdlWindowsRef debugIn debugOut teventsChan) prg--interpret' :: InterpreterState -> Program -> IO InterpreterState-interpret' istate prg = snd <$> do- let debugOut = isDebugOut istate- flip runStateT istate $ catch (do+ let istate = emptyIs sdlWindowsRef+ flip runStateT (stFn istate) $ (do loadBuiltIns interpretPassOne prg interpretPassTwo prg- cleanupSDL- liftIO $ putMVar debugOut Finished- ) (\(e :: SomeException) -> do- cleanupSDL- liftIO $ putMVar debugOut (Errored $ T.pack $ displayException e))+ ) `finally` cleanupSDL interpretPassOne :: Program -> InterpretM () interpretPassOne x = mapM_ (\a -> fn a) x
src/Interpreter/Common.hs view
@@ -1,6 +1,7 @@ module Interpreter.Common where import Control.Concurrent+import Control.Concurrent.STM.TBQueue import Control.Concurrent.STM.TChan import Control.Concurrent.STM.TMVar import Control.Exception@@ -13,20 +14,22 @@ import Data.Maybe (isJust) import Data.Proxy import Data.Text as T+import Data.Text.IO as T import qualified Data.Vector as V import qualified Data.Vector.Storable as VS import Data.Word import Foreign.C.Types import GHC.OverloadedLabels import GHC.TypeLits-import SDL hiding (Keycode, Scancode)+import SDL hiding (Keycode, Scancode, get) import qualified SDL as SDL import qualified SDL.Mixer as SDLM+import qualified System.IO as SIO import Common-import UI.Widgets.Common import Compiler.AST.Program import Compiler.Lexer+import UI.Widgets.Common audioSampleCount :: Int audioSampleCount = 44100@@ -94,7 +97,7 @@ compare (NumberInt x) (NumberFractional y) = compare (realToFrac x) y compare (NumberFractional x) (NumberInt y) = compare x (realToFrac y) -data UnNamedFn = UnNamedFn (Maybe (NonEmpty Identifier)) ExpressionWithLoc+data UnNamedFn = UnNamedFn (Maybe (NonEmpty Identifier)) Scope ExpressionWithLoc deriving Show data ThreadInfo = ThreadInfo ThreadId (TMVar (Either SomeException Value))@@ -127,6 +130,8 @@ | Channel ChannelRef | Ref MutableRef | ErrorValue Text+ -- ^ This should probably never be used directly, and should throw a CustomRTE instead+ -- so that it will be caught and rethrown with location information. | Void deriving Show @@ -147,12 +152,12 @@ (ArrayValue t) == (ArrayValue v) = t == v (ObjectValue t) == (ObjectValue v) = t == v (SDLValue (Keycode kc1)) == (SDLValue (Keycode kc2)) = kc1 == kc2- (ProcedureValue _) == _ = error "Procedures cannot be compared"- _ == (ProcedureValue _) = error "Procedures cannot be compared"- (BuiltIn _) == _ = error "Procedures cannot be compared"- _ == (BuiltIn _) = error "Procedures cannot be compared"- Void == _ = error "Void cannot be compared"- _ == Void = error "Void cannot be compared"+ (ProcedureValue _) == _ = error "cannot be compared"+ _ == (ProcedureValue _) = error "cannot be compared"+ (BuiltIn _) == _ = error "cannot be compared"+ _ == (BuiltIn _) = error "cannot be compared"+ Void == _ = error "cannot be compared"+ _ == Void = error "cannot be compared" _ == _ = False data ScopeKey@@ -167,16 +172,17 @@ type Scope = Map ScopeKey Value data RunMode- = NormalMode- | DebugMode+ = NormalMode (Maybe DebugEnv)+ | DebugMode DebugEnv deriving Show data DebugIn- = AddWatch Text- | StepIn- | StepOver+ = StepIn | Run- deriving Show+ | Start -- Start stepping through the program+ | StartStep -- Start stepping through the program+ | Stop -- Exit the stepping thread+ deriving (Show, Eq) data StepMode = SingleStep@@ -187,35 +193,97 @@ { dsScope :: Scope , dsLocation :: Location , dsCurrenEvaluation :: Maybe Text- } deriving Show+ , dsThreadName :: Text+ } deriving (Show, Eq) data DebugOut- = Finished+ = Finished Bool | Errored Text | DebugData DebugState- deriving Show+ deriving (Show, Eq) +data DebugEnv = DebugEnv+ { deStepMode :: StepMode+ , deInQueue :: TBQueue DebugIn+ , deOutQueue :: TBQueue DebugOut+ }++instance Show DebugEnv where+ show _ = "{DebugEnv}"+ data InterpreterState = InterpreterState- { isLocal :: [Scope]- , isRunMode :: RunMode- , isGlobalScope :: Scope- , isDefaultRenderer :: Maybe SDL.Renderer- , isAccelerated :: Maybe Bool- , isDefaultWindow :: Maybe SDL.Window- , isSDLWindows :: IORef [SDL.Window] -- We need these to cleanup any SDL windows after an exception.- , isDebugIn :: MVar DebugIn- , isDebugOut :: MVar DebugOut- , isStepMode :: StepMode- , isThreadId :: Maybe ThreadId- , isTerminalEventChan :: TChan TerminalEvent+ { isLocal :: [Scope]+ , isRunMode :: RunMode+ , isGlobalScope :: Scope+ , isDefaultRenderer :: Maybe SDL.Renderer+ , isAccelerated :: Maybe Bool+ , isDefaultWindow :: Maybe SDL.Window+ , isSDLWindows :: IORef [SDL.Window] -- We need these to cleanup any SDL windows after an exception.+ , isInputHandle :: SIO.Handle+ , isOutputHandle :: SIO.Handle+ , isThreadName :: Text } instance Show InterpreterState where show InterpreterState {..} = show (isJust isDefaultWindow) -emptyIs :: IORef [SDL.Window] -> MVar DebugIn -> MVar DebugOut -> TChan TerminalEvent -> InterpreterState-emptyIs sdlWindowsRef din dout inputChan = InterpreterState mempty DebugMode mempty Nothing Nothing Nothing sdlWindowsRef din dout SingleStep Nothing inputChan+dummyIS :: InterpreterState+dummyIS = InterpreterState+ { isLocal = mempty+ , isRunMode = NormalMode Nothing+ , isGlobalScope = mempty+ , isDefaultRenderer = Nothing+ , isAccelerated = Nothing+ , isDefaultWindow = Nothing+ , isSDLWindows = error "Unavailable"+ , isInputHandle = SIO.stdin+ , isOutputHandle = SIO.stdout+ , isThreadName = "MAIN"+ } +emptyIs :: IORef [SDL.Window] -> InterpreterState+emptyIs sdlWindowsRef = InterpreterState+ { isLocal = mempty+ , isRunMode = NormalMode Nothing+ , isGlobalScope = mempty+ , isDefaultRenderer = Nothing+ , isAccelerated = Nothing+ , isDefaultWindow = Nothing+ , isSDLWindows = sdlWindowsRef+ , isInputHandle = SIO.stdin+ , isOutputHandle = SIO.stdout+ , isThreadName = "MAIN"+ }++interpreterOutput :: Text -> InterpretM ()+interpreterOutput c = isOutputHandle <$> get >>= (liftIO . flip T.hPutStr c)++interpreterOutputFlush :: InterpretM ()+interpreterOutputFlush = isOutputHandle <$> get >>= (liftIO . SIO.hFlush)++interpreterInputChar :: InterpretM Char+interpreterInputChar = isInputHandle <$> get >>= (liftIO . SIO.hGetChar)++interpreterInput :: InterpretM Text+interpreterInput = isInputHandle <$> get >>= (liftIO . T.hGetContents)++readInterpreterInputLine :: InterpretM Text+readInterpreterInputLine = readInput ""+ where+ readInput ti = do+ c <- interpreterInputChar+ case c of+ '\n' -> pure $ T.reverse $ T.pack ti+ '\ESC' -> do+ interpreterOutput "\nInput cancelled, please try again: "+ interpreterOutputFlush+ readInput ""+ '\BS' -> readInput ti+ _ -> do+ interpreterOutput (T.singleton c)+ interpreterOutputFlush+ readInput (c:ti)+ mapLocal :: ([Scope] -> [Scope]) -> (InterpreterState -> InterpreterState) mapLocal fn = \is -> is { isLocal = fn $ isLocal is } @@ -224,6 +292,9 @@ type InterpretM a = forall m. (MonadCatch m, MonadIO m) => StateT InterpreterState m a +runInterpretM :: (MonadCatch m, MonadIO m) => InterpreterState -> InterpretM a -> m (a, InterpreterState)+runInterpretM istate act = flip runStateT (istate) act+ instance {-# OVERLAPPING #-} (MonadCatch m, MonadIO m) => MonadIO (StateT InterpreterState m) where liftIO act = lift $ liftIO @m (wrapSomeException IOError act) @@ -258,9 +329,15 @@ fromValue (StringValue t) = BTText t fromValue (BytesValue t) = BTBytes t fromValue a = throwErr $ UnexpectedType ("filepath", a)- typeName = "filepath"+ typeName = "bytes_or_text" -instance FromValue FilePath where+instance FromValue TextOrList where+ fromValue (StringValue t) = TCText t+ fromValue (ArrayValue t) = TCList t+ fromValue a = throwErr $ UnexpectedType ("text_or_list", a)+ typeName = "text_or_list"++instance {-# OVERLAPPING #-} FromValue FilePath where fromValue (StringValue t) = T.unpack t fromValue a = throwErr $ UnexpectedType ("filepath", a) typeName = "filepath"@@ -298,6 +375,8 @@ class FromValue a where fromValue :: Value -> a+ fromError :: Text -> a+ fromError err = throwErr $ CustomRTE err typeName :: Text instance FromValue SDL.Keycode where@@ -337,6 +416,11 @@ fromValue a = throwErr $ UnexpectedType ("number", a) typeName = "list of " <> (typeName @a) +instance FromValue a => FromValue [a] where+ fromValue (ArrayValue v) = V.toList $ V.map fromValue v+ fromValue a = throwErr $ UnexpectedType ("number", a)+ typeName = "list of " <> (typeName @a)+ instance FromValue Number where fromValue (NumberValue i) = i fromValue a = throwErr $ UnexpectedType ("number", a)@@ -364,13 +448,10 @@ fromValue a = throwErr $ UnexpectedType ("list", a) typeName = "list" -instance FromValue (V.Vector (Number, Number)) where- fromValue (ArrayValue v) = V.map fn v- where- fn (ArrayValue (V.toList -> ((NumberValue idx0) : (NumberValue idx1) : _))) = (idx0, idx1)- fn a = throwErr $ UnexpectedType ("list with two values", a)- fromValue a = throwErr $ UnexpectedType ("list", a)- typeName = "list"+instance FromValue (Number, Number) where+ typeName = "tuple"+ fromValue (ArrayValue (V.toList -> ((NumberValue idx0) : (NumberValue idx1) : _))) = (idx0, idx1)+ fromValue a = throwErr $ UnexpectedType ("list with two values", a) instance FromValue Word8 where fromValue = \case@@ -413,9 +494,16 @@ instance (KnownSymbol n, FromValue t, KnownArgs s) => KnownArgs (('(n, t) ': s)) where toArgDoc = (pack $ symbolVal (Proxy @n), typeName @t) : toArgDoc @s toArgs [] = throwErr $ BadArguments ((pack $ symbolVal (Proxy @n)) <> " of type " <> typeName @t, "No argument")- toArgs (ErrorValue err : _) = throwErr $ CustomRTE err+ toArgs (ErrorValue err : rst) = (NamedArg $ fromError @t err) :> (toArgs @s rst) -- throwErr $ CustomRTE err toArgs (v : rst) = (NamedArg $ fromValue v) :> (toArgs @s rst) +data EitherError a = EitherError (Either Text a)++instance FromValue a => FromValue (EitherError a) where+ fromValue v = EitherError (Right $ fromValue v)+ fromError err = EitherError (Left err)+ typeName = (typeName @a) <> "(optional)"+ instance FromValue a => FromValue (Maybe a) where fromValue v = Just $ fromValue v typeName = (typeName @a) <> "(optional)"@@ -465,6 +553,7 @@ | SDLError Text | ListIndexOutOfBounds Int | KeyNotFound Text+ | UnserializeableValue | CustomRTE Text instance Show RuntimeError where@@ -490,6 +579,7 @@ ListIndexOutOfBounds t -> "Out of bound access of a list at index: " <> (T.pack $ show t) KeyNotFound t -> "Non-existing key access in dictionary at key: " <> t CustomRTE t -> "Run time error: " <> t+ UnserializeableValue -> "UnserializeableValue" throwBadArgs :: [Value] -> Text -> InterpretM (Maybe Value) throwBadArgs v' m = throwBadArgs' v' [] m@@ -502,6 +592,11 @@ data BytesOrText = BTBytes BS.ByteString | BTText Text+ deriving Show++data TextOrList+ = TCList (V.Vector Value)+ | TCText Text deriving Show instance Exception RuntimeError where
src/Interpreter/Initialize.hs view
@@ -7,6 +7,7 @@ import Interpreter.Interpreter import Interpreter.Lib.Math import Interpreter.Lib.Misc+import Interpreter.Lib.String import Interpreter.Lib.Concurrency import Interpreter.Lib.SDL @@ -30,13 +31,20 @@ insertBuiltInWithDoc (SkIdentifier $ Identifier "contains") (SomeBuiltin contains) insertBuiltInWithDoc (SkIdentifier $ Identifier "haskey") (SomeBuiltin haskey) insertBuiltInWithDoc (SkIdentifier $ Identifier "filter") (SomeBuiltin filter_)- insertBuiltInWithDoc (SkIdentifier $ Identifier "drop") (SomeBuiltin arrayDrop)- insertBuiltInWithDoc (SkIdentifier $ Identifier "take") (SomeBuiltin arrayTake)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "drop") (SomeBuiltin builtInDrop)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "take") (SomeBuiltin builtInTake) -- Time insertBuiltInWithDoc (SkIdentifier $ Identifier "timestamp") (SomeBuiltin builtInTimestamp) insertBuiltInWithDoc (SkIdentifier $ Identifier "wait") (SomeBuiltin waitMillisec) + -- Strings+ insertBuiltInWithDoc (SkIdentifier $ Identifier "decodeutf8") (SomeBuiltin builtInDecodeUTF8Bytes)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "encodeutf8") (SomeBuiltin builtInEncodeUTF8Bytes)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "concat") (SomeBuiltin builtInConcat)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "join") (SomeBuiltin builtInJoin)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "split") (SomeBuiltin builtInSplit)+ -- Keyboard insertBuiltInWithDoc (SkIdentifier $ Identifier "getkey") (SomeBuiltin waitForKey) @@ -46,6 +54,7 @@ insertBuiltInWithDoc (SkIdentifier $ Identifier "writefile") (SomeBuiltin builtInWriteFile) -- Math+ insertBuiltInWithDoc (SkIdentifier $ Identifier "pow") (SomeBuiltin builtInPow) insertBuiltInWithDoc (SkIdentifier $ Identifier "mod") (SomeBuiltin builtInMod) insertBuiltInWithDoc (SkIdentifier $ Identifier "random") (SomeBuiltin builtInRandom) insertBuiltInWithDoc (SkIdentifier $ Identifier "sin") (SomeBuiltin builtInSin)@@ -66,14 +75,13 @@ insertBuiltInWithDoc (SkIdentifier $ Identifier "try") (SomeBuiltin builtInTry) insertBuiltInWithDoc (SkIdentifier $ Identifier "jsondecode") (SomeBuiltin builtInJSONParse) insertBuiltInWithDoc (SkIdentifier $ Identifier "jsonencode") (SomeBuiltin builtInJSONSerialize)- insertBuiltInWithDoc (SkIdentifier $ Identifier "decodeutf8") (SomeBuiltin builtInDecodeUTF8Bytes)- insertBuiltInWithDoc (SkIdentifier $ Identifier "encodeutf8") (SomeBuiltin builtInEncodeUTF8Bytes) insertBuiltInWithDoc (SkIdentifier $ Identifier "not") (SomeBuiltin not') insertBuiltInWithDoc (SkIdentifier $ Identifier "debug") (SomeBuiltin builtInDebug) insertBuiltInWithDoc (SkIdentifier $ Identifier "inspect") (SomeBuiltin builtInInspect) insertBuiltInWithDoc (SkIdentifier $ Identifier "println") (SomeBuiltin printValLn) insertBuiltInWithDoc (SkIdentifier $ Identifier "print") (SomeBuiltin printVal) insertBuiltInWithDoc (SkIdentifier $ Identifier "inputline") (SomeBuiltin builtinInputLine)+ insertBuiltInWithDoc (SkIdentifier $ Identifier "stringtonum") (SomeBuiltin numberFromString) -- SDL Sound insertBuiltInWithDoc (SkIdentifier $ Identifier "maketone") (SomeBuiltin builtInMakeTone)
src/Interpreter/Interpreter.hs view
@@ -2,7 +2,7 @@ import Prelude hiding (map) -import Control.Concurrent.MVar+import Control.Concurrent.STM as STM import Control.Exception (throw) import Control.Monad import Control.Monad.Catch (catch)@@ -21,12 +21,13 @@ import Interpreter.Common lookupScope :: ScopeKey -> InterpretM Value-lookupScope key = ((lookupInTopScope key . isLocal) <$> get) >>= \case- Just v -> pure v- Nothing -> ((M.lookup key . isGlobalScope) <$> get) >>= \case+lookupScope key =+ ((lookupInTopScope key . isLocal) <$> get) >>= \case Just v -> pure v- Nothing ->- throwErr $ SymbolNotFound $ (pack $ show key)+ Nothing -> ((M.lookup key . isGlobalScope) <$> get) >>= \case+ Just v -> pure v+ Nothing ->+ throwErr $ SymbolNotFound (pack $ show key) lookupInTopScope :: ScopeKey -> [Scope] -> Maybe Value lookupInTopScope _ [] = Nothing@@ -61,7 +62,10 @@ evaluateExpression_ (ECall iden exprs isTail) = evaluateFn (FnName iden) exprs isTail >>= \case Just v -> pure v Nothing -> throwErr MissingProcedureReturn-evaluateExpression_ (EUnnamedFn args expr) = pure $ UnnamedFnValue $ UnNamedFn args expr+evaluateExpression_ (EUnnamedFn args expr) = do+ isLocal <$> get >>= \case+ [] -> pure $ UnnamedFnValue $ UnNamedFn args mempty expr+ (h: _) -> pure $ UnnamedFnValue $ UnNamedFn args h expr popScope :: InterpretM () popScope = do@@ -80,42 +84,52 @@ evaluateProcedure (SkIdentifier idf) args insertEmptyScope :: InterpretM ()-insertEmptyScope = modify $ mapLocal (\s -> mempty : s)+insertEmptyScope = insertScope mempty +insertScope :: Scope -> InterpretM ()+insertScope scope = modify $ mapLocal (\s -> scope : s)+ evaluateUnnamedFn :: UnNamedFn -> [Value] -> InterpretM Value-evaluateUnnamedFn (UnNamedFn Nothing expr) _ = evaluateExpression expr-evaluateUnnamedFn (UnNamedFn (Just (NE.toList -> argNames)) expr) argsVals = do- insertEmptyScope+evaluateUnnamedFn (UnNamedFn Nothing scope expr) _ = do+ insertScope scope+ x <- evaluateExpression expr+ popScope+ pure x+evaluateUnnamedFn (UnNamedFn (Just (NE.toList -> argNames)) scope expr) argsVals = do+ insertScope scope zipWithM_ (\a1 a2 -> insertBinding a1 a2) (SkIdentifier <$> argNames) argsVals -- @TODO Check argument counts r <- evaluateExpression expr popScope pure r +evaluateProcedure_ :: Value -> [Value] -> InterpretM (Maybe Value)+evaluateProcedure_ fnVal args = case fnVal of+ UnnamedFnValue un -> Just <$> evaluateUnnamedFn un args+ (ProcedureValue (FunctionDef _ argNames (NE.toList -> stms))) -> do+ insertEmptyScope+ zipWithM_ (\a1 a2 -> insertBinding a1 a2) (SkIdentifier <$> argNames) args -- @TODO Check argument counts+ executeStatements stms >>= \case+ ProcReturn False v -> do+ popScope+ pure $ Just v+ ProcReturn True v -> do+ -- Don't pop stack if the return was a tail call return+ -- because the stack was popped before entering the+ -- call.+ pure $ Just v+ ProcBreak -> do+ popScope+ pure Nothing+ ProcContinue -> do+ popScope+ pure Nothing+ (BuiltIn (BuiltinCall cb)) -> cb args+ (BuiltIn (BuiltinCallWithDoc (SomeBuiltin cb))) -> cb (toArgs args)+ a -> throwErr $ UnexpectedType ("Procedure", a)+ evaluateProcedure :: ScopeKey -> [Value] -> InterpretM (Maybe Value)-evaluateProcedure sk args = do- lookupScope sk >>= \case- UnnamedFnValue un -> Just <$> evaluateUnnamedFn un args- (ProcedureValue (FunctionDef _ argNames (NE.toList -> stms))) -> do- insertEmptyScope- zipWithM_ (\a1 a2 -> insertBinding a1 a2) (SkIdentifier <$> argNames) args -- @TODO Check argument counts- executeStatements stms >>= \case- ProcReturn False v -> do- popScope- pure $ Just v- ProcReturn True v -> do- -- Don't pop stack if the return was a tail call return- -- because the stack was popped before entering the- -- call.- pure $ Just v- ProcBreak -> do- popScope- pure Nothing- ProcContinue -> do- popScope- pure Nothing- (BuiltIn (BuiltinCall cb)) -> cb args- (BuiltIn (BuiltinCallWithDoc (SomeBuiltin cb))) -> cb (toArgs args)- a -> throwErr $ UnexpectedType ("Procedure", a)+evaluateProcedure sk args =+ lookupScope sk >>= (\x -> evaluateProcedure_ x args) evaluateFn :: FnId -> [ExpressionWithLoc] -> Bool -> InterpretM (Maybe Value) evaluateFn fnId argsExps isTail = do@@ -123,8 +137,12 @@ FnOp op -> SkOperator op FnName idf -> SkIdentifier idf args <- mapM (\x -> evaluateExpression x) argsExps- when isTail popScope- evaluateProcedure sk args+ if isTail+ then do+ fnVal <- lookupScope sk+ popScope+ evaluateProcedure_ fnVal args+ else evaluateProcedure sk args evaluateSubscriptedExpr :: SubscriptedExpression -> InterpretM Value evaluateSubscriptedExpr (EArraySubscript expr indexExpr) = evaluateExpression expr >>= \case@@ -239,35 +257,36 @@ _ -> throw (RuntimeErrorWithLoc (Left r) loc) peHandler (r :: ProgramError) = throw (RuntimeErrorWithLoc (Right r) loc) -executeDebugStepable :: DebugStepable a b => a -> InterpretM b+executeDebugStepable :: Show a => DebugStepable a b => a -> InterpretM b executeDebugStepable dbs = do isRunMode <$> get >>= \case- NormalMode -> do+ NormalMode _ -> do execute dbs- DebugMode -> do- isStepMode <$> get >>= \case+ DebugMode debugEnv@(DebugEnv { deInQueue = isDebugIn, deOutQueue = isDebugOut, deStepMode = stepMode }) -> do+ case stepMode of Continue -> execute dbs SingleStep -> do- isDebugOut <$> get >>= sendDebugOut- isDebugIn <$> get >>= (liftIO . takeMVar) >>= \case- Run -> do- modify (\is -> is { isRunMode = NormalMode })- execute dbs- StepIn -> execute dbs- AddWatch _ -> execute dbs- StepOver -> do- modify (\is -> is { isStepMode = Continue })- r <- execute dbs- modify (\is -> is { isStepMode = SingleStep })- pure r+ -- 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) })+ execute dbs+ StepIn -> do+ modify (\is -> is { isRunMode = DebugMode (DebugEnv SingleStep isDebugIn isDebugOut) })+ execute dbs+ _ -> error "Unexpected debug command" where sendDebugOut debugOut = do- currentScope <- isLocal <$> get >>= \case- [] -> isGlobalScope <$> get- (scope : _) -> pure scope+ is <- get+ let currentScope = case isLocal is of+ [] -> isGlobalScope is+ (scope : _) -> scope let- dd = DebugState currentScope (getLocation dbs) (Just $ toSource dbs)- liftIO $ putMVar debugOut $ DebugData dd+ dd = DebugState currentScope (getLocation dbs) (Just $ trimAndElipsis $ toSource dbs) (isThreadName is)+ liftIO $ atomically $ writeTBQueue debugOut $ DebugData dd++ trimAndElipsis (T.replace "\n" " " -> t) = if T.length t > 30 then T.take 30 t <> "..." else t executeStatement_ :: FunctionStatement -> InterpretM ProcResult executeStatement_ (FnComment _) = pure ProcContinue
src/Interpreter/Lib/Concurrency.hs view
@@ -8,17 +8,19 @@ import Control.Monad.IO.Class import Control.Monad.State.Strict import Data.Coerce+import Data.Text (pack) import Interpreter.Common import Interpreter.Interpreter -builtInLaunchThread :: BuiltInFnWithDoc '[ '("callback_thread", Callback), '("callback_arg", Value) ]-builtInLaunchThread ((coerce -> (processCb :: Callback)) :> (coerce -> threadArg) :> EmptyArgs) = do+builtInLaunchThread :: BuiltInFnWithDoc '[ '("callback_thread", Callback), '("callback_arg", Maybe Value) ]+builtInLaunchThread ((coerce -> (processCb :: Callback)) :> (coerce -> (mthreadArg)) :> EmptyArgs) = do istate <- get liftIO $ do resultRef <- newEmptyTMVarIO threadId <- forkIO $ flip catch (asynExHandler resultRef) $ do- (r, _) <- flip runStateT istate (evaluateCallback processCb [threadArg])+ threadId <- myThreadId+ (r, _) <- flip runStateT (istate { isThreadName = pack (show threadId) }) (evaluateCallback processCb $ maybe [] (\x -> [x]) mthreadArg) atomically $ putTMVar resultRef $ case r of Just r' -> Right r' Nothing -> Left (toException MissingProcedureReturn)
src/Interpreter/Lib/Math.hs view
@@ -51,6 +51,9 @@ builtInATan ((coerce -> v) :> _) = do pure $ Just $ NumberValue $ NumberFractional (radianToDegree $ atan v) +builtInPow :: BuiltInFnWithDoc '[ '("number", Double), '("pow", IntType)]+builtInPow ((coerce -> (v :: FloatType)) :> (coerce -> (pw :: IntType)) :> EmptyArgs) = pure $ Just $ NumberValue $ NumberFractional $ v ^ pw+ radianToDegree :: FloatType -> FloatType radianToDegree x = (x/pi*180)
src/Interpreter/Lib/Misc.hs view
@@ -1,25 +1,28 @@ module Interpreter.Lib.Misc where import Control.Monad.IO.Class-import Control.Concurrent.STM+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 import qualified Data.ByteString as BS-import Data.Text.Encoding import qualified Data.ByteString.Lazy as BSL import Data.Coerce-import qualified Data.Scientific as S import Data.Map as M-import Text.Hex (encodeHex)-import Data.HashMap.Strict as HM+import qualified Data.Scientific as S 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 Control.Monad.State.Strict as SM+import qualified System.IO as SIO+import Text.Hex (encodeHex) -import UI.Widgets.Common import Interpreter.Common+import UI.Widgets.Common+import Common printValLn :: BuiltInFnWithDoc '[ '("value", Variadic)] printValLn ((coerce -> (Variadic vals)) :> EmptyArgs) = do@@ -36,6 +39,13 @@ S.hFlush S.stdout pure Nothing +numberFromString :: BuiltInFnWithDoc '[ '("string", Text)]+numberFromString ((coerce -> (T.unpack -> str)) :> EmptyArgs) = case readMaybe @IntType str of+ Just i -> pure $ Just $ NumberValue $ NumberInt i+ Nothing -> case readMaybe @FloatType str of+ Just i -> pure $ Just $ NumberValue $ NumberFractional i+ Nothing -> pure $ throwErr $ CustomRTE "String cannot be converted to a number"+ multiplication :: BuiltInFn multiplication (NumberValue v1: NumberValue v2 : []) = pure $ Just $ NumberValue $ numberBinaryFn (*) v1 v2 multiplication a = throwBadArgs a "number"@@ -66,21 +76,29 @@ not' :: BuiltInFnWithDoc '[ '("bool", Bool)] not' ((coerce -> v1) :> _) = pure $ Just $ BoolValue (not v1) -contains :: BuiltInFnWithDoc '[ '("list", Vector Value), '("item", Value)]-contains ((coerce -> v1) :> (coerce -> v2) :> _) = pure $ Just $ BoolValue $ V.foldl' fn False v1- where- fn :: Bool -> Value -> Bool- fn True _ = True- fn False v = v2 == v+contains :: BuiltInFnWithDoc '[ '("list", TextOrList), '("item", Value)]+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"+ TCList lst -> pure $ Just $ BoolValue $ V.foldl' fn False lst+ where+ fn :: Bool -> Value -> Bool+ fn True _ = True+ fn False v = v2 == v haskey :: BuiltInFnWithDoc '[ '("dictionary", M.Map Text Value), '("key", Text)] haskey ((coerce -> (map' :: M.Map Text Value)) :> (coerce -> key) :> _) = pure $ Just $ BoolValue $ M.member key map' -arrayTake :: BuiltInFnWithDoc ['("source_list", Vector Value), '("count", Int)]-arrayTake ((coerce -> v1) :> (coerce -> c) :> _) = pure $ Just $ ArrayValue (V.take c v1)+builtInTake :: BuiltInFnWithDoc ['("count", Int), '("source", TextOrList)]+builtInTake ((coerce -> c) :> (coerce -> vl) :> EmptyArgs) = case vl of+ TCText t -> pure $ Just $ StringValue $ T.take c t+ TCList l -> pure $ Just $ ArrayValue (V.take c l) -arrayDrop :: BuiltInFnWithDoc ['("source_list", Vector Value), '("count", Int)]-arrayDrop ((coerce -> v1) :> (coerce -> c) :> _) = pure $ Just $ ArrayValue (V.drop c v1)+builtInDrop :: BuiltInFnWithDoc ['("count", Int), '("source", TextOrList)]+builtInDrop ((coerce -> c) :> (coerce -> vl) :> EmptyArgs) = case vl of+ TCText t -> pure $ Just $ StringValue $ T.drop c t+ TCList l -> pure $ Just $ ArrayValue (V.drop c l) builtInArrayInsertLeft :: BuiltInFnWithDoc ['("item", Value), '("initial_list", Vector Value)] builtInArrayInsertLeft ((coerce -> c) :> (coerce -> v1) :> _) = pure $ Just $ ArrayValue (V.cons c v1)@@ -112,27 +130,29 @@ Just (x, _) -> pure $ Just x Nothing -> throwErr $ CustomRTE "Empty list found for 'head' call" -builtInTry :: BuiltInFnWithDoc '[ '("evaluation", Value), '("alternate", Maybe Value)]-builtInTry ((coerce -> evaluation) :> (coerce -> malternate) :> _) = case (evaluation, malternate) of- (ErrorValue _, Just a) -> pure $ Just a- (e@(ErrorValue _), Nothing) -> pure $ Just e- (v, _) -> pure $ Just v+builtInTry :: BuiltInFnWithDoc '[ '("evaluation", EitherError Value), '("alternate", Value)]+builtInTry ((coerce -> evaluation) :> (coerce -> alternate) :> _) = case evaluation of+ 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) +serializeJSON :: Value -> InterpretM BS.ByteString+serializeJSON v =+ (BSL.toStrict . A.encode) <$> toAesonVal v+ builtInJSONSerialize :: BuiltInFnWithDoc '[ '("value", Value)] builtInJSONSerialize ((coerce -> (v :: Value)) :> _) =- (Just . BytesValue . BSL.toStrict . A.encode) <$> toAesonVal v+ (Just . BytesValue ) <$> serializeJSON v builtInInspect :: BuiltInFnWithDoc '[ '("value", Value)] builtInInspect ((coerce -> (v :: Value)) :> _) = do- vText <- (decodeUtf8 . BSL.toStrict . A.encode) <$> toAesonVal v- liftIO $ do- T.putStr vText- S.hFlush S.stdout+ vText <- (decodeUtf8) <$> serializeJSON v+ interpreterOutput vText+ interpreterOutputFlush pure Nothing builtInJSONParse :: BuiltInFnWithDoc '[ '("value", Value)]@@ -143,17 +163,14 @@ ((coerce -> (a :: Value)) :> _) -> throwErr $ BadArguments ("String/Bytes", T.pack $ show a) in case A.eitherDecodeStrict bytes of Right val -> pure $ Just $ fromAesonVal val- Left err -> pure $ Just $ ErrorValue ("JSON decoding failed with error:" <> (T.pack err))--builtInDecodeUTF8Bytes :: BuiltInFnWithDoc '[ '("bytes", BS.ByteString)]-builtInDecodeUTF8Bytes ((coerce -> b) :> _) = pure $ Just $ StringValue $ decodeUtf8 b--builtInEncodeUTF8Bytes :: BuiltInFnWithDoc '[ '("string", Text)]-builtInEncodeUTF8Bytes ((coerce -> b) :> _) = pure $ Just $ BytesValue $ encodeUtf8 b+ Left err -> throwErr $ CustomRTE ("JSON decoding failed with error:" <> (T.pack err)) builtInDebug :: BuiltInFnWithDoc '[] builtInDebug _ = do- SM.modify (\is -> is { isRunMode = DebugMode, isStepMode = SingleStep })+ SM.modify (\is -> case isRunMode is of+ NormalMode (Just debugEnv) -> is { isRunMode = DebugMode (debugEnv { deStepMode = SingleStep }) }+ _ -> is+ ) pure Nothing fromAesonVal :: A.Value -> Value@@ -161,7 +178,7 @@ fromAesonVal (A.Number s) = NumberValue $ if S.isInteger s then NumberInt (round s) else NumberFractional (realToFrac s) fromAesonVal (A.Bool b) = BoolValue b fromAesonVal (A.Array b) = ArrayValue (fromAesonVal <$> b)-fromAesonVal (A.Object b) = ObjectValue (M.fromList $ HM.toList $ fromAesonVal <$> b)+fromAesonVal (A.Object b) = ObjectValue (M.fromList $ (\(a, b') -> (A.toText a, fromAesonVal b')) <$> (A.toList b)) fromAesonVal A.Null = Void toAesonVal :: Value -> InterpretM A.Value@@ -174,58 +191,44 @@ vs <- V.mapM (\x -> toAesonVal x) b pure $ A.Array vs toAesonVal (ObjectValue b) = do- vs <- Prelude.mapM (\(k, x) -> do v <- toAesonVal x; pure (k, v)) $ M.toList b- pure $ A.Object $ HM.fromList vs-toAesonVal _ = throwErr $ CustomRTE "Unserializable value"+ vs <- Prelude.mapM (\(k, x) -> do v <- toAesonVal x; pure (A.fromText k, v)) $ M.toList b+ pure $ A.Object $ A.fromList vs+toAesonVal _ = throwErr UnserializeableValue waitMillisec :: BuiltInFnWithDoc '[ '("timeinseconds", Number)] waitMillisec ((coerce -> number) :> _) = (liftIO $ waitMillisec' number) >> pure Nothing waitForKey :: BuiltInFnWithDoc '[] waitForKey _ = do- inputChan <- isTerminalEventChan <$> get- (liftIO $ atomically $ readTChan inputChan) >>= \case- TerminalKey (KeyChar _ _ _ i) -> do- pure $ Just $ StringValue $ T.singleton i- _ -> pure $ Just $ StringValue ""--readChannel :: TChan TerminalEvent -> String -> IO Text-readChannel inputChan c = do- (liftIO $ atomically $ readTChan inputChan) >>= \case- TerminalKey (KeyCtrl _ _ _ Return) -> pure $ T.reverse $ T.pack c- TerminalKey (KeyChar _ _ _ i) -> do- S.putChar i- S.hFlush S.stdout- readChannel inputChan (i:c)- _ -> readChannel inputChan c+ inputHandle <- isInputHandle <$> get+ c <- liftIO $ SIO.hGetChar inputHandle+ pure $ Just $ StringValue $ T.singleton c builtinInputLine :: BuiltInFnWithDoc '[ '("prompt", Text)] builtinInputLine ((coerce -> prompt) :> _) = do- liftIO $ do- T.putStrLn prompt- S.hFlush S.stdout- inputChan <- isTerminalEventChan <$> get- (Just . StringValue) <$> (liftIO $ readChannel inputChan "")+ 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+ 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/SDL.hs view
@@ -184,11 +184,20 @@ waitForSDLKey :: BuiltInFnWithDoc '[] waitForSDLKey _ = do- void $ iterateWhile id $ do- events <- pollEvents- pure $ ((length $ filter filterEvent events) == 0)- pure Nothing+ mv <- iterateWhile isNothing $ do+ events <- (filter filterEvent) <$> pollEvents+ case events of+ [] -> pure Nothing+ (h:_) -> pure $ convertEvent h+ pure mv where+ convertEvent :: Event -> Maybe Value+ convertEvent event =+ case eventPayload event of+ KeyboardEvent keyboardEvent ->+ Just $ SDLValue $ Keycode ((keysymKeycode (keyboardEventKeysym keyboardEvent)))+ _ -> Nothing+ filterEvent :: Event -> Bool filterEvent event = case eventPayload event of@@ -296,8 +305,31 @@ , ("a", SDLValue $ Keycode KeycodeA) , ("b", SDLValue $ Keycode KeycodeB) , ("c", SDLValue $ Keycode KeycodeC)+ , ("d", SDLValue $ Keycode KeycodeD)+ , ("e", SDLValue $ Keycode KeycodeE)+ , ("f", SDLValue $ Keycode KeycodeF)+ , ("g", SDLValue $ Keycode KeycodeG)+ , ("h", SDLValue $ Keycode KeycodeH)+ , ("i", SDLValue $ Keycode KeycodeI)+ , ("j", SDLValue $ Keycode KeycodeJ)+ , ("k", SDLValue $ Keycode KeycodeK)+ , ("l", SDLValue $ Keycode KeycodeL)+ , ("m", SDLValue $ Keycode KeycodeM)+ , ("n", SDLValue $ Keycode KeycodeN)+ , ("o", SDLValue $ Keycode KeycodeO)+ , ("p", SDLValue $ Keycode KeycodeP) , ("q", SDLValue $ Keycode KeycodeQ)+ , ("r", SDLValue $ Keycode KeycodeR) , ("s", SDLValue $ Keycode KeycodeS)+ , ("t", SDLValue $ Keycode KeycodeT)+ , ("u", SDLValue $ Keycode KeycodeU)+ , ("v", SDLValue $ Keycode KeycodeV)+ , ("w", SDLValue $ Keycode KeycodeW)+ , ("x", SDLValue $ Keycode KeycodeX)+ , ("y", SDLValue $ Keycode KeycodeY)+ , ("z", SDLValue $ Keycode KeycodeZ)+ , ("return", SDLValue $ Keycode KeycodeReturn)+ , ("escape", SDLValue $ Keycode KeycodeEscape) ] scancodes :: Value@@ -306,5 +338,30 @@ , ("down", SDLValue $ Scancode ScancodeDown) , ("left", SDLValue $ Scancode ScancodeLeft) , ("right", SDLValue $ Scancode ScancodeRight)+ , ("a", SDLValue $ Scancode ScancodeA)+ , ("b", SDLValue $ Scancode ScancodeB)+ , ("c", SDLValue $ Scancode ScancodeC)+ , ("d", SDLValue $ Scancode ScancodeD)+ , ("e", SDLValue $ Scancode ScancodeE)+ , ("f", SDLValue $ Scancode ScancodeF)+ , ("g", SDLValue $ Scancode ScancodeG)+ , ("h", SDLValue $ Scancode ScancodeH)+ , ("i", SDLValue $ Scancode ScancodeI)+ , ("j", SDLValue $ Scancode ScancodeJ)+ , ("k", SDLValue $ Scancode ScancodeK)+ , ("l", SDLValue $ Scancode ScancodeL)+ , ("m", SDLValue $ Scancode ScancodeM)+ , ("n", SDLValue $ Scancode ScancodeN)+ , ("o", SDLValue $ Scancode ScancodeO)+ , ("p", SDLValue $ Scancode ScancodeP) , ("q", SDLValue $ Scancode ScancodeQ)+ , ("r", SDLValue $ Scancode ScancodeR)+ , ("s", SDLValue $ Scancode ScancodeS)+ , ("t", SDLValue $ Scancode ScancodeT)+ , ("u", SDLValue $ Scancode ScancodeU)+ , ("v", SDLValue $ Scancode ScancodeV)+ , ("w", SDLValue $ Scancode ScancodeW)+ , ("x", SDLValue $ Scancode ScancodeX)+ , ("y", SDLValue $ Scancode ScancodeY)+ , ("z", SDLValue $ Scancode ScancodeZ) ]
+ src/Interpreter/Lib/String.hs view
@@ -0,0 +1,26 @@+module Interpreter.Lib.String where++import qualified Data.ByteString as BS+import Data.Coerce+import Data.Text as T+import Data.Text.Encoding+import Data.Vector as V++import Interpreter.Common++builtInDecodeUTF8Bytes :: BuiltInFnWithDoc '[ '("bytes", BS.ByteString)]+builtInDecodeUTF8Bytes ((coerce -> b) :> EmptyArgs) = pure $ Just $ StringValue $ decodeUtf8 b++builtInEncodeUTF8Bytes :: BuiltInFnWithDoc '[ '("string", Text)]+builtInEncodeUTF8Bytes ((coerce -> b) :> EmptyArgs) = pure $ Just $ BytesValue $ encodeUtf8 b++builtInConcat :: BuiltInFnWithDoc '[ '("string1", Text), '("string2", Text)]+builtInConcat ((coerce -> b) :> (coerce -> d) :> EmptyArgs) = pure $ Just $ StringValue $ T.concat [b, d]++builtInJoin :: BuiltInFnWithDoc '[ '("joiner", Text), '("parts", [Text])]+builtInJoin ((coerce -> b) :> (coerce -> d) :> EmptyArgs) =+ pure $ Just $ StringValue $ T.intercalate b d++builtInSplit :: BuiltInFnWithDoc '[ '("divider", Text), '("text", Text)]+builtInSplit ((coerce -> b) :> (coerce -> d) :> EmptyArgs) =+ pure $ Just $ ArrayValue $ V.fromList $ StringValue <$> T.splitOn b d
src/UI/Chars.hs view
@@ -19,3 +19,9 @@ cornerLB :: Char cornerLB = chr 0x2514++verticalLeft :: Char+verticalLeft = chr 0x251C++verticalRight :: Char+verticalRight = chr 0x2524
src/UI/Widgets/BorderBox.hs view
@@ -33,13 +33,16 @@ getVisibility ref = bbwVisible <$> readWRef ref draw ref = do w <- readWRef ref- drawBorderBox (bbwPos w) (bbwDim w)- case bbwContent w of- SomeWidgetRef a -> do- withCapability (DrawableCap a) $ do- withCapability (MoveableCap a) $ do- move a (moveDown 1 $ moveRight 1 $ bbwPos w)- draw a+ case (bbwVisible w) of+ False -> pass+ True -> do+ drawBorderBox (bbwPos w) (bbwDim w)+ case bbwContent w of+ SomeWidgetRef a -> do+ withCapability (DrawableCap a) $ do+ withCapability (MoveableCap a) $ do+ move a (moveDown 1 $ moveRight 1 $ bbwPos w)+ draw a borderBox :: forall m. ScreenPos
src/UI/Widgets/Common.hs view
@@ -13,11 +13,13 @@ 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 qualified Data.List as DL import Data.Map.Strict as M hiding (keys) import Data.Maybe import Data.Text as T@@ -28,11 +30,12 @@ import Data.Vector.Mutable (IOVector) import qualified Data.Vector.Mutable as MV import GHC.Stack-import qualified Graphics.Vty as VTY 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 qualified System.Console.ANSI as A@@ -228,46 +231,45 @@ strToKeyEvent ('\n': rst) = (KeyCtrl False False False Return) : strToKeyEvent rst strToKeyEvent str = KeyChar False False False <$> str -initializeVty :: IO VTY.Vty-initializeVty =- VTY.standardIOConfig >>= VTY.mkVty--shutdownVty :: VTY.Vty -> IO ()-shutdownVty vty = VTY.shutdown vty+-- Some terminals sets the eighth bit, instead of sending+-- Escape code to indicate alt key sequences. So this function+-- checks for the 8th bit, and if it is set, sets the alt modifier+-- and changes the original char to one with 8th bit unset.+convertFrom8Bit :: KeyEvent -> KeyEvent+convertFrom8Bit kc@(KeyChar c s _ char) = let+ cw = (toEnum $ fromEnum char) :: Word8+ mask' = complement (bit 7)+ in if ((bit 7 .&. cw) > 0) then (KeyChar c s True (toEnum $ fromEnum (cw .&. mask'))) else kc+convertFrom8Bit c = c -readVtyEvent :: VTY.Vty -> IO [TerminalEvent]-readVtyEvent vty = VTY.nextEvent vty >>= \x -> do- case x of- VTY.EvResize w h -> pure [TerminalResize w h]- VTY.EvKey k mods -> pure $ TerminalKey <$> case k of- VTY.KChar c -> [setModifiers mods $ KeyChar False False False c]- VTY.KUp -> [setModifiers mods $ KeyCtrl False False False ArrowUp]- VTY.KDown -> [setModifiers mods $ KeyCtrl False False False ArrowDown]- VTY.KRight -> [setModifiers mods $ KeyCtrl False False False ArrowRight]- VTY.KLeft -> [setModifiers mods $ KeyCtrl False False False ArrowLeft]- VTY.KEsc -> [setModifiers mods $ KeyCtrl False False False Esc]- VTY.KEnter -> [setModifiers mods $ KeyCtrl False False False Return]- VTY.KFun 32 -> [setModifiers (VTY.MCtrl : mods) $ KeyCtrl False False False (Fun 8)]- VTY.KFun n -> [setModifiers mods $ KeyCtrl False False False (Fun n)]- VTY.KBS -> [setModifiers mods $ KeyCtrl False False False Backspace]- VTY.KHome -> [setModifiers mods $ KeyCtrl False False False Home]- VTY.KEnd -> [setModifiers mods $ KeyCtrl False False False End]- VTY.KDel -> [setModifiers mods $ KeyCtrl False False False Del]- _ -> []- _ -> pure []+readTerminalEvent :: (TERM.MonadScreen m, TERM.MonadInput m, MonadIO m) => m [TerminalEvent]+readTerminalEvent = TERM.awaitEvent >>= \case+ Left _ -> do+ pure [TerminalInterrupt]+ Right x ->+ case x of+ TERM.WindowEvent TERM.WindowSizeChanged -> do+ TERM.Size h w <- TERM.getWindowSize+ pure [TerminalResize w h]+ TERM.KeyEvent k mods -> pure $ TerminalKey <$> case k of+ TERM.CharKey c -> [convertFrom8Bit $ setModifiers mods $ KeyChar False False False c]+ TERM.ArrowKey TERM.Upwards -> [setModifiers mods $ KeyCtrl False False False ArrowUp]+ TERM.ArrowKey TERM.Downwards -> [setModifiers mods $ KeyCtrl False False False ArrowDown]+ TERM.ArrowKey TERM.Rightwards -> [setModifiers mods $ KeyCtrl False False False ArrowRight]+ TERM.ArrowKey TERM.Leftwards -> [setModifiers mods $ KeyCtrl False False False ArrowLeft]+ TERM.EscapeKey -> [setModifiers mods $ KeyCtrl False False False Esc]+ TERM.EnterKey -> [setModifiers mods $ KeyCtrl False False False Return]+ TERM.FunctionKey n -> [setModifiers mods $ KeyCtrl False False False (Fun n)]+ TERM.BackspaceKey -> [setModifiers mods $ KeyCtrl False False False Backspace]+ TERM.HomeKey -> [setModifiers mods $ KeyCtrl False False False Home]+ TERM.EndKey -> [setModifiers mods $ KeyCtrl False False False End]+ TERM.DeleteKey -> [setModifiers mods $ KeyCtrl False False False Del]+ _ -> []+ _ -> pure [] where- setModifiers :: [VTY.Modifier] -> KeyEvent -> KeyEvent- setModifiers mods key = DL.foldl' foldFn key mods-- foldFn :: KeyEvent -> VTY.Modifier -> KeyEvent- foldFn (KeyCtrl c _ a v) VTY.MShift = KeyCtrl c True a v- foldFn (KeyCtrl _ s a v) VTY.MCtrl = KeyCtrl True s a v- foldFn (KeyCtrl c s _ v) VTY.MMeta = KeyCtrl c s True v- foldFn (KeyCtrl c s _ v) VTY.MAlt = KeyCtrl c s True v- foldFn (KeyChar c _ a v) VTY.MShift = KeyChar c True a v- foldFn (KeyChar _ s a v) VTY.MCtrl = KeyChar True s a v- foldFn (KeyChar c s _ v) VTY.MMeta = KeyChar c s True v- foldFn (KeyChar c s _ v) VTY.MAlt = KeyChar c s True v+ setModifiers :: TERM.Modifiers -> KeyEvent -> KeyEvent+ setModifiers modifiers (KeyCtrl _ _ _ c) = KeyCtrl ((modifiers .&. TERM.ctrlKey) /= mempty) ((modifiers .&. TERM.shiftKey) /= mempty) ((modifiers .&. TERM.altKey) /= mempty) c+ setModifiers modifiers (KeyChar _ _ _ c) = KeyChar ((modifiers .&. TERM.ctrlKey) /= mempty) ((modifiers .&. TERM.shiftKey) /= mempty) ((modifiers .&. TERM.altKey) /= mempty) c readKey :: IO [KeyEvent] readKey = do@@ -354,15 +356,32 @@ deriving (Show, Ord, Eq) data KeyEvent- = KeyChar Bool Bool Bool Char+ = KeyChar Bool Bool Bool Char -- Bool fields for modifiers for ctrl, shift, alt | KeyCtrl Bool Bool Bool CtrlKey deriving (Show, Eq, Ord) data TerminalEvent = TerminalKey KeyEvent | TerminalResize Int Int+ | TerminalInterrupt deriving Show +pushTerminalEventToHandle :: SIO.Handle -> TerminalEvent -> IO ()+pushTerminalEventToHandle handle' kv = case kv of+ TerminalKey (KeyChar False False False c) -> do+ SIO.hPutChar handle' c+ SIO.hFlush handle'+ TerminalKey (KeyCtrl False False False Backspace) -> do+ SIO.hPutChar handle' '\BS'+ SIO.hFlush handle'+ TerminalKey (KeyCtrl False False False Esc) -> do+ SIO.hPutChar handle' '\ESC'+ SIO.hFlush handle'+ TerminalKey (KeyCtrl False False False Return) -> do+ SIO.hPutChar handle' '\n'+ SIO.hFlush handle'+ _ -> pass+ data TerminalException = TerminalException Text deriving (Show)@@ -440,6 +459,12 @@ let n = moveRight (sX rel) $ moveDown (sY rel) o wSetCursor n pure n++drawTitleLine :: WidgetC m => ScreenPos -> Int -> Int -> Maybe Text -> m ()+drawTitleLine sp width titleOffset (fromMaybe "" -> title) = do+ 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)) ] drawBorderBox :: WidgetC m => ScreenPos -> Dimensions -> m () drawBorderBox sp Dimensions {..} = do
src/UI/Widgets/Editor.hs view
@@ -47,12 +47,12 @@ { epGutterSize :: Int , epLinenumberWidth :: Int , epLinenumberRightPad :: Int- , epBorderSize :: Int+ , epBorder :: Bool , epLineNos :: Bool- }+ } deriving Show defaultEp :: EditorParams-defaultEp = EditorParams 1 4 0 1 True+defaultEp = EditorParams 1 4 0 True True instance Moveable EditorWidget where getPos ref = ewPos <$> readWRef ref@@ -71,18 +71,27 @@ getTextPaddingAndSoftLineLength d EditorParams {..} = let linenumberWidth' = if epLineNos then epLinenumberWidth else 0 linenumberRightPad' = if epLineNos then epLinenumberRightPad else 0+ epBorderSize = if epBorder then 1 else 0 textPadding = epBorderSize + epGutterSize + linenumberWidth' + linenumberRightPad'- softLineLength = (diW d) - textPadding - (2 * epBorderSize)+ softLineLength = (diW d) - textPadding - epBorderSize in (textPadding, softLineLength) getContentStart :: EditorParams -> ScreenPos-getContentStart EditorParams {..} = ScreenPos (epBorderSize + epGutterSize) epBorderSize+getContentStart EditorParams {..} = let+ epBorderSize = if epBorder then 1 else 0+ in ScreenPos (epBorderSize + epGutterSize) epBorderSize getTextContentStart :: Dimensions -> EditorParams -> ScreenPos getTextContentStart d ep = let (tp, _) = getTextPaddingAndSoftLineLength d ep in addSp (ScreenPos (tp - 1) 0) (getContentStart ep) +resetCursor :: EditorWidget -> EditorWidget+resetCursor ew = ew { ewScrollOffset = 0, ewCursor = 0, ewCursorInfo = (ScreenPos 0 0, Bar) }++wrapInSpace :: Text -> Text+wrapInSpace x = " " <> x <> " "+ instance Drawable EditorWidget where setVisibility ref v = modifyWRefM ref (\b -> do case ewAutocompleteWidget b of@@ -94,13 +103,17 @@ draw ref = do w <- readWRef ref draw' w+ where draw' w = do- if (diH $ ewDim w) > 2 then drawBorderBox (ewPos w) (ewDim w) else pass+ let epBorderSize = if (epBorder $ ewParams w) then 1 else 0+ if ((diH $ ewDim w) > 2 && (epBorder $ ewParams w))+ then drawBorderBox (ewPos w) (ewDim w) else pass let (_, softLineLength) = getTextPaddingAndSoftLineLength (ewDim w) params+ let content = ewContent w let cursorLine = ewCursorLine w- let contentHeight = (diH $ ewDim w) - 2+ let contentHeight = (diH $ ewDim w) - (2 * epBorderSize) let mDlocation = ewDebugLocation w let mElocation = ewParseErrorLocation w@@ -224,7 +237,7 @@ if (isPrintableArea realoffset' height) then do wSetCursor- $ moveRight (gutterSize + linenumberWidth' + linenumberRightPad')+ $ moveRight (linenumberWidth' + linenumberRightPad') $ moveDown realoffset' startPos hlText' <- case debugLocation of Just dLocation -> do@@ -232,7 +245,7 @@ Nothing -> pure ((\(a, b) -> (Plain a, b)) <$> hlText) hlText'' <- case selection of Just sLocation -> do- pure $ (selectionColor startOffset sLocation) <$> hlText'+ pure $ snd $ DL.foldl' (selectionColor sLocation) (startOffset, []) hlText' Nothing -> pure hlText' hlText''' <- case errorLocation of Just dLocation -> do@@ -247,7 +260,6 @@ pure () pure tokenStack'' where- gutterSize = epGutterSize linenumberWidth = epLinenumberWidth linenumberRightPad = epLinenumberRightPad linenumberWidth' = if epLineNos then linenumberWidth else 0@@ -258,17 +270,12 @@ tokenLoc = getTokenLoc token in if tokenLoc == debugLoc then (StyledText TextUnderline [Plain src], Just token) else (Plain src, Just token) - selectionColor :: Int -> (Int, Int) -> (StyledText, Maybe a) -> (StyledText, Maybe a)- selectionColor startOffset selectionLoc (src, Nothing) =+ selectionColor :: (Int, Int) -> (Int, [(StyledText, Maybe a)]) -> (StyledText, Maybe a) -> (Int, [(StyledText, Maybe a)])+ selectionColor selectionLoc (startOffset, result) (src, a) = let newSrc = StyledText NoStyle (applyStyleToRange (\st -> StyledText (FgBg Black White) [st]) startOffset selectionLoc [src])- in (newSrc, Nothing)- selectionColor _ selectionLoc (src, Just token) =- let- newSrc = StyledText NoStyle (applyStyleToRange- (\st -> StyledText (FgBg Black White) [st]) (lcOffset $ getTokenLoc token) selectionLoc [src])- in (newSrc, Just token)+ in (startOffset + stTotalLength [src], result <> [(newSrc, a)]) errorColor _ (src, Nothing) = (src, Nothing) errorColor errorLoc (src, Just token) = let@@ -301,7 +308,8 @@ instance Container EditorWidget Text where getContent ref = ewContent <$> readWRef ref- setContent ref content = modifyWRef ref (\w -> w { ewContent = content })+ setContent ref content = do+ modifyWRef ref (\w -> putCursor Nothing (min (ewCursor w) (T.length content - 1)) (w { ewContent = content })) between :: Int -> (Int, Int) -> Bool between a (b, c) = (b <= a) && (a <= c)@@ -354,6 +362,12 @@ adjustScrollOffset r = modifyWRef r (\ew -> putCursor Nothing 0 ew) +scrollToBottom :: WidgetC m => WRef EditorWidget -> m ()+scrollToBottom ewRef = do+ w <- readWRef ewRef+ let ch = (T.length $ ewContent w) - 1+ modifyWRef ewRef (\ew -> putCursor Nothing ch ew)+ putCursor :: Maybe [Int] -> Int -> EditorWidget -> EditorWidget putCursor mll nc ew = let lineLengths = fromMaybe (getLineLengths ew) mll@@ -403,7 +417,8 @@ computeScrollOffset :: EditorWidget -> ScreenPos -> Int computeScrollOffset ew newSp = let- contentHeight = (diH $ ewDim ew) - (2 * (epBorderSize $ ewParams ew))+ epBorderSize = if (epBorder $ ewParams ew) then 1 else 0+ contentHeight = (diH $ ewDim ew) - (2 * epBorderSize) cursorOverflow = (sY newSp - (ewScrollOffset ew)) - (contentHeight - 1) cursorUnderflow = (ewScrollOffset ew) - (sY newSp) in if cursorOverflow > 0@@ -473,7 +488,7 @@ hideAc ew pure $ moveCursor (ew { ewContent = newContent }) (CRIGHT cursorShift) Nothing -> pure ew- KeyChar _ _ _ (convertTab -> c) -> case ewInsertMode ew of+ KeyChar False False False (convertTab -> c) -> case ewInsertMode ew of InsertMode -> do let newContent = insertCharAt c (ewCursor ew) (ewContent ew) let newEw = moveCursor (ew { ewContent = newContent}) (CRIGHT 1)
src/UI/Widgets/Layout.hs view
@@ -21,7 +21,7 @@ , lowOrientation :: Orientation , lowTextFocus :: Maybe SomeKeyInputWidget , lowVisibility :: Bool- , lowFloatingContent :: Maybe SomeWidgetRef+ , lowFloatingContent :: [SomeWidgetRef] , lowDimensionDistribution :: Int -> [Double] } @@ -95,11 +95,8 @@ case (lowOrientation w) of Vertical -> foldM_ (fny (sX $ lowPos w)) (sY $ lowPos w) visibileItems Horizontal -> foldM_ (fn (sY $ lowPos w)) (sX $ lowPos w) visibileItems- case lowFloatingContent w of- Just (SomeWidgetRef f) -> do- withCapability (DrawableCap f) $ do- draw f- Nothing -> pure ()+ flip mapM_ (lowFloatingContent w) $ \(SomeWidgetRef f) -> do+ withCapability (DrawableCap f) $ draw f where fny x y w = case w of SomeWidgetRef a ->@@ -133,6 +130,6 @@ , lowOrientation = ori , lowTextFocus = tif , lowVisibility = True- , lowFloatingContent = Nothing+ , lowFloatingContent = [] , lowDimensionDistribution = distr }
src/UI/Widgets/LogWidget.hs view
@@ -1,27 +1,28 @@ module UI.Widgets.LogWidget where import Data.Text as T-import Text.Printf (printf)-import System.Console.ANSI (Color(..)) import Common-import Highlighter.Highlighter import UI.Widgets.Common as C+import UI.Widgets.Editor data LogWidget = LogWidget { lwDim :: Dimensions , lwContent :: [Text] , lwPos :: ScreenPos , lwVisible :: Bool- , lwScrollOffset :: Int+ , lwContentWidget :: WRef EditorWidget } insertLog :: WidgetC m => WRef LogWidget -> Text -> m ()-insertLog ref l = modifyWRef ref (\lw ->- let- h = diH $ lwDim lw- ln = Prelude.length (lwContent lw)- newContent = (lwContent lw) ++ [l]- in if ln > h then lw { lwScrollOffset = 0, lwContent = Prelude.drop (ln - h) newContent } else lw { lwContent = newContent })+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') instance Moveable LogWidget where getPos ref = lwPos <$> readWRef ref@@ -42,40 +43,24 @@ getVisibility ref = lwVisible <$> readWRef ref draw ref = do w <- readWRef ref- let height = (diH $ lwDim w) - 3- let width = (diW $ lwDim w) - 3- let scrollOffset = lwScrollOffset w- drawBorderBox (lwPos w) (lwDim w)- wSetCursor $ moveDown 1 $ moveRight 1 (lwPos w)- let fmt = "%-" <> (show (width + 1)) <> "s"- csPutText $ colorText White Black (T.pack $ printf fmt (" Logs" :: Text))- let lines' = Prelude.concat $ T.splitOn "\n" <$> lwContent w- lst <- foldM (\offset line -> do- let chunksize = (diW $ lwDim w) - 2- let segments = T.chunksOf chunksize line- foldM (\soffset chunk -> do- when ((soffset > scrollOffset) && ((soffset - scrollOffset) <= height) ) $ do- let cp = moveUp scrollOffset $ moveDown (soffset + 1) $ moveRight 1 (lwPos w)- wSetCursor cp- csPutText $ Plain (T.replicate chunksize " ")- wSetCursor cp- csPutText $ Plain (T.strip chunk)- pure (soffset + 1)- ) offset segments- ) 1 lines'- let overflow = (((lst - 1) - scrollOffset) - height)- when (overflow > 0) $ do- modifyWRef ref (\a -> a { lwScrollOffset = lwScrollOffset a + overflow })- draw ref+ case lwVisible w of+ False -> pure ()+ True -> do+ move (lwContentWidget w) (lwPos w)+ resize (lwContentWidget w) (\_ -> (lwDim w))+ setContent (lwContentWidget w) (T.intercalate "\n" (lwContent w))+ draw (lwContentWidget w) logWidget :: forall m. WidgetM m (WRef LogWidget) logWidget = do+ ew <- editor (\_ -> pure []) Nothing+ modifyWRef ew (\ew' -> ew' { ewParams = (ewParams ew') { epBorder = False, epGutterSize = 0, epLinenumberRightPad = 0, epLineNos = False }}) newWRef $ LogWidget { lwDim = Dimensions 10 10 , lwContent = [] , lwPos = ScreenPos 0 0 , lwVisible = True- , lwScrollOffset = 0+ , lwContentWidget = ew }
src/UI/Widgets/MenuContainer.hs view
@@ -16,6 +16,7 @@ data Menu = Menu { menuItems :: [(Text, SubMenu)] , menuActive :: Maybe (Int, Int) -- Menu items and sub items are indexed from 0+ , menuTitle :: Maybe Text } data MenuContainerWidget = MenuContainerWidget@@ -32,13 +33,13 @@ getContent ref = mcwContent <$> readWRef ref getSubmenuAt :: Menu -> Int -> Maybe SubMenu-getSubmenuAt (Menu mis _) x =+getSubmenuAt (Menu mis _ _) x = case safeIndex mis x of Just (_, sm) -> Just sm Nothing -> Nothing getMenuItem :: Menu -> (Int, Int) -> Maybe [Text]-getMenuItem (Menu mis _) (x, y) =+getMenuItem (Menu mis _ _) (x, y) = case safeIndex mis x of Just (mmName, SubMenu sm) -> case safeIndex sm y of Just sName -> Just [mmName, sName]@@ -55,23 +56,30 @@ getVisibility ref = mcwVisibility <$> readWRef ref draw ref = do w <- readWRef ref+ drawBorderBox (ScreenPos 0 0) (mcwDim w) case mcwMenu w of- Menu mi _ -> foldM_ (\x (n, _) -> do- csSetCursorPosition x 0- csPutText (colorText White Black (" "<> n <> " "))- pure (x + (T.length n + 2))- ) 1 mi+ Menu mi _ mtitle -> do+ co <- foldM (\x (n, _) -> do+ csSetCursorPosition x 0+ csPutText (colorText White Black (" "<> n <> " "))+ pure (x + (T.length n + 2))+ ) 2 mi+ case mtitle of+ Just title -> do+ csSetCursorPosition co 0+ csPutText $ colorText White Blue (" "<> title <> " ")+ Nothing -> pass case mcwContent w of SomeWidgetRef a -> do withCapability (DrawableCap a) $ do withCapability (MoveableCap a) $ do- move a (ScreenPos 0 1)- resize a (\_ -> amendHeight (mcwDim w) (\x -> x-2))+ move a (ScreenPos 1 1)+ resize a (\_ -> amendWidth (\x -> x - 2) $ amendHeight (\x -> x-2) (mcwDim w) ) draw a case menuActive $ mcwMenu w of Just (m, s) -> do case mcwMenu w of- Menu mi _ -> foldM_ (\(idx, x) (n, submenu) -> do+ Menu mi _ _ -> foldM_ (\(idx, x) (n, submenu) -> do if idx == m then do case submenu of SubMenu smi -> do@@ -88,7 +96,7 @@ pure (idy+1)) 0 smi else pure () pure (idx + 1, x + T.length n + 2)- ) (0, 1) mi+ ) (0, 2) mi Nothing -> pure () menuContainer
src/UI/Widgets/TextContainer.hs view
@@ -1,5 +1,8 @@ module UI.Widgets.TextContainer where +import Data.Typeable+import qualified Data.Text as T+ import UI.Widgets.Common import Common @@ -17,6 +20,11 @@ tcwContent <$> readWRef ref instance Widget TextContainerWidget where+ hasCapability (ContainerCap _ (_ :: Proxy cnt)) = case eqT @cnt @Text of+ Just Refl -> Just Dict+ Nothing -> Nothing+ hasCapability (DrawableCap _) = Just Dict+ hasCapability (MoveableCap _) = Just Dict hasCapability _ = Nothing instance Moveable TextContainerWidget where@@ -32,16 +40,17 @@ getVisibility ref = tcwVisibility <$> readWRef ref draw ref = do w <- readWRef ref+ forM_ [0..((diH $ tcwDim w) - 1)] (\x -> printOneSoftLine w x ((T.replicate (diW $ tcwDim w) " "), 0)) foldM_ (printOneLine w) 0 (splitOn "\n" (tcwContent w)) where printOneLine w ln lineContent = do- ll <- foldM printOneSoftLine ln (Prelude.zip (chunksOf ((diW $ tcwDim w) - 2) lineContent) [0..])+ ll <- foldM (printOneSoftLine w) ln (Prelude.zip (chunksOf ((diW $ tcwDim w)) lineContent) [0..]) pure (ll + 1)- where- printOneSoftLine lns (sLineContent, ln') = do- wSetCursor $ moveDown (lns + ln') (tcwPos w)- csPutText $ Plain sLineContent- pure lns++ printOneSoftLine w lns (sLineContent, ln') = do+ wSetCursor $ moveDown (lns + ln') (tcwPos w)+ csPutText $ Plain sLineContent+ pure lns textContainer :: ScreenPos
+ src/UI/Widgets/TitledContainer.hs view
@@ -0,0 +1,50 @@+module UI.Widgets.TitledContainer where++import UI.Widgets.Common+import Common++data TitledContainer = TitledContainer+ { ttcwTitle :: Text+ , ttcwContent :: SomeWidgetRef+ , ttcwDim :: Dimensions+ , ttcwPos :: ScreenPos+ , ttcwVisibility :: Bool+ }++setTitle :: TitledContainer -> Text -> TitledContainer+setTitle tc t = tc { ttcwTitle = t }++instance Widget TitledContainer where+ hasCapability (DrawableCap _) = Just Dict+ hasCapability (MoveableCap _) = Just Dict+ hasCapability _ = Nothing++instance Moveable TitledContainer where+ getPos ref = ttcwPos <$> readWRef ref+ move ref pos =+ modifyWRef ref (\tcw -> tcw { ttcwPos = pos })+ getDim ref = ttcwDim <$> readWRef ref+ resize ref cb =+ modifyWRef ref (\tcw -> tcw { ttcwDim = cb $ ttcwDim tcw })++instance Drawable TitledContainer where+ setVisibility ref v = modifyWRef ref (\b -> b { ttcwVisibility = v })+ getVisibility ref = ttcwVisibility <$> readWRef ref+ draw ref = do+ w <- readWRef ref+ 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))+ withCapability (DrawableCap cw) $+ draw cw++titledContainer+ :: ScreenPos+ -> Dimensions+ -> SomeWidgetRef+ -> Text+ -> WidgetM m (WRef TitledContainer)+titledContainer sp dim cont title = newWRef $ TitledContainer title cont dim sp True
src/UI/Widgets/WatchWidget.hs view
@@ -6,10 +6,12 @@ import Common import UI.Widgets.Common as C+import UI.Widgets.Editor data WatchWidget = WatchWidget { wwDim :: Dimensions , wwContent :: [(Text, Text)]+ , wwContentWidget :: WRef EditorWidget , wwPos :: ScreenPos , wwVisible :: Bool }@@ -41,19 +43,27 @@ getVisibility ref = wwVisible <$> readWRef ref draw ref = do w <- readWRef ref- drawBorderBox (wwPos w) (wwDim w)- wSetCursor $ moveDown 1 $ moveRight 1 (wwPos w)- flip mapM_ (Prelude.zip [1..] (wwContent w)) $ \(i, (k, v)) -> do- wSetCursor $ moveDown i $ moveRight 1 (wwPos w)- csPutText $ Plain $ T.take ((diW $ wwDim w) - 2) $ T.intercalate "|" [k, v]+ case wwVisible w of+ False -> pure ()+ True -> do+ move (wwContentWidget w) (wwPos w)+ resize (wwContentWidget w) (\_ -> wwDim w)+ setContent (wwContentWidget w) (T.intercalate "\n" (joinItems <$> (wwContent w)))+ draw (wwContentWidget w)+ where+ joinItems :: (Text, Text) -> Text+ joinItems (k, v) = k <> " = " <> v watchWidget :: forall m. WidgetM m (WRef WatchWidget) watchWidget = do+ ew <- editor (\_ -> pure []) Nothing+ modifyWRef ew (\ew' -> ew' { ewParams = (ewParams ew') { epBorder = False, epGutterSize = 0, epLinenumberRightPad = 0, epLineNos = False }}) newWRef $ WatchWidget { wwDim = Dimensions 10 10 , wwContent = []+ , wwContentWidget = ew , wwPos = ScreenPos 0 0 , wwVisible = False }
stack.yaml view
@@ -2,12 +2,13 @@ packages: - . extra-deps:- - strip-ansi-escape-0.1.0.0@sha256:08f2ed93b16086a837ec46eab7ce8d27cf39d47783caaeb818878ea33c2ff75f,1628- - Win32-2.10.1.1@sha256:e23a0c857a03c5c5d1a6174ee922b1a97fe495fa0383c3831eb9b8a1474884fe,4399- - directory-1.3.7.0@sha256:fa5aa98b70559eb9c26a8c1332a55618876ad825233271142f182c3502e1f23c,2811- - process-1.6.13.2@sha256:9733aa8a27b3e6c0f08a87a5c7287b3b73302d396f68f5655f9990a641368e3e,2845- - time-1.10@sha256:536801b30aa2ce66da07cb19847827662650907efb2af4c8bef0a6276445075f,5738- - unix-2.7.2.2@sha256:15f5365c5995634e45de1772b9504761504a310184e676bc2ef60a14536dbef9,3496- - proteaaudio-sdl-0.9.2@sha256:b1c2f3adf4d209fa20643939489cb9a03be10095acdee1b536649b69ee8a53eb,1887- - sdl2-mixer-1.2.0.0@sha256:6a6b5a46c035c9e77eaf9c244e45de9e4a9b9a110890cfeeb9fa72faa2419cef,4497- - WAVE-0.1.6@sha256:f744ff68f5e3a0d1f84fab373ea35970659085d213aef20860357512d0458c5c,1016+- WAVE-0.1.6@sha256:f744ff68f5e3a0d1f84fab373ea35970659085d213aef20860357512d0458c5c,1016+- aeson-2.0.3.0@sha256:130bda8e10dc6dd159b79b306abb10025d7f8b5d9cbc2f7d6d7e6768a0272058,5845+- hspec-2.9.4@sha256:658a6a74d5a70c040edd6df2a12228c6d9e63082adaad1ed4d0438ad082a0ef3,1709+- sdl2-mixer-1.2.0.0@sha256:6a6b5a46c035c9e77eaf9c244e45de9e4a9b9a110890cfeeb9fa72faa2419cef,4497+- terminal-0.2.0.0@sha256:de6770ecaae3197c66ac1f0db5a80cf5a5b1d3b64a66a05b50f442de5ad39570,2977+- attoparsec-0.14.3@sha256:b65d94fa4ac2854e396d29532915c5fd6c48d000fea8b84f3c0d9c8430e36dc4,6183+- hspec-core-2.9.4@sha256:a126e9087409fef8dcafcd2f8656456527ac7bb163ed4d9cb3a57589042a5fe8,6498+- hspec-discover-2.9.4@sha256:fbcf49ecfc3d4da53e797fd0275264cba776ffa324ee223e2a3f4ec2d2c9c4a6,2165+- text-short-0.1.5@sha256:962c6228555debdc46f758d0317dea16e5240d01419b42966674b08a5c3d8fa6,3498+- strip-ansi-escape-0.1.0.0@sha256:08f2ed93b16086a837ec46eab7ce8d27cf39d47783caaeb818878ea33c2ff75f,1628
+ stack.yaml.lock view
@@ -0,0 +1,82 @@+# This file was autogenerated by Stack.+# You should not edit this file by hand.+# For more information, please see the documentation at:+# https://docs.haskellstack.org/en/stable/lock_files++packages:+- completed:+ hackage: WAVE-0.1.6@sha256:f744ff68f5e3a0d1f84fab373ea35970659085d213aef20860357512d0458c5c,1016+ pantry-tree:+ size: 405+ sha256: ee5ccd70fa7fe6ffc360ebd762b2e3f44ae10406aa27f3842d55b8cbd1a19498+ original:+ hackage: WAVE-0.1.6@sha256:f744ff68f5e3a0d1f84fab373ea35970659085d213aef20860357512d0458c5c,1016+- completed:+ hackage: aeson-2.0.3.0@sha256:130bda8e10dc6dd159b79b306abb10025d7f8b5d9cbc2f7d6d7e6768a0272058,5845+ pantry-tree:+ size: 38191+ sha256: bccfc5a7259a27aad7e4193f367c3d7d67799f42632fdcb90241c1e9fbb0cf40+ original:+ hackage: aeson-2.0.3.0@sha256:130bda8e10dc6dd159b79b306abb10025d7f8b5d9cbc2f7d6d7e6768a0272058,5845+- completed:+ hackage: hspec-2.9.4@sha256:658a6a74d5a70c040edd6df2a12228c6d9e63082adaad1ed4d0438ad082a0ef3,1709+ pantry-tree:+ size: 583+ sha256: 0a92fc29b7e7f422dbd056c8e8bb88f5e4009ad37d679a8a2dab3ca62de98277+ original:+ hackage: hspec-2.9.4@sha256:658a6a74d5a70c040edd6df2a12228c6d9e63082adaad1ed4d0438ad082a0ef3,1709+- completed:+ hackage: sdl2-mixer-1.2.0.0@sha256:6a6b5a46c035c9e77eaf9c244e45de9e4a9b9a110890cfeeb9fa72faa2419cef,4497+ pantry-tree:+ size: 764+ sha256: 5899820c239536aaccfceeb1b6c056ce8ecebbe40f31d3715ca0a53f56d9aaa1+ original:+ hackage: sdl2-mixer-1.2.0.0@sha256:6a6b5a46c035c9e77eaf9c244e45de9e4a9b9a110890cfeeb9fa72faa2419cef,4497+- completed:+ hackage: terminal-0.2.0.0@sha256:de6770ecaae3197c66ac1f0db5a80cf5a5b1d3b64a66a05b50f442de5ad39570,2977+ pantry-tree:+ size: 1775+ sha256: 54160663bf0cbcd1d9fa52e136740faaf91a82d1ca1efeb08e8e58575a7446e7+ original:+ hackage: terminal-0.2.0.0@sha256:de6770ecaae3197c66ac1f0db5a80cf5a5b1d3b64a66a05b50f442de5ad39570,2977+- completed:+ hackage: attoparsec-0.14.3@sha256:b65d94fa4ac2854e396d29532915c5fd6c48d000fea8b84f3c0d9c8430e36dc4,6183+ pantry-tree:+ size: 5305+ sha256: 0a15e87509cc67315b0531cac10baaaad5eef464c0bb5175d8ecbdcd7365e056+ original:+ hackage: attoparsec-0.14.3@sha256:b65d94fa4ac2854e396d29532915c5fd6c48d000fea8b84f3c0d9c8430e36dc4,6183+- completed:+ hackage: hspec-core-2.9.4@sha256:a126e9087409fef8dcafcd2f8656456527ac7bb163ed4d9cb3a57589042a5fe8,6498+ pantry-tree:+ size: 5684+ sha256: 3715daf7eb40eefeba075013c5b70d57219d0cfd8114706fc7500c9442f05966+ original:+ hackage: hspec-core-2.9.4@sha256:a126e9087409fef8dcafcd2f8656456527ac7bb163ed4d9cb3a57589042a5fe8,6498+- completed:+ hackage: hspec-discover-2.9.4@sha256:fbcf49ecfc3d4da53e797fd0275264cba776ffa324ee223e2a3f4ec2d2c9c4a6,2165+ pantry-tree:+ size: 828+ sha256: 54035d7fe6836d08d2e6e934b415135f7e77b4cb002167c4620e3b68d3c51bd7+ original:+ hackage: hspec-discover-2.9.4@sha256:fbcf49ecfc3d4da53e797fd0275264cba776ffa324ee223e2a3f4ec2d2c9c4a6,2165+- completed:+ hackage: text-short-0.1.5@sha256:962c6228555debdc46f758d0317dea16e5240d01419b42966674b08a5c3d8fa6,3498+ pantry-tree:+ size: 727+ sha256: 1fc6561c4acb94a41e58cd8f8c7cce161c18c5629dac63a54a9c62f9c778c52b+ original:+ hackage: text-short-0.1.5@sha256:962c6228555debdc46f758d0317dea16e5240d01419b42966674b08a5c3d8fa6,3498+- completed:+ hackage: strip-ansi-escape-0.1.0.0@sha256:08f2ed93b16086a837ec46eab7ce8d27cf39d47783caaeb818878ea33c2ff75f,1628+ pantry-tree:+ size: 671+ sha256: cf7712453587e8ea69b96f33e2e8015c22d3b448259d4cace663cc15657309d7+ original:+ hackage: strip-ansi-escape-0.1.0.0@sha256:08f2ed93b16086a837ec46eab7ce8d27cf39d47783caaeb818878ea33c2ff75f,1628+snapshots:+- completed:+ size: 611690+ url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2021/12/18.yaml+ sha256: d588b09b01c2b9ed1ea2880d70742f67c7ae775b3e032a44aa3beac8774fc99c+ original: nightly-2021-12-18
test/Compiler/Lexer/LiteralSpec.hs view
@@ -16,6 +16,7 @@ describe "Literal parsing" $ do it "can parse strings" $ runParser parser ("\"test\"" :: TextWithOffset) `shouldReturn` (Just $ LitString "test")+ it "can parse strings with escaped quotes" $ runParser parser (toTextWithOffset $ "\"te" <> "\\" <> "\"" <> "st\"") `shouldReturn` (Just $ LitString "te\"st") it "can parse numbers" $ runParser parser "90" `shouldReturn` (Just $ LitNumber 90) it "reject numbers starting with 0" $ (runParser @Literal) parser "09" `shouldReturn` Nothing it "can parse float: 1" $ runParser parser "90.05" `shouldReturn` (Just $ LitFloat 90.05)
test/Interpreter/InterpreterSpec.hs view
@@ -49,7 +49,7 @@ |] compile program >>= interpret'' >>= ensureVarIs (SkIdentifier "a") (NumberValue $ NumberInt 10) where- interpret'' = interpret_ (error "Input stream not available")+ interpret'' = interpret id ensureVarIs :: ScopeKey -> Value -> InterpreterState -> Expectation ensureVarIs sk v (isGlobalScope -> scope) = (lookupInTopScope sk [scope]) `shouldBe` (Just v)
test/UI/EditorSpec.hs view
@@ -42,6 +42,7 @@ csClear mapM_ (handleInput ewRef) kEvents draw ewRef+ csDraw assertReferenceScreenState expectedSs ewRef mkKeys :: Int -> CtrlKey -> [KeyEvent]