diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,10 @@ # Changelog for S.P.A.D.E +## Unreleased + +* Added directory iterator. +* Make subscripted indexing work for strings and bytes. + ## 0.1.0.6 * Added an output window within IDE. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -14,8 +14,7 @@ for i = 1 to 100 circle(random(10, 300), random(10, 300), random(10, 40)) endfor -drawscreen() -waitforkey() +render() ``` The entire language and function reference is available in the IDE in an diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -75,8 +75,11 @@ T.putStrLn "Will print input from stdin for 10 seconds..." SIO.hFlush stdout threadId <- forkIO $ forever $ do - ks <- readKey + ks <- readKey_ stdin + T.putStrLn "----------" T.putStrLn $ T.pack $ show ks + T.putStrLn $ T.pack $ show $ strToKeyEvent ks + T.putStrLn "----------" SIO.hFlush stdout -- wait for 10 sec wait 10 diff --git a/docs/functions/concurrency.md b/docs/functions/concurrency.md --- a/docs/functions/concurrency.md +++ b/docs/functions/concurrency.md @@ -7,6 +7,14 @@ from the callback, after it has finished execution in the thread. This can also be used with #link: killthread# to stop the execution of a thread. +The first argument to this function is the function that should be run in the thread. +The second argument is passed to the thread function. Use a list to pass multiple values +to the thread function. + +The thread function does not inherit any scope from main thread. If you have to share +some data with the thread, you have to use a mutable reference, that is passed to the +thread function using the second argument to `startthread` function. + Example: ``` proc thread1(threadname) @@ -29,29 +37,6 @@ await(t2) getkey() --- Outputs: - --- thread 1 --- thread 2 --- thread 2 --- thread 1 --- thread 2 --- thread 1 --- thread 1 --- thread 2 --- thread 2 --- thread 1 --- thread 1 --- thread 2 --- thread 2 --- thread 1 --- thread 2 --- thread 1 --- thread 1 --- thread 2 --- thread 1 --- thread 2 - ``` #### killthread @@ -74,12 +59,6 @@ println("Thread killed") getkey() --- Outputs: - --- loop --- loop --- loop --- Thread killed ``` #### awaitresult @@ -99,10 +78,6 @@ println(awaitresult(t1)) getkey() --- Outputs --- Thread started, waiting for result... --- 100 - ``` #### await @@ -121,22 +96,46 @@ println("Thread finished") getkey() --- Outputs --- Thread started, waiting to end... --- Thread finished ``` #### newchannel Create a new channel for communication with threads. + +``` +proc thread1(args) + loop + writechannel(args[2], 20) + wait(1) + endloop +endproc +let ch = newchannel() +let t1 = startthread(thread1, ["thread 1", ch]) +println("Thread started, waiting for result...") +loop + let x = readchannel(ch) + println(x) +endloop +getkey() +``` + #### writechannel -Write a value to a channel +``` +writechannel(channel, value) +``` +Write a value to a channel. See #link: newchannel# for an example. + #### readchannel +``` +let msg = readchannel(channel) +``` + Wait till a value is available on a channel, and return it when it is available. +See #link: newchannel# for an example. #### newref @@ -152,31 +151,4 @@ #### modifyref -Modify the current value of the mutable reference by a call back. The call back -gets the current value, and should return the modified value. - -Example: - -Increments a counter in a mutable reference in two threads. - -``` -proc thread1(ref) - for i = 1 to 50000 - modifyref(ref, fn (x) (x + 1) endfn) - endfor -endproc - -proc thread2(ref) - for i = 1 to 50000 - modifyref(ref, fn (x) (x + 1) endfn) - endfor -endproc -let r = newref(0) -let t1 = startthread(thread1, r) -let t2 = startthread(thread2, r) -await(t1) -await(t2) -println(readref(r)) --- Prints 100000 -getkey() -``` +Atomically modify a reference using a callback diff --git a/docs/functions/dictionary.md b/docs/functions/dictionary.md --- a/docs/functions/dictionary.md +++ b/docs/functions/dictionary.md @@ -12,6 +12,15 @@ getkey() ``` +#### addkey + +Adds a new key to the dictionary. + +#### getkey + +Adds a new key to the dictionary. + + #### Getting number of items in dictionary Use #link: size# diff --git a/docs/functions/file.md b/docs/functions/file.md --- a/docs/functions/file.md +++ b/docs/functions/file.md @@ -16,3 +16,76 @@ and writes content to the file at path. Any existing content is truncated. Content can be either bytes or text. + +#### opendir + +Accept a path to a directory and opens it and returns an iterator that +can be used with foreach. Accepts a second boolean argument, if true +the directory will be walked recursively. Does not follow symbolic links. + +Each item in the iteration is a dictionary that will contain the following keys. + +path: Will contain the full path to the file +type: Will conain either the string "file", if the item is a file, "dir" if the + item is a directory, "symlink" is the item is a symbolic link, or "error" if + there was an error reading the items file entry. + +#### getcurrentdir + +Gets the current directory as a string. + +#### takefilename + +Gets the filename component of a path. + +#### takedirectory + +Gets the directory component of a path. + +#### takeextension + +Gets the extension component of a path. + + +#### dropextension + +Gets the path with extension removed. + +#### takebasename + +Gets the name without extension and directory. + +#### joinpaths + +Accepts two path components and join them. + +#### readfilehandle + +Reads the specified number of bytes from the provided file handle. If there is +not enough data remaining to read, returns all the remaining data. So it +returns a bytes value of zero length on end of file, and can be used to detect +EOF. + +#### writefilehandle + +Accepts a file handle and a bytes value and writes it to the handle. + +#### openfilehandle + +Opens a file handle in one of the given modes "r", "w", "rw", "a". + +#### gethandlesize + +Returns the size of the associated file of the handle in 8 bit bytes. + +#### renamefile + +Renames a file to new name. + +#### isfile + +Checks if a path is a file. + +#### isdirectory + +Checks if a path is a directory. diff --git a/docs/functions/graphics.md b/docs/functions/graphics.md --- a/docs/functions/graphics.md +++ b/docs/functions/graphics.md @@ -5,9 +5,8 @@ Starts the graphics mode. The argument here is an optional boolean. A true value indicates the graphics will use acceleration. -In accelerated graphics mode, screen is only updated on #link: drawscreen# +In accelerated graphics mode, screen is only updated on #link: render# -Example: ``` graphics(true) @@ -24,14 +23,14 @@ graphicswindow(400, 200, true) ``` -#### drawscreen +#### render Draws everything to the screen at once. Example: ``` -drawscreen() +render() ``` #### point @@ -110,6 +109,31 @@ circle(100, 100, 20) ``` +#### arc + +``` +arc(center_x, center_y, radius, start_angle, end_angle, fill) +``` + +Similar to #link: circle#, but draws an arc. + +#### polygon + +``` +polygon(points, fill) +``` + +Draws a polygon taking a list of points as input. The last point is joined with +the first one, closing the polygon. The second optional argument specifies +wether the polygon should be filled. + +Sample: + +``` +polygon([[100, 100], [150, 50], [200, 100]]) +``` + + #### setcolor Sets the current drawing color using red, green and blue component values. @@ -157,3 +181,27 @@ ``` waitforkey() ``` + +##### loadtexture + +Loads a bitmap file into a texture. + +##### destroytexture + +Destroys a loaded texture. + +##### copytexture + +Copy a texture to default renderer at the the specified position. + +##### copytexturepart + +Copy a texture partially to default renderer at the the specified position. + +##### copytexturerotated + +Copy a texture after rotating/flipping to default renderer at the the specified position. + +##### textureinfo + +Get dimensions of the texture. diff --git a/docs/functions/list.md b/docs/functions/list.md --- a/docs/functions/list.md +++ b/docs/functions/list.md @@ -113,3 +113,8 @@ inspect(size(mylist)) -- outputs : 5 getkey() ``` + +#### repeat + +Returns a list with the provided item repeated the specified number +of times. diff --git a/docs/functions/math.md b/docs/functions/math.md --- a/docs/functions/math.md +++ b/docs/functions/math.md @@ -44,3 +44,22 @@ Power of function. +#### hash + +Computes the hash using algorith specified and of input bytes. +Right now only support following algorithms. + +#### hashinit + +Initialize a hash context for incremental hashing. + +#### hashupdate + +Update a hash context with a bytestring. + +#### hashfinalize + +Gets the final hash. + + +1. md5 diff --git a/docs/functions/misc.md b/docs/functions/misc.md --- a/docs/functions/misc.md +++ b/docs/functions/misc.md @@ -1,5 +1,13 @@ ### Miscellaneous Functions +#### error + +Construct an error value with the provided message. + +#### iserror + +Check if a value is an error value.. + #### print Accept many values and prints them in order, without an ending newline. @@ -65,11 +73,18 @@ Set current output location +#### csmove + +Set output location relative to current location + #### csprint Prints text at current location +#### csprintln +Prints text at current location and moves to next line + #### csclear Clears the screen to start drawing next frame. @@ -77,3 +92,103 @@ #### csdraw Output instructions to update screen. + +#### csinputline + +Input a line at current cursor. + +#### csclearline + +Clears current line. + +#### csget + +Gets current location as a dictonary with x, y keys. + +#### hexencode + +Hex encodes a bytes value to text value. + +#### hexdecode + +Hex decodes a text value to bytes value. + +#### borderbox + +TODO + +#### attach + +TODO + +#### attachat + +TODO + +#### draw + +TODO + +#### resizinglayout + +TODO + +#### text + +TODO + +#### label + +TODO + +#### selector + +TODO + +#### handle + +TODO + +#### csscreensize + +TODO + +#### setsize + +TODO + +#### settext + +TODO + +#### setfocus + +TODO + +#### layout + +TODO + +#### input + +TODO + +#### multilineinput + +TODO + +#### setoptions + +TODO + +#### getselection + +TODO + +#### getoptions + +TODO + +#### button + +TODO diff --git a/docs/functions/string.md b/docs/functions/string.md --- a/docs/functions/string.md +++ b/docs/functions/string.md @@ -12,6 +12,10 @@ Concats two strings. +#### trim + +Removes surrounding whitespace from string. + #### split Splits a string using a separator @@ -36,3 +40,15 @@ #### formatamount Insert commas into a string according to the passed argument. + +#### tolower + +Lower case a string + +#### toupper + +Upper case a string + +#### replace + +`replace(needle, replace, haystack)` returns a string with occurances of `needle` replaced with `replace` in `haystack` diff --git a/docs/graphics-and-animation.md b/docs/graphics-and-animation.md --- a/docs/graphics-and-animation.md +++ b/docs/graphics-and-animation.md @@ -1,75 +1,100 @@ ### Graphics and Animation -Use the #link: graphics# or #link: graphicswindow# functions to open a -graphics window and start drawing things on screen. - -The origin is located at the top, left corner. +Use the #link: graphics# or #link: graphicswindow# functions to open a graphics +window and start drawing things on screen. You can draw lines, circles, +rectangles etc. Co-ordinate (0, 0) is at top left corner. `x` co-ordinate +increases as you move down right, and `y` values increase as you move down. -Objects are drawn in the currently draw color. Use #link: setcolor# function -to change the draw color. +Objects are drawn in the currently set draw color. Use #link: setcolor# +function to change the draw color. Color is represented by its red, green and blue components. Each can range from 0 to 255. -##### Accelerated mode +The following program draws a line from top left corner to bottom left corner +of the screen. -If acceleration is enabled, output of the drawing commands are not rendered -until #link: drawscreen# is called. +``` +graphics() +let screensize = getwindowsize() +setcolor(0, 0, 0) +clearscreen() +setcolor(255, 0, 0) -- red color +line(0, 0, screensize.width, screensize.height) +render() +waitforkey() +``` -##### Clearing screen +So generally the procedure to draw stuff on screen is as follows. -Use #link: clearscreen# function to fill the screen with the current draw color. +1. clear screen using setcolor and clearscreen. +2. Draw stuff on the screen. +3. call `render()` to actually show the drawn stuff. +This means that you need to keep track of all the stuff that is on screen +and redraw then every frame. To draw incrementally, use non-accelerated mode. + +##### Non-accelerated mode + +Graphics acceleration is enabled by default, and output of the drawing commands +are not rendered until #link: render# is called. If you want to draw +incremently, you have to disable acceleration. For example, if you want to +animate a line being drawn from the left edge of the screen to the right edge, +you can use the following program. + +``` +graphics(false) +let screensize = getwindowsize() +setcolor(255, 0, 0) +for i = 1 to screensize.width + point(i, 200) +endfor +render() +waitforkey() +``` + ##### Working with screens of different resolutions Since displays vary widely in their sizes and resolutions, dimensions that look good on one display might look too small, or too large in a different display resolution. -To fix this, use #link: setlogicalsize# function to correctly scale rendered -objects to look similar in different displays. +To workaround this this, use #link: setlogicalsize# function to work in a virtual +screen, and have your drawings stretched to the actual resolution automatically. ##### Keyboard input handling -The #link: getkeypresses# function can be used to get all the keys that have been pressed -since that last call of this function. This function returns a list that contains -the keycode of the keys. The keycodes can be compared using the values in #link: keycodes# -dictionary. - -Example: - -``` -graphicswindow(500, 500) -wait(5) --- Wait while user presses some keys -let keyspressed = getkeypresses() - -if contains(keyspressed, keycodes.b) then - -- If user pressed 'b' then set color to red - setcolor(255, 0, 0) -else - -- or else set color to green - setcolor(0, 255, 0) -endif -circle(100, 100, 50) -drawscreen() -waitforkey() -``` - -This method is not very good to detect simultaneous key presses. For that, use -#link: getkeystate# function to capture keyboard state at a point. Then use -#link: inkeystate# function to check if a certain key was pressed at the point -of capture. +Use #link: getkeystate# function to capture the keyboard state and use the +`inkeystate` function to query if some keys were pressed during the moment of +capture. The following program moves a point across the screen controlled by +the arrow keys. You can press up/right arrows simultaneously to move the point +diagonally. Example: ``` graphics() +setcolor(0, 0, 0) +clearscreen() +let x = 0 +let y = 0 +setcolor(255, 255, 255) loop + point(x, y) let ks = getkeystate() - -- Capture keyboard state at this point. - -- Check if both up and left arrows are pressed in the captured state - if (inkeystate(ks, scancodes.up) and inkeystate(ks, scancodes.left)) then + if inkeystate(ks, scancodes.up) then + let y = (y - 1) + endif + if inkeystate(ks, scancodes.down) then + let y = (y + 1) + endif + if inkeystate(ks, scancodes.left) then + let x = (x - 1) + endif + if inkeystate(ks, scancodes.right) then + let x = (x + 1) + endif + if inkeystate(ks, scancodes.x) then break endif endloop diff --git a/docs/ide.md b/docs/ide.md --- a/docs/ide.md +++ b/docs/ide.md @@ -4,12 +4,14 @@ 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. +IDE. If such a file does not exist, then it is created upon saving the program from +the IDE. #### 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. +For example 'spade run myprog.spd' just runs the "myprog.spd" spade program without +loading it in the IDE. ##### Menu @@ -22,13 +24,22 @@ and debug information. Contents of the log window can be cleared by the "Clear log" menu item. The watch window appears when stepping through the program, and displays the contents of the current -functions scope. +function's scope. ##### Debugging A program can be started in step mode by pressing 'F8' or selecting the step menu item. By pressing the 'F8' key it is possible to step through the program, expression by expression. The currently evaluated line is indicated by a '>' in the left margin, and the currently evaluated expression is indicated by -underlining it. +an underline. A program can call the `debug()` function at any point to break into the debugger. + +##### Shortcuts + +F1 -> Help +F6 -> Save +F8 -> Run program in single step mode +F5 -> Run program +F9 -> Kill program execution and return to IDE +Esc -> Go back to previous help page diff --git a/docs/language-reference.md b/docs/language-reference.md --- a/docs/language-reference.md +++ b/docs/language-reference.md @@ -116,12 +116,74 @@ println(multiply(5, 2)) ``` +### Anonymous functions or Lambdas + +You can create anonymous function using the `fn` keyword. Example where +a callback using an anonymous function is passed to the `filter` function. + +``` +let mylist = [2, 3, 4, 5, 6] +let filtered = filter(mylist, fn(x) mod(x, 2) == 0 endfn) +``` + +Anonymous functions can contain only a single expression. + +### Scoping + +Variables assigned at the top level are globals and are available +inside functions without special syntax. + +For example, the program below will print `10` when executed. + +``` +let a = 10 + +proc myProc() + println(a) +endproc + +myProc() +``` + +There is a caveat to this though. Global variables defined below a +function call will not be available inside the function. For example +the following program results in an "Unknown symbol reference" error. + +``` +proc myProc() + println(a) +endproc + +myProc() + +let a = 10 +-- ^ Global variable `a` defined after `myProc` call. Variable `a` +-- is not available inside `myProc`. +``` + +#### Closures + +When a function returns an unnamed function, the returned function holds +a copy of the parent functions local scope. For example, the following function +prints `10 20` + +``` +proc myFunc(x) + return fn() print(x, " ") endfn +endproc + +let fn1 = myFunc(10) +let fn2 = myFunc(20) + +fn1() +fn2() +``` + ### Expressions Expressions are things that can be evaluated to a value. Following types of expressions are available in the language. - #### Literals The language support the following literals. @@ -135,12 +197,12 @@ Dictionary -> `{name : "John", age: 34}` Anonymous function -> `fn(x) x * 2 endfn` -#### Variables +#### Variable expression These refer to a variable, and evaluate to the same value that is held by the variable. -#### If-then-else +#### Conditional expression These provide conditional evaluation, for example. @@ -148,7 +210,7 @@ let x = if x == 0 then 1 else x ``` -#### Binary operators +#### Binary expression The following binary operators are available. @@ -186,7 +248,7 @@ #### Index access -An index in a list expression can be accessed using the index accessor. +An index in a list/string/bytes expression can be accessed using the index accessor. For example, ``` @@ -194,7 +256,7 @@ print(list[2]) -- prints 2. ``` -NOTE: List indexes starts from 1. +NOTE: Indexes starts from 1. Index accessor can be attached to any expression, for example a function returning a list. For example, @@ -206,6 +268,31 @@ print(myFunc()[2]) -- prints 2. ``` +You can modify values using indexes too. + +``` +let list = [1,2,3,4] +let list[2] = 10 +print(list[2]) -- prints 10 +``` + +This works similarly for bytes and texts. + +``` +let b = 0xffff +let b[2] = 0 +print(b) -- prints 0xff00 +``` + +and for strings + + +``` +let b = "abcd" +let b[2] = "e" +print(b) -- prints "aecd" +``` + #### Key access An key in a dictionary expression can be accessed using the key accessor. @@ -214,7 +301,10 @@ ``` let person = { name: "John", age : 39 } print(person.name) -- prints "John" -print(person.age) -- prints 39 +print(person["age"]) -- prints 39 + +let k = "age" +print(person[k]) -- prints 39 ``` Key accessor can be attached to any expression, for example a function diff --git a/docs/toc.md b/docs/toc.md --- a/docs/toc.md +++ b/docs/toc.md @@ -12,14 +12,16 @@ IDE Reference #link: Menu# #link: Windows# + #link: Shortcuts# #link: Debugging# -Language Reference +#link: Language Reference# #link: Variables# + #link: Scoping# #link: Expressions# #link: Literals# - #link: Variables# - #link: Conditionals# - #link: Binary operators# + #link: Variable expression# + #link: Conditional expression# + #link: Binary expression# #link: Numeric operators# #link: Boolean operators# #link: Function calls# @@ -36,8 +38,6 @@ #link: Functions/Procedures# #link: Builtin data types# #link: Graphics and Animation# - #link: Accelerated mode# - #link: Clearing screen# #link: Working with screens of different resolutions# #link: Keyboard input handling# Function References diff --git a/samples/filechecker.spd b/samples/filechecker.spd new file mode 100644 --- /dev/null +++ b/samples/filechecker.spd @@ -0,0 +1,193 @@ +proc getNumberSelection() + loop + let selection = try(stringtonum(csinputline("Please enter your selection?")), 0) + csdraw() + if (selection !== 0) then + return selection + endif + endloop +endproc + +proc selectActionScreen() + println("What do you want to do?") + println("1. Add files to the catalog") + println("2. Check files in catalog") + println("3. Mount sources") + if (selection == 1) then + return "ADD_FILES" + elseif (selection == 2) then + return "CHECK_FILES" + elseif (selecton == 3) then + return "MOUNT_SOURCE" + endif +endproc + +proc getCatalogPath() + return inputline("\nPlease enter path to catalog: ") +endproc + +proc readCatalog(cp) + return jsondecode(readfile(cp)) +endproc + +proc selectPath(dirsonly) + let current_path = getcurrentdir() + loop + csclear() + csgoto(0, 0) + csprintln("Select path to ", (if (dirsonly) then "directory" else "file"), " :") + csprintln("===================") + csprintln("Current selected: ", current_path) + csprintln("") + csprintln("Select action or path") + csprintln("---------------------") + let dh = opendir(current_path) + let subdirs = [] + foreach dh as ditem + if dirsonly then + if (ditem.type == "dir") then + let subdirs = insertright(subdirs, ditem) + endif + else + let subdirs = insertright(subdirs, ditem) + endif + endforeach + csprintln(1, ". Proceed") + csprintln(2, ". Go up") + let offset = 2 + let i = offset + foreach subdirs as subdir + let i = (i + 1) + csprintln(i, ". ", subdir.path) + endforeach + csdraw() + let selection = getNumberSelection() + if (selection == 1) then + return current_path + elseif (selection == 2) then + let current_path = takedirectory(current_path) + else + let realindex = (selection - offset) + if ((realindex <= size(subdirs)) and (realindex > 0)) then + let di = subdirs[realindex] + if (di.type == "dir") then + let current_path = di.path + else + return di.path + endif + endif + endif + csdraw() + endloop +endproc + +proc checkfile(filehash, path) + let currentpos = csget() + csgoto(0, currentpos.y) + let fh = openfilehandle(path, "r") + let filesize = gethandlesize(fh) + csprintln("Checking file:", path) + csprintln("Size:", filesize) + csclearline() + let hctx = hashinit("md5") + let readbytes = 0 + loop + let chunk = readfilehandle(fh, 4096) + let hctx = hashupdate(hctx, chunk) + if (size(chunk) == 0) then + let finalhash = hexencode(hashfinalize(hctx)) + if (finalhash == filehash) then + csprintln("OK") + else + csprintln("HASH MISMATCH!") + csdraw() + wait(1) + endif + break + else + let readbytes = readbytes + size(chunk) + csgoto(0, currentpos.y + 2) + csclearline() + let p = round(readbytes/filesize * 100) + csprintln("Hashing: ", take(round(p/10), "=========="), " ", p, "%") + csclearline() + csdraw() + endif + endloop + csdraw() + csgoto(currentpos.x, currentpos.y) +endproc + +proc mainscreen(catalogref, mountedpathsref) + let catalogpath = readref(catalogref) + let mountedpaths = readref(mountedpathsref) + csclear() + csgoto(0, 0) + csprintln("Catalog path = ", (if ((catalogpath == "")) then "(empty)" else catalogpath)) + csprintln("Mounted paths:") + csprintln("") + let i = 0 + foreach mountedpaths as mp + let i = (i + 1) + csprintln(i, ". ", mp.key, " -> ", mp.value) + endforeach + csprintln("-----------------") + csprintln("Selection action") + csprintln("-----------------") + csprintln("1. Select catalog path") + csprintln("2. Mount sources") + csprintln("3. Run check") + csprintln("4. Add files") + csprintln("5. Exit") + let selection = getNumberSelection() + if (selection == 1) then + let catalogPath = selectPath(false) + writeref(catalogref, catalogPath) + return 0 + elseif (selection == 2) then + let mountsource = selectPath(false) + if (takebasename(mountsource) == "PMSRCID") then + let pmsrcid = trim(readtextfile(mountsource)) + let currentpaths = readref(mountedpathsref) + writeref(mountedpathsref, addkey(currentpaths, pmsrcid, takedirectory(mountsource))) + endif + return 0 + elseif (selection == 3) then + let catalogPath = readref(catalogref) + let mountedPaths = readref(mountedpathsref) + if (catalogPath !== "") then + let catalog = readCatalog(catalogPath) + foreach catalog as v + foreach v.value as s + if haskey(mountedPaths, s.key) then + foreach s.value as si + checkfile(v.key, joinpaths(mountedPaths[s.key], si)) + endforeach + endif + endforeach + wait(0.001) + endforeach + endif + return 0 + elseif (selection == 4) then + break + else + return -1 + endif + csdraw() +endproc +csinit() +let catalogpathref = newref("") +let mountedpathsref = newref({}) +loop + if (mainscreen(catalogpathref, mountedpathsref) == -1) then + break + endif +endloop +getkey() +-- let catalogPath = getCatalogPath() +-- let catalogPath = selectPath(false) +-- csclear() +-- csprintln("Catalog path = ", catalogPath) +-- csdraw() +-- getkey() diff --git a/samples/paratrooper.spd b/samples/paratrooper.spd --- a/samples/paratrooper.spd +++ b/samples/paratrooper.spd @@ -58,7 +58,7 @@ let total_x = 0 let total_y = 0 let p = [] - foreach pi as i + foreach pi as i let p = insertright(p, [(i[1] / 4), (i[2] / 4)]) endforeach for i = 1 to size(p) @@ -93,7 +93,7 @@ proc drawtrooper(trooper) setcolor(0, 255, 0) let tps = [] - foreach trooperpoints_s as tp + foreach trooperpoints_s as tp let tps = insertright(tps, [(tp[1] + trooper.x), (tp[2] + trooper.y)]) endforeach lines(tps) @@ -123,7 +123,7 @@ 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 + 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 @@ -135,7 +135,7 @@ endfor for i = 1 to size(gs.troopers) let gs.troopers[i].y = (gs.troopers[i].y + (100 * et)) - foreach gs.bullets as b + 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 @@ -200,13 +200,13 @@ for i = 1 to size(gs.helicopters) drawhelicopter(gs.helicopters[i], 1000) endfor - foreach gs.troopers as trooper + foreach gs.troopers as trooper drawtrooper(trooper) endforeach - foreach gs.fragments as f + 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() + render() endproc diff --git a/samples/snake.spd b/samples/snake.spd --- a/samples/snake.spd +++ b/samples/snake.spd @@ -18,7 +18,7 @@ then let snake = growsnake(snake) let food = {x : random(0, 900), y: random(0, 900) } endif -drawscreen() +render() let keys = getkeystate() if inkeystate(keys, scancodes.q) then break endif if inkeystate(keys, scancodes.down) then diff --git a/spade.cabal b/spade.cabal --- a/spade.cabal +++ b/spade.cabal @@ -1,11 +1,11 @@ cabal-version: 2.2 --- This file has been generated from package.yaml by hpack version 0.34.6. +-- This file has been generated from package.yaml by hpack version 0.35.0. -- -- see: https://github.com/sol/hpack name: spade -version: 0.1.0.6 +version: 0.1.0.7 synopsis: A simple programming and debugging environment. description: A simple weakly typed, dynamic, interpreted programming langauge and terminal IDE. category: language, interpreter, ide @@ -39,6 +39,7 @@ stack.yaml stack.yaml.lock samples/char-animation.spd + samples/filechecker.spd samples/mandelbrot.spd samples/paratrooper.spd samples/snake.spd @@ -75,6 +76,8 @@ Interpreter.Initialize Interpreter.Interpreter Interpreter.Lib.Concurrency + Interpreter.Lib.Crypto + Interpreter.Lib.FileSystem Interpreter.Lib.Math Interpreter.Lib.Misc Interpreter.Lib.SDL @@ -97,6 +100,13 @@ UI.Widgets.MenuContainer UI.Widgets.NullWidget UI.Widgets.OutputContainer + UI.Widgets.Spade.Button + UI.Widgets.Spade.Input + UI.Widgets.Spade.Layout + UI.Widgets.Spade.RefLabel + UI.Widgets.Spade.Selector + UI.Widgets.Spade.TextContainer + UI.Widgets.Spade.TextLabel UI.Widgets.TextContainer UI.Widgets.TitledContainer UI.Widgets.WatchWidget @@ -152,36 +162,42 @@ InstanceSigs ghc-options: -Wall -Wno-type-defaults build-depends: - 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 >=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 - , with-utf8 >=1.0.2 && <1.1 + Decimal + , WAVE + , aeson + , ansi-terminal + , base >=4.16.3 && <4.17 + , bytestring + , constraints + , containers + , cryptonite + , directory + , exceptions + , file-embed + , filepath + , hedgehog + , hex-text + , hspec + , hspec-hedgehog + , memory + , monad-loops + , mtl + , ordered-containers + , process + , random + , regex-tdfa + , scientific + , sdl2 + , sdl2-mixer + , stm + , template-haskell + , terminal + , text + , time + , unix + , unordered-containers + , vector + , with-utf8 default-language: Haskell2010 autogen-modules: Paths_spade @@ -239,37 +255,43 @@ InstanceSigs ghc-options: -Wall -Wno-type-defaults -threaded -fPIC build-depends: - 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 >=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 + Decimal + , WAVE + , aeson + , ansi-terminal + , base >=4.16.3 && <4.17 + , bytestring + , constraints + , containers + , cryptonite + , directory + , exceptions + , file-embed + , filepath + , hedgehog + , hex-text + , hspec + , hspec-hedgehog + , memory + , monad-loops + , mtl + , ordered-containers + , process + , random + , regex-tdfa + , scientific + , sdl2 + , sdl2-mixer , spade - , 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 - , with-utf8 >=1.0.2 && <1.1 + , stm + , template-haskell + , terminal + , text + , time + , unix + , unordered-containers + , vector + , with-utf8 default-language: Haskell2010 autogen-modules: Paths_spade @@ -342,38 +364,44 @@ InstanceSigs ghc-options: -Wall -Wno-type-defaults build-depends: - 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 >=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 + Decimal + , WAVE + , aeson + , ansi-terminal + , base >=4.16.3 && <4.17 + , bytestring + , constraints + , containers + , cryptonite + , directory + , exceptions + , file-embed + , filepath , hedgehog - , hex-text >=0.1.0 && <0.2 + , hex-text , hspec , hspec-discover , hspec-hedgehog - , monad-loops >=0.4.3 && <0.5 - , mtl >=2.2.2 && <2.3 + , memory + , monad-loops + , mtl , neat-interpolation - , 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 + , ordered-containers + , process + , random + , regex-tdfa + , scientific + , sdl2 + , sdl2-mixer , spade - , stm >=2.5.0 && <2.6 + , stm , strip-ansi-escape - , 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 - , with-utf8 >=1.0.2 && <1.1 + , template-haskell + , terminal + , text + , time + , unix + , unordered-containers + , vector + , with-utf8 default-language: Haskell2010 diff --git a/src/Common.hs b/src/Common.hs --- a/src/Common.hs +++ b/src/Common.hs @@ -5,6 +5,7 @@ import Control.Concurrent import Control.Exception +import Control.Monad.IO.Class import Control.Monad import Data.List as DL import Data.Text as T @@ -112,8 +113,8 @@ indent :: Int -> Text indent i = T.replicate i " " -instance HasLog IO where - appendLog a = void $ try @SomeException (T.appendFile "/tmp/spade.log" $ pack (show a <> "\n")) +instance MonadIO m => HasLog m where + appendLog a = liftIO $ void $ try @SomeException (T.appendFile "/tmp/spade.log" $ pack (show a <> "\n")) genericPairWithTokens :: (a -> Int) -> (a -> Location) -> Int -> Text -> [a] -> ([(Text, Maybe a)], [a]) genericPairWithTokens _ _ _ "" [] = ([], []) diff --git a/src/Compiler/AST/Expression.hs b/src/Compiler/AST/Expression.hs --- a/src/Compiler/AST/Expression.hs +++ b/src/Compiler/AST/Expression.hs @@ -88,7 +88,7 @@ | ECall Identifier [ExpressionWithLoc] Bool -- Boolean is used during execution to mark tail calls | EConditional ExpressionWithLoc ExpressionWithLoc ExpressionWithLoc | EParan ExpressionWithLoc - | EUnnamedFn (Maybe (NonEmpty Identifier)) ExpressionWithLoc + | EUnnamedFn [Identifier] ExpressionWithLoc | ENegated ExpressionWithLoc deriving (Show) @@ -134,8 +134,8 @@ EUnnamedFn args expr -> let argsSrc = case args of - Just args' -> T.intercalate ", " (toSource <$> (NE.toList args')) - Nothing -> "" + [] -> "" + args'@(_:_) -> T.intercalate ", " (toSource <$> args') in T.concat [toSource KwFn, ws, toSource DlParenOpen, argsSrc, toSource DlParenClose, ws, toSource expr, ws, toSource KwEndFn] where @@ -156,7 +156,7 @@ , ECall <$> getGen <*> (list (linear 1 2) getGen) <*> (pure False) , EConditional <$> getGen <*> getGen <*> getGen , EParan <$> getGen - , EUnnamedFn <$> (C.maybe (nonEmptyGen getGen)) <*> getGen + , EUnnamedFn <$> (list (linear 0 2) getGen) <*> getGen ] addLRecursion :: ExpressionWithLoc -> AstParser ExpressionWithLoc @@ -199,7 +199,9 @@ unnamedFnParser :: AstParser Expression unnamedFnParser = surroundWs $ do surroundWs_ (parseKeyword KwFn) - args <- parseItemListInParen parseIdentifier + args <- parseItemListInParen parseIdentifier >>= \case + Just x -> pure $ NE.toList x + Nothing -> pure [] expr <- mandatory (surroundWs (astParser @ExpressionWithLoc)) mandatory $ surroundWs_ $ parseKeyword KwEndFn pure $ EUnnamedFn args expr diff --git a/src/Compiler/AST/FunctionStatement.hs b/src/Compiler/AST/FunctionStatement.hs --- a/src/Compiler/AST/FunctionStatement.hs +++ b/src/Compiler/AST/FunctionStatement.hs @@ -47,11 +47,13 @@ | Loop (NonEmpty FunctionStatementWithLoc) | Return ExpressionWithLoc | Break + | Pass | FnComment Comment deriving (Show, Eq) instance ToSource FunctionStatement where toSourcePretty i Break = T.concat [indent i, toSource KwBreak] + toSourcePretty i Pass = T.concat [indent i, toSource KwPass] toSourcePretty i (FnComment c) = stripEnd (toSourcePretty i c) toSourcePretty i (Let idf expr) = T.concat [indent i, toSource KwLet, wst, toSource idf, wst, toSource KwAssignment, wst, toSource expr] @@ -118,6 +120,7 @@ , Return <$> getGen , FnComment <$> getGen , pure Break + , pure Pass ] [ If <$> getGen <*> (nonEmptyGen getGen) <*> (nonEmptyGen getGen) , IfThen <$> getGen <*> (nonEmptyGen getGen) @@ -142,6 +145,7 @@ <|> loopParser <|> returnParser <|> breakParser + <|> passParser <|> callStatementParser <|> (FnComment <$> (surroundWs parseComment)) @@ -241,3 +245,8 @@ breakParser = nameParser "break statement" $ do surroundWs_ (parseKeyword KwBreak) pure Break + +passParser :: AstParser FunctionStatement +passParser = nameParser "pass statement" $ do + surroundWs_ (parseKeyword KwPass) + pure Pass diff --git a/src/Compiler/Lexer/Keywords.hs b/src/Compiler/Lexer/Keywords.hs --- a/src/Compiler/Lexer/Keywords.hs +++ b/src/Compiler/Lexer/Keywords.hs @@ -30,6 +30,7 @@ | KwTo | KwReturn | KwAssignment + | KwPass | KwFn -- We don't want to generate this in automatic tests because of the lookahead for ( deriving (Show, Lift,Eq, Enum, Bounded) @@ -57,6 +58,7 @@ <|> parseFor KwEndProc <|> parseFor KwTo <|> parseFor KwReturn + <|> parseFor KwPass <|> parseFor KwAssignment where parseFor :: Keyword -> Parser Keyword @@ -100,6 +102,7 @@ KwEndLoop -> "endloop" KwTo -> "to" KwReturn -> "return" + KwPass -> "pass" KwAssignment -> "=" instance HasGen Keyword where diff --git a/src/DiffRender/DiffRender.hs b/src/DiffRender/DiffRender.hs --- a/src/DiffRender/DiffRender.hs +++ b/src/DiffRender/DiffRender.hs @@ -4,82 +4,51 @@ import Control.Monad.IO.Class import Data.List as DL import Data.Text as T -import Data.Text.IO as T import Data.Vector.Mutable (IOVector) import qualified Data.Vector.Mutable as MV import System.Console.ANSI (Color(..), ColorIntensity(..), ConsoleLayer(..), SGR(..), Underlining(..), setSGRCode) -import qualified System.Console.ANSI as A -import qualified System.IO as S import Test.Common data DiffRender = DiffRender { dfScreenStateBack :: ScreenState , dfScreenState :: ScreenState + , dfDebug :: Bool } emptyDiffRender :: Dimensions -> IO DiffRender emptyDiffRender Dimensions { diH = rows, diW = cols } = do ss <- emptyScreenState rows cols ssBack <- emptyScreenState rows cols - pure $ DiffRender { dfScreenStateBack = ssBack, dfScreenState = ss } + pure $ DiffRender { dfScreenStateBack = ssBack, dfScreenState = ss, dfDebug = False } emptyScreenState :: Int -> Int -> IO ScreenState emptyScreenState rows cols = do stLines <- MV.generate rows (\_ -> [Plain (T.replicate cols " ")]) pure (ScreenState stLines (ScreenPos 0 0) cols True) -dfSetCursorPosition :: Int -> Int -> DiffRender -> DiffRender -dfSetCursorPosition x y dfr = +dfGetCursorPosition :: DiffRender -> ScreenPos +dfGetCursorPosition dfr = ssCursorPos $ dfScreenStateBack dfr + +dfSetCursorPosition :: (Int -> Int) -> (Int -> Int) -> DiffRender -> DiffRender +dfSetCursorPosition fx fy dfr = let screenState = dfScreenStateBack dfr screenLines = ssLines screenState screenColumns = ssColumns screenState + x = fx $ sX $ ssCursorPos $ dfScreenStateBack dfr + y = fy $ sY $ ssCursorPos $ dfScreenStateBack dfr in if (x >= 0 && x < screenColumns) && (y >= 0 && y < (MV.length screenLines)) then dfr { dfScreenStateBack = screenState { ssCursorOverflow = False, ssCursorPos = ScreenPos x y }} else dfr { dfScreenStateBack = screenState { ssCursorOverflow = True }} dfPutText :: MonadIO m => StyledText -> DiffRender -> m () -dfPutText t (DiffRender { dfScreenStateBack = ScreenState {ssLines = ssLns, ssCursorOverflow = cursorOverflow, ssCursorPos = ScreenPos cx cy} }) = do +dfPutText t (DiffRender { dfDebug = _, dfScreenStateBack = ScreenState {ssLines = ssLns, ssCursorOverflow = cursorOverflow, ssCursorPos = ScreenPos cx cy} }) = do -- Write stuff to the backbuffer. If the cursor is in an overflow position, then do nothing. if cursorOverflow then pure () else liftIO $ flip (MV.modify ssLns) cy $ \l -> stInsert l cx t -dfDraw :: MonadIO m => Maybe (ScreenPos, Dimensions) -> DiffRender -> m DiffRender -dfDraw mScreenParams dfr@(DiffRender { dfScreenStateBack = (ssLines -> ssb), dfScreenState = (ssLines -> ss) }) = do - let - (screenOffsetX, screenOffsetY) = case mScreenParams of - Just (sp, _) -> (sX sp, sY sp) - Nothing -> (0, 0) - - liftIO $ MV.imapM_ (\idx neLine -> do - oldLine <- MV.read ss idx - if (oldLine /= neLine) - then do - A.setCursorPosition (idx + screenOffsetY) screenOffsetX - -- mapM_ (\x -> do T.putStr x; S.hFlush stdout; threadDelay 10000;) (stRender <$> neLine) - mapM_ T.putStr (stRender <$> neLine) - S.hFlush S.stdout - else pure () - ) ssb - pure $ dfr { dfScreenState = dfScreenStateBack dfr, dfScreenStateBack = dfScreenState dfr } - -dfClear :: MonadIO m => DiffRender -> m () -dfClear dfIn = do - let bb = dfScreenStateBack dfIn - liftIO $ MV.set (ssLines bb) [Plain (T.replicate (ssColumns bb) " ")] - -dfInitialize :: MonadIO m => Dimensions -> DiffRender -> m DiffRender -dfInitialize (Dimensions cols rows) dfIn = do - -- Initialize the screen memory for the dimensions - -- and initialize to whitespaces. - (ss, ssBack) <- liftIO $ do - ss <- emptyScreenState rows cols - ssBack <- emptyScreenState rows cols - pure (ss, ssBack) - pure $ dfIn { dfScreenStateBack = ssBack, dfScreenState = ss} - data ScreenState = ScreenState { ssLines :: IOVector [StyledText] , ssCursorPos :: ScreenPos @@ -89,6 +58,10 @@ screenStateDimension :: ScreenState -> Dimensions screenStateDimension ScreenState {..} = Dimensions ssColumns (MV.length ssLines) + +copyScreenState :: ScreenState -> ScreenState -> IO () +copyScreenState sss ssd = + MV.copy (ssLines ssd) (ssLines sss) diffRenderToDimension :: DiffRender -> Dimensions diffRenderToDimension DiffRender {..} = screenStateDimension dfScreenState diff --git a/src/IDE/Help.hs b/src/IDE/Help.hs --- a/src/IDE/Help.hs +++ b/src/IDE/Help.hs @@ -1,29 +1,29 @@ module IDE.Help where -import Compiler.Lexer.Keywords (Keyword) -import Compiler.Lexer.Operators (Operator) -import Control.Concurrent -import Control.Concurrent.STM (atomically) -import Control.Concurrent.STM.TChan -import Control.Monad as CM -import qualified Data.ByteString as BS -import Data.IORef -import qualified Data.List as DL -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Data.Text as T -import Data.Text.Encoding (decodeUtf8) -import Data.Vector as V +import Compiler.Lexer.Keywords (Keyword) +import Compiler.Lexer.Operators (Operator) +import Control.Concurrent +import Control.Concurrent.STM (atomically) +import Control.Concurrent.STM.TChan +import Control.Monad as CM +import qualified Data.ByteString as BS +import Data.IORef +import qualified Data.List as DL +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8) +import Data.Vector as V -import Common -import Compiler.AST.Program -import Compiler.Parser -import IDE.Common -import IDE.Help.Contents -import IDE.Help.Parser -import UI.Widgets -import UI.Widgets.Layout -import UI.Widgets.NullWidget +import Common +import Compiler.AST.Program +import Compiler.Parser +import IDE.Common +import IDE.Help.Contents +import IDE.Help.Parser +import UI.Widgets +import UI.Widgets.Layout +import UI.Widgets.NullWidget newtype SearchPage = SearchPage Text deriving (Show, Eq) @@ -105,6 +105,8 @@ 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 PageUp -> handleInput (hwContentWidget w) ke + KeyCtrl False _ False PageDown -> handleInput (hwContentWidget w) ke KeyCtrl False False False Return -> do tokens <- liftIO $ readIORef (hwTokensRef w) case V.find (\case @@ -135,7 +137,7 @@ where hasKeyCombination (KeyCtrl False False False _) = False hasKeyCombination (KeyChar False False False _) = False - hasKeyCombination _ = True + hasKeyCombination _ = True instance Moveable HelpWidget where move r pos = do @@ -286,13 +288,16 @@ helpWidget :: WidgetC m => [Text] -> TChan IDEEvent -> m (WRef HelpWidget) helpWidget builtins ideEventRef = do -- The help window - let helpWidgetDimDistrbution = \case - 1 -> [1] - 2 -> [0, 1] - _ -> error "Unsupported widget count" - let helpWidgetTopDimDistrbution = \case - 2 -> [0.1, 0.9] - _ -> error "Unsupported widget count" + let helpWidgetDimDistrbution = [ + undefined + , [1] + , [0, 1] + ] + let helpWidgetTopDimDistrbution = + [ undefined + , undefined + , [0.1, 0.9] + ] cursorRef <- liftIO $ newMVar @Int 0 searchResultRef <- liftIO newEmptyMVar searchChan <- liftIO (newTChanIO @SearchPage) @@ -307,10 +312,10 @@ helpContent <- editor (\_ -> pure []) (Just $ SomeTokenStream (V.toList <$> readIORef tokensRef)) modifyWRef helpSearchInput (\hw -> hw { ewParams = (ewParams hw) { epBorder = True, epGutterSize = 0, epLineNos = False} }) modifyWRef helpContent (\hw -> hw { ewShowVirtualCursor = True, ewParams = (ewParams hw) { epLineNos = False} }) - addWidget helptopLayoutRef "helpsearchinput" helpSearchInput - (newWRef nullWidget) >>= addWidget helptopLayoutRef "helpsearchspacer" - addWidget helpLayoutRef "helpsearch" helptopLayoutRef - addWidget helpLayoutRef "helpcontent" helpContent + addWidget helptopLayoutRef helpSearchInput + (newWRef nullWidget) >>= addWidget helptopLayoutRef + addWidget helpLayoutRef helptopLayoutRef + addWidget helpLayoutRef helpContent docs <- liftIO parsedDocContent let docIndex = buildIndex docs void $ liftIO $ forkIO (searchThread docIndex searchChan searchResultRef) diff --git a/src/IDE/IDE.hs b/src/IDE/IDE.hs --- a/src/IDE/IDE.hs +++ b/src/IDE/IDE.hs @@ -64,12 +64,6 @@ type IDEM a = WidgetM IO a -editorId :: Text -editorId = "editor" - -watchWidgetId :: Text -watchWidgetId = "watch" - putStrLnFlush :: Text -> IO () putStrLnFlush s = do T.putStrLn s @@ -185,17 +179,19 @@ watchWidgetRef <- watchWidget titledWatchRef <- titledContainer (SomeWidgetRef watchWidgetRef) " Watch " - let dimensionDistributionFnMain = \case - 1 -> [1] - 2 -> [0.5, 0.5] - a -> error $ "Unsupported widget count:" <> show a + let dimensionDistributionFnMain = + [ undefined + , [1] + , [0.5, 0.5] + ] - 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 + let dimensionDistributionFn = + [ undefined + , [1] + , [0.85, 0.15] + , [0.70, 0.15, 0.15] + , [0.55, 0.15, 0.15, 0.15] + ] logRef <- logWidget titledLogRef <- titledContainer (SomeWidgetRef logRef) " Log " @@ -207,7 +203,7 @@ -- The aboutbox widget aboutText <- textContainer (ScreenPos 0 0) (Dimensions 58 12) - let versionString = T.intercalate "." $ ((T.pack . show) <$> versionBranch version) + let versionString = T.intercalate "." ((T.pack . show) <$> versionBranch version) let aboutContent = (T.replicate 24 " ") <> "S.P.A.D.E" <> "\n" @@ -228,13 +224,13 @@ modifyWRef layoutRef (\lw -> lw { lowFloatingContent = [SomeWidgetRef ac] }) modifyWRef layoutRef' (\lw -> lw { lowFloatingContent = [SomeWidgetRef aboutBox] }) - addWidget layoutRef editorId editorRef - addWidget layoutRef "helpwidget" helpWidgetRef - addWidget layoutRef "watch" titledWatchRef - addWidget layoutRef "log" titledLogRef + addWidget layoutRef editorRef + addWidget layoutRef helpWidgetRef + addWidget layoutRef titledWatchRef + addWidget layoutRef titledLogRef - addWidget layoutRef' "editorlayout" layoutRef - addWidget layoutRef' "output" titledOutputRef + addWidget layoutRef' layoutRef + addWidget layoutRef' titledOutputRef setVisibility helpWidgetRef False setVisibility titledWatchRef False @@ -258,7 +254,7 @@ ideRedraw = do csClear draw menuContainerRef - csDraw + csDraw Nothing let getActiveEditor :: WidgetC m => m (WRef EditorWidget) @@ -282,7 +278,7 @@ pure (programOutputHandleW, outputPos, screenSize, Just outBufLock) False -> do clearscreen - screenSize <- (diffRenderToDimension . usDiffRender) <$> get + screenSize <- diffRenderToDimension <$> getDiffRender pure (SIO.stdout, ScreenPos 0 0, screenSize, Nothing) liftIO $ do compileEither source >>= \case @@ -382,7 +378,7 @@ d <- getScreenBounds csInitialize d draw menuContainerRef - csDraw + csDraw Nothing pure True IDEStop -> do idsDebugEnv <$> (liftIO $ readTVarIO ideStateRef) >>= \case @@ -466,7 +462,7 @@ d <- getScreenBounds csInitialize d draw menuContainerRef - csDraw + csDraw Nothing pure True IDEACUpdateIdentifiers acs -> do liftIO $ atomically (modifyTVar ideStateRef (\is -> is { idsCodeAutocompletions = (\x -> (x, x)) <$> acs })) @@ -504,6 +500,7 @@ launchProgram >>= \case (Right ideDebugEnv, mStdoutLock) -> do insertLog logRef "Starting..." + clearOutput outputWidgetRef liftIO $ atomically $ do writeTBQueue (ideDebugIn ideDebugEnv) Start writeTVar inputRouteToRef (RouteProgram $ ideDebugThreadInputW ideDebugEnv) @@ -606,29 +603,30 @@ draw menuContainerRef adjustScrollOffset editorRef draw menuContainerRef - csDraw + csDraw Nothing pure True - IDETerminalEvent (TerminalKey ev) -> case ev of - KeyChar True _ _ 'c' -> pure False - KeyChar True _ _ 'C' -> pure False - k -> do - updateMenuOnKey ideEventsRef menuContainerRef k >>= \case - True -> pure () - False -> shortcutsHandler ideEventsRef k >>= \case + IDETerminalEvent (TerminalKey ev) -> do + case ev of + KeyChar True _ _ 'c' -> pure False + KeyChar True _ _ 'C' -> pure False + k -> do + updateMenuOnKey ideEventsRef menuContainerRef k >>= \case True -> pure () - False -> do - case k of - KeyCtrl _ _ _ Del -> liftIO $ atomically $ writeTChan ideEventsRef (IDEEdit Cut) - _ -> pass - idsKeyInputReciever <$> (liftIO $ readTVarIO ideStateRef) >>= \case - Just (SomeKeyInputWidget w) -> handleInput w k - Nothing -> pure () - idestate <- liftIO $ readTVarIO ideStateRef - case idsCodeParseError idestate of - Just (loc, _) -> modifyWRef editorRef (\ew -> ew { ewParseErrorLocation = Just loc }) - Nothing -> modifyWRef editorRef (\ew -> ew { ewParseErrorLocation = Nothing }) - ideRedraw - pure True + False -> shortcutsHandler ideEventsRef k >>= \case + True -> pure () + False -> do + case k of + KeyCtrl _ _ _ Del -> liftIO $ atomically $ writeTChan ideEventsRef (IDEEdit Cut) + _ -> pass + idsKeyInputReciever <$> (liftIO $ readTVarIO ideStateRef) >>= \case + Just (SomeKeyInputWidget w) -> handleInput w k + Nothing -> pure () + idestate <- liftIO $ readTVarIO ideStateRef + case idsCodeParseError idestate of + Just (loc, _) -> modifyWRef editorRef (\ew -> ew { ewParseErrorLocation = Just loc }) + Nothing -> modifyWRef editorRef (\ew -> ew { ewParseErrorLocation = Nothing }) + ideRedraw + pure True ) clearscreen setCursorPosition 0 0 diff --git a/src/Interpreter/Common.hs b/src/Interpreter/Common.hs --- a/src/Interpreter/Common.hs +++ b/src/Interpreter/Common.hs @@ -5,17 +5,19 @@ import Control.Concurrent.STM.TChan import Control.Concurrent.STM.TMVar import Control.Concurrent.STM.TSem +import Control.Concurrent.STM.TVar import Control.Exception import Control.Monad.Catch (MonadCatch, MonadThrow, throwM) +import Crypto.Hash import qualified Data.ByteString as BS import Data.IORef import Data.Kind (Type) -import Data.List.NonEmpty import Data.Map as M -import Data.Maybe (isJust) +import Data.Maybe (fromMaybe, isJust) import Data.Proxy import Data.Text as T import Data.Text.IO as T +import Data.Typeable import qualified Data.Vector as V import qualified Data.Vector.Storable as VS import Data.Word @@ -25,7 +27,9 @@ import SDL hiding (Keycode, Scancode, get) import qualified SDL as SDL import qualified SDL.Mixer as SDLM +import System.IO import qualified System.IO as SIO +import System.Posix.Directory import Text.Hex (encodeHex) import Common @@ -56,6 +60,7 @@ | Scancode SDL.Scancode | KeyboardState SDLKeyboardStateCallback | SoundSample Sample + | Texture SDL.Texture instance Show SDLValue where show (Keycode k) = "(SDL_KEY)" <> show k @@ -64,6 +69,7 @@ show (Color _) = "(SDL_COLOR)" show (Renderer _) = "(SDL_RENDERER)" show (SoundSample _) = "(SDL_SOUND)" + show (Texture _) = "(SDL_TEXTURE)" data Number = NumberInt IntType @@ -100,7 +106,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)) Scope ExpressionWithLoc +data UnNamedFn = UnNamedFn [Identifier] Scope ExpressionWithLoc deriving Show data ThreadInfo = ThreadInfo ThreadId (TMVar (Either SomeException Value)) @@ -113,11 +119,36 @@ instance Show ChannelRef where show _ = "(ConcurrencyChannel)" -newtype MutableRef = MutableRef (TMVar Value) +data MutableRef = MutableRef { mref :: (TMVar Value), mrsem :: TSem } instance Show MutableRef where show _ = "(MutableRef)" +newtype AbsoluteFilePath = AbsoluteFilePath FilePath deriving Show + +data DirStreamInfo = DirStreamInfo AbsoluteFilePath (Maybe DirStream) + +instance Show DirStreamInfo where + show (DirStreamInfo afp (Just _)) = show (afp, "Just _") + show (DirStreamInfo afp _) = show (afp, "Nothing") + +data DirHandleRef = DirHandleRef Bool (TVar [DirStreamInfo]) + +instance Show DirHandleRef where + show _ = "(Directory)" + +data HashContext = + MD5HashContext (Context MD5) + +instance Show HashContext where + show _ = "(HashContext)" + +data FileHandle = + FileHandle Handle + +instance Show FileHandle where + show _ = "(FileHandle)" + data Value = StringValue Text | NumberValue Number @@ -132,6 +163,11 @@ | ThreadRef ThreadInfo | Channel ChannelRef | Ref MutableRef + | DirectoryStack DirHandleRef + | FileHandleValue FileHandle + | WidgetValue SomeWidgetRef + | HashContextValue HashContext + | EventValue KeyEvent | 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. @@ -155,8 +191,13 @@ UnnamedFnValue _ -> "(unnamed_function)" Void -> "(void)" BuiltIn _ -> "(builtin)" + DirectoryStack _ -> "(directory)" + WidgetValue _ -> "(widget)" + HashContextValue _ -> "(hash_context)" + FileHandleValue _ -> "(file_handle)" s@(ErrorValue _) -> pack $ show s SDLValue s -> pack $ show s + EventValue ke -> pack $ show ke instance Ord Value where compare (NumberValue x) (NumberValue y) = compare x y @@ -235,26 +276,37 @@ 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. - , isInputHandle :: SIO.Handle - , isOutputHandle :: SIO.Handle - , isThreadName :: Text - , isDiffRender :: Maybe DiffRender - , isWidgetState :: Maybe WidgetState - , isTerminalParams :: Maybe (ScreenPos, Dimensions) - , isStdoutLock :: Maybe TSem + { 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 + , isDiffRender :: Maybe DiffRender + , isWidgetState :: Maybe WidgetState + , isTerminalParams :: Maybe (ScreenPos, Dimensions) + , isStdoutLock :: Maybe TSem , isDefaultPrintParams :: Maybe (Text, Int, [Int]) -- ^ This lock is required to sync stdout writing when the program -- is run from within the IDE and both IDE code and the interepreted -- program wants to write to stdout concurrently. } +instance MonadIO m => HasDiffRender (StateT InterpreterState m) where + getDiffRender = (fromMaybe (error "Char screen not initialized") . isDiffRender) <$> get + putDiffRender dfr = modify (\us -> us { isDiffRender = Just dfr }) + modifyDiffRender fn = modify (\us -> us { isDiffRender = fn <$> (isDiffRender us) }) + +instance MonadIO m => HasWidgetState (StateT InterpreterState m) where + getWidgetState = (fromMaybe (error "Widgets not initialized") . isWidgetState) <$> get + getWidgetStateMaybe = isWidgetState <$> get + putWidgetState ws = modify (\us -> us { isWidgetState = Just ws }) + modifyWidgetState fn = modify (\us -> us { isWidgetState = fn <$> isWidgetState us }) + instance Show InterpreterState where show InterpreterState {..} = show (isJust isDefaultWindow) @@ -275,6 +327,7 @@ , isStdoutLock = Nothing , isWidgetState = Nothing , isDefaultPrintParams = Nothing + -- ^ Some parameters that decides the comma placement when numbers are printed. } emptyIs :: IORef [SDL.Window] -> InterpreterState @@ -292,7 +345,7 @@ , isDiffRender = Nothing , isTerminalParams = Nothing , isStdoutLock = Nothing - , isWidgetState = Nothing + , isWidgetState = Just emptyWidgetState , isDefaultPrintParams = Just (".", 2, [3, 2, 2, 2, 2, 2, 2]) } @@ -331,9 +384,9 @@ mapGlobalScope :: (Scope -> Scope) -> (InterpreterState -> InterpreterState) mapGlobalScope fn = \is -> is { isGlobalScope = fn $ isGlobalScope is } -type InterpretM a = forall m. (MonadCatch m, MonadIO m) => StateT InterpreterState m a +type InterpretM a = forall m. (MonadCatch m, MonadIO m, Typeable m) => StateT InterpreterState m a -runInterpretM :: (MonadCatch m, MonadIO m) => InterpreterState -> InterpretM a -> m (a, InterpreterState) +runInterpretM :: (MonadCatch m, MonadIO m, Typeable 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 @@ -346,6 +399,26 @@ = CallbackUnNamed UnNamedFn | CallbackNamed Identifier +instance FromValue SomeWidgetRef where + fromValue (WidgetValue s) = s + fromValue a = throwErr $ UnexpectedType ("widget", a) + typeName = "widget" + +instance FromValue KeyEvent where + fromValue (EventValue s) = s + fromValue a = throwErr $ UnexpectedType ("event", a) + typeName = "event" + +instance FromValue Handle where + fromValue (FileHandleValue (FileHandle t)) = t + fromValue a = throwErr $ UnexpectedType ("file_handle", a) + typeName = "file_handle" + +instance FromValue HashContext where + fromValue (HashContextValue t) = t + fromValue a = throwErr $ UnexpectedType ("hash_context", a) + typeName = "hash_context" + instance FromValue (M.Map Text Value) where fromValue (ObjectValue t) = t fromValue a = throwErr $ UnexpectedType ("object", a) @@ -383,6 +456,11 @@ fromValue a = throwErr $ UnexpectedType ("filepath", a) typeName = "filepath" +instance FromValue SDL.Texture where + fromValue (SDLValue (Texture s)) = s + fromValue a = throwErr $ UnexpectedType ("texture", a) + typeName = "texture" + instance FromValue Sample where fromValue (SDLValue (SoundSample s)) = s fromValue a = throwErr $ UnexpectedType ("soundsample", a) @@ -446,6 +524,12 @@ fromValue a = throwErr $ UnexpectedType ("number", a) typeName = "integer" +instance FromValue CDouble where + fromValue (NumberValue (NumberInt i)) = realToFrac i + fromValue (NumberValue (NumberFractional i)) = realToFrac i + fromValue a = throwErr $ UnexpectedType ("fractional", a) + typeName = "fractional" + instance FromValue Double where fromValue (NumberValue (NumberInt i)) = realToFrac i fromValue (NumberValue (NumberFractional i)) = i @@ -489,15 +573,22 @@ fromValue a = throwErr $ UnexpectedType ("list", a) typeName = "list" -instance FromValue (Number, Number) where +instance (FromValue a, FromValue b) => FromValue (a, b) where typeName = "tuple" - fromValue (ArrayValue (V.toList -> ((NumberValue idx0) : (NumberValue idx1) : _))) = (idx0, idx1) + fromValue (ArrayValue (V.toList -> ((fromValue -> idx0) : (fromValue -> idx1) : _))) = (idx0, idx1) fromValue a = throwErr $ UnexpectedType ("list with two values", a) +instance FromValue Char where + typeName = "char" + fromValue = \case + StringValue x -> if T.length x == 1 then T.head x else throwErr $ CustomRTE "A string of length one char expected, but got many or none" + a -> throwErr $ UnexpectedType ("string", a) + instance FromValue Word8 where fromValue = \case (NumberValue (NumberInt i)) -> fromInt i (NumberValue (NumberFractional i)) -> fromInt (round i) + (BytesValue b) -> if BS.length b == 1 then BS.head b else throwErr $ CustomRTE "One byte expected, but got many or none" a -> throwErr $ UnexpectedType ("number", a) where fromInt i = if (fromIntegral i) <= (maxBound @Word8) then fromIntegral i else throwErr $ CustomRTE "Number too large to be converted to a byte" @@ -592,7 +683,7 @@ data RuntimeError = IOError Text | SDLError Text - | ListIndexOutOfBounds Int + | IndexOutOfBounds Int | KeyNotFound Text | UnserializeableValue | CustomRTE Text @@ -617,7 +708,7 @@ hReadable = \case IOError t -> "Input/Output error: " <> t SDLError t -> "SDL error: " <> t - ListIndexOutOfBounds t -> "Out of bound access of a list at index: " <> (T.pack $ show t) + Interpreter.Common.IndexOutOfBounds t -> "Out of bound access of index: " <> (T.pack $ show t) KeyNotFound t -> "Non-existing key access in dictionary at key: " <> t CustomRTE t -> "Run time error: " <> t UnserializeableValue -> "UnserializeableValue" @@ -703,8 +794,7 @@ putCommas pos' v' = T.reverse $ T.intercalate "," (splitPos pos' (T.reverse v')) splitPos :: [Int] -> Text -> [Text] - splitPos [] "" = [] - splitPos [] v' = [v'] - splitPos _ "" = [] + splitPos [] "" = [] + splitPos [] v' = [v'] + splitPos _ "" = [] splitPos (p: rs) v' = (T.take p v') : (splitPos rs (T.drop p v')) - diff --git a/src/Interpreter/Initialize.hs b/src/Interpreter/Initialize.hs --- a/src/Interpreter/Initialize.hs +++ b/src/Interpreter/Initialize.hs @@ -10,6 +10,8 @@ import Interpreter.Lib.String import Interpreter.Lib.Concurrency import Interpreter.Lib.SDL +import Interpreter.Lib.Crypto +import Interpreter.Lib.FileSystem loadBuiltIns :: InterpretM () loadBuiltIns = do @@ -30,6 +32,8 @@ insertBuiltInWithDoc (SkIdentifier $ Identifier "size") (SomeBuiltin valueSize) insertBuiltInWithDoc (SkIdentifier $ Identifier "contains") (SomeBuiltin contains) insertBuiltInWithDoc (SkIdentifier $ Identifier "haskey") (SomeBuiltin haskey) + insertBuiltInWithDoc (SkIdentifier $ Identifier "getkey") (SomeBuiltin getkey) + insertBuiltInWithDoc (SkIdentifier $ Identifier "addkey") (SomeBuiltin addkey) insertBuiltInWithDoc (SkIdentifier $ Identifier "filter") (SomeBuiltin filter_) insertBuiltInWithDoc (SkIdentifier $ Identifier "drop") (SomeBuiltin builtInDrop) insertBuiltInWithDoc (SkIdentifier $ Identifier "take") (SomeBuiltin builtInTake) @@ -44,15 +48,34 @@ insertBuiltInWithDoc (SkIdentifier $ Identifier "concat") (SomeBuiltin builtInConcat) insertBuiltInWithDoc (SkIdentifier $ Identifier "join") (SomeBuiltin builtInJoin) insertBuiltInWithDoc (SkIdentifier $ Identifier "split") (SomeBuiltin builtInSplit) + insertBuiltInWithDoc (SkIdentifier $ Identifier "trim") (SomeBuiltin builtInTrim) insertBuiltInWithDoc (SkIdentifier $ Identifier "formatamount") (SomeBuiltin builtInAmountFormat) + insertBuiltInWithDoc (SkIdentifier $ Identifier "replace") (SomeBuiltin builtInReplace) + insertBuiltInWithDoc (SkIdentifier $ Identifier "tolower") (SomeBuiltin builtInToLower) + insertBuiltInWithDoc (SkIdentifier $ Identifier "toupper") (SomeBuiltin builtInToUpper) -- Keyboard - insertBuiltInWithDoc (SkIdentifier $ Identifier "getkey") (SomeBuiltin waitForKey) + insertBuiltInWithDoc (SkIdentifier $ Identifier "waitforkey") (SomeBuiltin waitForKey) -- Files insertBuiltInWithDoc (SkIdentifier $ Identifier "readfile") (SomeBuiltin builtInReadFile) insertBuiltInWithDoc (SkIdentifier $ Identifier "readtextfile") (SomeBuiltin builtInReadTextFile) insertBuiltInWithDoc (SkIdentifier $ Identifier "writefile") (SomeBuiltin builtInWriteFile) + insertBuiltInWithDoc (SkIdentifier $ Identifier "opendir") (SomeBuiltin builtInOpenDir) + insertBuiltInWithDoc (SkIdentifier $ Identifier "getcurrentdir") (SomeBuiltin builtInGetCurrentDir) + insertBuiltInWithDoc (SkIdentifier $ Identifier "takefilename") (SomeBuiltin builtInTakeFilename) + insertBuiltInWithDoc (SkIdentifier $ Identifier "takedirectory") (SomeBuiltin builtInTakeDirectory) + insertBuiltInWithDoc (SkIdentifier $ Identifier "takeextension") (SomeBuiltin builtInTakeExtension) + insertBuiltInWithDoc (SkIdentifier $ Identifier "dropextension") (SomeBuiltin builtInDropExtension) + insertBuiltInWithDoc (SkIdentifier $ Identifier "takebasename") (SomeBuiltin builtInTakeBaseName) + insertBuiltInWithDoc (SkIdentifier $ Identifier "joinpaths") (SomeBuiltin builtInJoinPaths) + insertBuiltInWithDoc (SkIdentifier $ Identifier "openfilehandle") (SomeBuiltin builtInOpenFileHandle) + insertBuiltInWithDoc (SkIdentifier $ Identifier "readfilehandle") (SomeBuiltin builtInReadFileHandle) + insertBuiltInWithDoc (SkIdentifier $ Identifier "writefilehandle") (SomeBuiltin builtInWriteFileHandle) + insertBuiltInWithDoc (SkIdentifier $ Identifier "gethandlesize") (SomeBuiltin builtInGetFileSize) + insertBuiltInWithDoc (SkIdentifier $ Identifier "isfile") (SomeBuiltin builtInIsFile) + insertBuiltInWithDoc (SkIdentifier $ Identifier "isdirectory") (SomeBuiltin builtInIsDir) + insertBuiltInWithDoc (SkIdentifier $ Identifier "renamefile") (SomeBuiltin builtInRenameFile) -- Math insertBuiltInWithDoc (SkIdentifier $ Identifier "pow") (SomeBuiltin builtInPow) @@ -71,11 +94,16 @@ insertBuiltInWithDoc (SkIdentifier $ Identifier "insertleft") (SomeBuiltin builtInArrayInsertLeft) insertBuiltInWithDoc (SkIdentifier $ Identifier "insertright") (SomeBuiltin builtInArrayInsertRight) insertBuiltInWithDoc (SkIdentifier $ Identifier "head") (SomeBuiltin builtInHead) + insertBuiltInWithDoc (SkIdentifier $ Identifier "repeat") (SomeBuiltin builtInRepeat) -- Misc insertBuiltInWithDoc (SkIdentifier $ Identifier "try") (SomeBuiltin builtInTry) + insertBuiltInWithDoc (SkIdentifier $ Identifier "error") (SomeBuiltin builtInError) + insertBuiltInWithDoc (SkIdentifier $ Identifier "iserror") (SomeBuiltin builtInIsError) insertBuiltInWithDoc (SkIdentifier $ Identifier "jsondecode") (SomeBuiltin builtInJSONParse) insertBuiltInWithDoc (SkIdentifier $ Identifier "jsonencode") (SomeBuiltin builtInJSONSerialize) + insertBuiltInWithDoc (SkIdentifier $ Identifier "hexencode") (SomeBuiltin builtinEncodeBytes) + insertBuiltInWithDoc (SkIdentifier $ Identifier "hexdecode") (SomeBuiltin builtinDecodeBytes) insertBuiltInWithDoc (SkIdentifier $ Identifier "not") (SomeBuiltin not') insertBuiltInWithDoc (SkIdentifier $ Identifier "debug") (SomeBuiltin builtInDebug) insertBuiltInWithDoc (SkIdentifier $ Identifier "inspect") (SomeBuiltin builtInInspect) @@ -86,10 +114,37 @@ insertBuiltInWithDoc (SkIdentifier $ Identifier "tostring") (SomeBuiltin builtInToString) insertBuiltInWithDoc (SkIdentifier $ Identifier "csinit") (SomeBuiltin initCharScreen) insertBuiltInWithDoc (SkIdentifier $ Identifier "csgoto") (SomeBuiltin charScreenGoto) + insertBuiltInWithDoc (SkIdentifier $ Identifier "csget") (SomeBuiltin charScreenGet) + insertBuiltInWithDoc (SkIdentifier $ Identifier "csmove") (SomeBuiltin charScreenMove) insertBuiltInWithDoc (SkIdentifier $ Identifier "csprint") (SomeBuiltin charScreenPrint) + insertBuiltInWithDoc (SkIdentifier $ Identifier "csprintln") (SomeBuiltin charScreenPrintLn) + insertBuiltInWithDoc (SkIdentifier $ Identifier "csinputline") (SomeBuiltin charScreenInputLine) insertBuiltInWithDoc (SkIdentifier $ Identifier "csclear") (SomeBuiltin charScreenClear) + insertBuiltInWithDoc (SkIdentifier $ Identifier "csclearline") (SomeBuiltin charScreenClearLine) insertBuiltInWithDoc (SkIdentifier $ Identifier "csdraw") (SomeBuiltin charScreenDraw) + insertBuiltInWithDoc (SkIdentifier $ Identifier "csscreensize") (SomeBuiltin charGetDimensions) + -- Widgets + insertBuiltInWithDoc (SkIdentifier $ Identifier "resizinglayout") (SomeBuiltin builtInLayoutWidget) + insertBuiltInWithDoc (SkIdentifier $ Identifier "layout") (SomeBuiltin builtInLayoutWidgetSimple) + insertBuiltInWithDoc (SkIdentifier $ Identifier "borderbox") (SomeBuiltin builtInBorderBox) + insertBuiltInWithDoc (SkIdentifier $ Identifier "text") (SomeBuiltin builtInTextContainerWidget) + insertBuiltInWithDoc (SkIdentifier $ Identifier "multilineinput") (SomeBuiltin builtInInputWidget) + insertBuiltInWithDoc (SkIdentifier $ Identifier "input") (SomeBuiltin builtInSingleLineInputWidget) + insertBuiltInWithDoc (SkIdentifier $ Identifier "label") (SomeBuiltin builtInTextLabelWidget) + insertBuiltInWithDoc (SkIdentifier $ Identifier "selector") (SomeBuiltin builtInSelectorWidget) + insertBuiltInWithDoc (SkIdentifier $ Identifier "button") (SomeBuiltin builtInButtonWidget) + insertBuiltInWithDoc (SkIdentifier $ Identifier "setoptions") (SomeBuiltin builtInSetOptions) + insertBuiltInWithDoc (SkIdentifier $ Identifier "getoptions") (SomeBuiltin builtInGetOptions) + insertBuiltInWithDoc (SkIdentifier $ Identifier "getselection") (SomeBuiltin builtInGetSelection) + insertBuiltInWithDoc (SkIdentifier $ Identifier "attach") (SomeBuiltin builtInAddWidget) + insertBuiltInWithDoc (SkIdentifier $ Identifier "attachat") (SomeBuiltin builtInAddWidgetAt) + insertBuiltInWithDoc (SkIdentifier $ Identifier "handle") (SomeBuiltin builtInHandleInput) + insertBuiltInWithDoc (SkIdentifier $ Identifier "draw") (SomeBuiltin builtInDrawWidget) + insertBuiltInWithDoc (SkIdentifier $ Identifier "setsize") (SomeBuiltin builtInSetWidgetSize) + insertBuiltInWithDoc (SkIdentifier $ Identifier "settext") (SomeBuiltin builtInSetTextWidgetContent) + insertBuiltInWithDoc (SkIdentifier $ Identifier "setfocus") (SomeBuiltin builtInSetFocus) + -- SDL Sound insertBuiltInWithDoc (SkIdentifier $ Identifier "maketone") (SomeBuiltin builtInMakeTone) insertBuiltInWithDoc (SkIdentifier $ Identifier "makesound") (SomeBuiltin builtInMakeSoundSample) @@ -105,13 +160,21 @@ insertBuiltInWithDoc (SkIdentifier $ Identifier "points") (SomeBuiltin drawPoints) insertBuiltInWithDoc (SkIdentifier $ Identifier "line") (SomeBuiltin drawLine) insertBuiltInWithDoc (SkIdentifier $ Identifier "lines") (SomeBuiltin drawLines) + insertBuiltInWithDoc (SkIdentifier $ Identifier "arc") (SomeBuiltin drawArc) insertBuiltInWithDoc (SkIdentifier $ Identifier "circle") (SomeBuiltin drawCircle) + insertBuiltInWithDoc (SkIdentifier $ Identifier "polygon") (SomeBuiltin drawPoly) insertBuiltInWithDoc (SkIdentifier $ Identifier "box") (SomeBuiltin drawBox) - insertBuiltInWithDoc (SkIdentifier $ Identifier "drawscreen") (SomeBuiltin draw) + insertBuiltInWithDoc (SkIdentifier $ Identifier "render") (SomeBuiltin draw) insertBuiltInWithDoc (SkIdentifier $ Identifier "setcolor") (SomeBuiltin setDrawColor) insertBuiltInWithDoc (SkIdentifier $ Identifier "clearscreen") (SomeBuiltin clear) insertBuiltInWithDoc (SkIdentifier $ Identifier "getwindowsize") (SomeBuiltin getWindowSize) insertBuiltInWithDoc (SkIdentifier $ Identifier "setlogicalsize") (SomeBuiltin setLogicalSize) + insertBuiltInWithDoc (SkIdentifier $ Identifier "loadtexture") (SomeBuiltin loadTexture) + insertBuiltInWithDoc (SkIdentifier $ Identifier "destroytexture") (SomeBuiltin destroyTexture) + insertBuiltInWithDoc (SkIdentifier $ Identifier "copytexture") (SomeBuiltin copyTexture) + insertBuiltInWithDoc (SkIdentifier $ Identifier "copytexturepart") (SomeBuiltin copyTexturePart) + insertBuiltInWithDoc (SkIdentifier $ Identifier "copytexturerotated") (SomeBuiltin copyTextureRotated) + insertBuiltInWithDoc (SkIdentifier $ Identifier "textureinfo") (SomeBuiltin textureInfo) -- SDL Keyboard insertBuiltInWithDoc (SkIdentifier $ Identifier "getkeypresses") (SomeBuiltin getKeys) @@ -132,7 +195,14 @@ insertBuiltInWithDoc (SkIdentifier $ Identifier "writeref") (SomeBuiltin builtInWriteRef) insertBuiltInWithDoc (SkIdentifier $ Identifier "modifyref") (SomeBuiltin builtInModifyRef) + -- Crypto + insertBuiltInWithDoc (SkIdentifier $ Identifier "hash") (SomeBuiltin builtInHash) + insertBuiltInWithDoc (SkIdentifier $ Identifier "hashinit") (SomeBuiltin builtInHashInit) + insertBuiltInWithDoc (SkIdentifier $ Identifier "hashupdate") (SomeBuiltin builtInHashUpdate) + insertBuiltInWithDoc (SkIdentifier $ Identifier "hashfinalize") (SomeBuiltin builtInHashFinalize) + -- Constants insertBuiltInVal (SkIdentifier $ Identifier "keycodes") keycodes insertBuiltInVal (SkIdentifier $ Identifier "scancodes") scancodes + diff --git a/src/Interpreter/Interpreter.hs b/src/Interpreter/Interpreter.hs --- a/src/Interpreter/Interpreter.hs +++ b/src/Interpreter/Interpreter.hs @@ -2,8 +2,9 @@ import Prelude hiding (map) +import Control.Monad.Catch (try) import Control.Concurrent.STM as STM -import Control.Exception (throw) +import Control.Exception (throw, IOException) import Control.Monad import Control.Monad.Catch (catch) import Control.Monad.Loops (iterateWhile) @@ -11,7 +12,12 @@ import qualified Data.List.NonEmpty as NE import Data.Map as M hiding (map) import Data.Text as T hiding (index, map) +import qualified Data.Text as T (index) import qualified Data.Vector as V +import qualified Data.ByteString as BS +import System.Posix.Directory as POSIX +import System.FilePath +import System.Directory import Common import Compiler.AST.FunctionStatement @@ -58,10 +64,10 @@ evaluateExpression_ (EOperator op e1 e2) = do evaluateFn (FnOp op) [e1, e2] False >>= \case Just v -> pure v - Nothing -> throwErr MissingProcedureReturn + Nothing -> pure Void evaluateExpression_ (ECall iden exprs isTail) = evaluateFn (FnName iden) exprs isTail >>= \case Just v -> pure v - Nothing -> throwErr MissingProcedureReturn + Nothing -> pure Void evaluateExpression_ (EUnnamedFn args expr) = do isLocal <$> get >>= \case [] -> pure $ UnnamedFnValue $ UnNamedFn args mempty expr @@ -90,12 +96,12 @@ insertScope scope = modify $ mapLocal (\s -> scope : s) evaluateUnnamedFn :: UnNamedFn -> [Value] -> InterpretM Value -evaluateUnnamedFn (UnNamedFn Nothing scope expr) _ = do +evaluateUnnamedFn (UnNamedFn [] scope expr) _ = do insertScope scope x <- evaluateExpression expr popScope pure x -evaluateUnnamedFn (UnNamedFn (Just (NE.toList -> argNames)) scope expr) argsVals = do +evaluateUnnamedFn (UnNamedFn argNames scope expr) argsVals = do insertScope scope zipWithM_ (\a1 a2 -> insertBinding a1 a2) (SkIdentifier <$> argNames) argsVals -- @TODO Check argument counts r <- evaluateExpression expr @@ -146,10 +152,24 @@ evaluateSubscriptedExpr :: SubscriptedExpression -> InterpretM Value evaluateSubscriptedExpr (EArraySubscript expr indexExpr) = evaluateExpression expr >>= \case + StringValue v -> evaluateExpression indexExpr >>= \case + NumberValue (NumberInt i) -> do + let index :: Int = fromIntegral i + if index <= T.length v && index >= 0 + then pure $ StringValue $ T.singleton (T.index v (index - 1)) + else (throwErr $ IndexOutOfBounds index) + a -> throwErr $ UnexpectedType ("Integer index", a) + BytesValue v -> evaluateExpression indexExpr >>= \case + NumberValue (NumberInt i) -> do + let index :: Int = fromIntegral i + case BS.indexMaybe v (index - 1) of + Just w -> pure $ NumberValue $ NumberInt $ fromIntegral w + Nothing -> (throwErr $ IndexOutOfBounds index) + a -> throwErr $ UnexpectedType ("Integer index", a) ArrayValue v -> evaluateExpression indexExpr >>= \case NumberValue (NumberInt i) -> do let index :: Int = fromIntegral i - if index <= V.length v && index >= 0 then (pure $ v V.! (index - 1)) else (throwErr $ ListIndexOutOfBounds index) + if index <= V.length v && index >= 0 then (pure $ v V.! (index - 1)) else (throwErr $ IndexOutOfBounds index) a -> throwErr $ UnexpectedType ("Integer index", a) ObjectValue mp -> evaluateExpression indexExpr >>= \case StringValue key -> case M.lookup key mp of @@ -174,7 +194,7 @@ evaluateVar sub >>= \case ArrayValue v -> do let index :: Int = fromIntegral int - if index <= V.length v && index >= 0 then (pure $ v V.! (index - 1)) else (throwErr $ ListIndexOutOfBounds index) + if index <= V.length v && index >= 0 then (pure $ v V.! (index - 1)) else (throwErr $ IndexOutOfBounds index) a -> throwErr $ UnexpectedType ("Array/Object", a) StringValue key -> lookupInMapVar sub key a -> throwErr $ UnexpectedType ("String/Integer container key", a) @@ -226,8 +246,32 @@ let index :: Int = fromIntegral idx if (index <= V.length v && index > 0) then modifyBinding sub (ArrayValue $ V.update v (V.fromList [(index - 1, val)])) - else throwErr $ ListIndexOutOfBounds index + else throwErr $ IndexOutOfBounds index a -> throwErr $ UnexpectedType ("Integer Index", a) + BytesValue v -> evaluateExpression expr >>= \case + NumberValue (NumberInt idx) -> do + let index :: Int = fromIntegral idx + if (index <= BS.length v && index > 0) + then + let + prefix = BS.take (index - 1) v + suffix = BS.drop index v + wv = fromValue val + in modifyBinding sub (BytesValue $ prefix <> BS.cons wv suffix) + else throwErr $ IndexOutOfBounds index + a -> throwErr $ UnexpectedType ("Integer Index", a) + StringValue v -> evaluateExpression expr >>= \case + NumberValue (NumberInt idx) -> do + let index :: Int = fromIntegral idx + if (index <= T.length v && index > 0) + then + let + prefix = T.take (index - 1) v + suffix = T.drop index v + wv = fromValue val + in modifyBinding sub (StringValue $ prefix <> T.cons wv suffix) + else throwErr $ IndexOutOfBounds index + a -> throwErr $ UnexpectedType ("Integer Index", a) ObjectValue v -> evaluateExpression expr >>= \case StringValue key -> case M.lookup key v of Just _ -> modifyBinding sub (ObjectValue $ M.insert key val v) @@ -334,10 +378,15 @@ evaluateExpression (eloc { elExpression = ECall idf args True }) >>= pure . ProcReturn True executeStatement_ (Return expr) = evaluateExpression expr >>= pure . ProcReturn False executeStatement_ Break = pure ProcBreak -executeStatement_ (Loop (NE.toList -> stms)) = iterateWhile (\case - ProcBreak -> False - ProcContinue -> True - ProcReturn _ _ -> False) (executeStatements stms) +executeStatement_ Pass = pure ProcContinue +executeStatement_ (Loop (NE.toList -> stms)) = do + r <- iterateWhile (\case + ProcBreak -> False + ProcContinue -> True + ProcReturn _ _ -> False) (executeStatements stms) + case r of + ProcBreak -> pure ProcContinue + a -> pure a executeStatement_ (While exprBool (NE.toList -> stms)) = do r <- iterateWhile (\case @@ -375,6 +424,12 @@ V.foldM (\a1 a2 -> fn a1 a2) ProcContinue values >>= \case ProcReturn tc v -> pure $ ProcReturn tc v _ -> pure ProcContinue + DirectoryStack dhref -> do + let go lr = do + (liftIO $ readDirectoryStack dhref) >>= \case + EmptyItem -> pure ProcContinue + fi -> fn lr (mkObjectFromFileItem fi) >>= go + go ProcContinue a -> throwErr $ UnexpectedType ("Array/Object", a) where fn :: ProcResult -> Value -> InterpretM ProcResult @@ -382,6 +437,72 @@ insertBinding (SkIdentifier iden) current executeStatements stms fn r _ = pure r + +data FileEntry + = FileItem FilePath + | DirItem FilePath + | SymlinkItem FilePath + | ErrorItem FilePath Text + | EmptyItem + +mkObjectFromFileItem :: FileEntry -> Value +mkObjectFromFileItem EmptyItem = error "Impossible!" +mkObjectFromFileItem (FileItem t) = ObjectValue $ M.fromList [("type", StringValue "file"), ("path", StringValue $ T.pack t)] +mkObjectFromFileItem (DirItem t) = ObjectValue $ M.fromList [("type", StringValue "dir"), ("path", StringValue $ T.pack t)] +mkObjectFromFileItem (SymlinkItem t) = ObjectValue $ M.fromList [("type", StringValue "symlink"), ("path", StringValue $ T.pack t)] +mkObjectFromFileItem (ErrorItem t e) = ObjectValue $ M.fromList [("type", StringValue "error"), ("path", StringValue $ T.pack t), ("message", StringValue e)] + +readDirectoryStack :: DirHandleRef -> IO FileEntry +readDirectoryStack a@(DirHandleRef recursive ref) = do + readTVarIO ref >>= \case + [] -> pure EmptyItem + (DirStreamInfo (AbsoluteFilePath afp) mh: _) -> do + eh <- case mh of + Just h -> pure $ Right h + Nothing -> do + try @_ @IOException (POSIX.openDirStream afp) >>= \case + Right h -> do + atomically $ modifyTVar ref (\case + [] -> error "Impossible!" + (_:c) -> (DirStreamInfo (AbsoluteFilePath afp) (Just h) : c)) + pure $ Right h + Left err -> do + atomically $ modifyTVar ref (\case + [] -> error "Impossible!" + (_:c) -> c) + pure $ Left (T.pack $ show err) + + case eh of + Left h -> pure $ ErrorItem afp h + Right h -> do + POSIX.readDirStream h >>= \case + "" -> do + -- pop top most path if it has run out of files. + POSIX.closeDirStream h + atomically $ modifyTVar ref (\case + [] -> error "Impossible!" + (_:rs) -> rs) + readDirectoryStack a + "." -> readDirectoryStack a + ".." -> readDirectoryStack a + fp -> do + -- check if this is a dir, if yes, push it on top of stack, but + -- only if recursion is enabled. + -- then return its path. + let fp' = afp fp + pathIsSymbolicLink fp' >>= \case + True -> pure (SymlinkItem fp') + False -> if recursive + then do + doesDirectoryExist fp' >>= \case + True -> do + atomically $ modifyTVar ref (\c -> (DirStreamInfo (AbsoluteFilePath fp') Nothing : c)) + pure (DirItem fp') + _ -> pure (FileItem fp') + else do + doesDirectoryExist fp' >>= \case + True -> pure (DirItem fp') + _ -> pure (FileItem fp') filter_ :: BuiltInFnWithDoc '[ '("list", V.Vector Value), '("callback", Callback)] filter_ ((coerce -> v1) :> (coerce -> callback) :> _) = diff --git a/src/Interpreter/Lib/Concurrency.hs b/src/Interpreter/Lib/Concurrency.hs --- a/src/Interpreter/Lib/Concurrency.hs +++ b/src/Interpreter/Lib/Concurrency.hs @@ -3,6 +3,7 @@ import Control.Concurrent import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TChan +import Control.Concurrent.STM.TSem import Control.Concurrent.STM.TMVar import Control.Exception (AsyncException(..), SomeException, catch, toException) import Control.Monad.IO.Class @@ -59,23 +60,30 @@ builtInNewRef :: BuiltInFnWithDoc '[ '("init_value", Value) ] builtInNewRef ((coerce -> (v :: Value)) :> EmptyArgs) = do - ref <- liftIO $ newTMVarIO v - pure $ Just $ Ref $ MutableRef ref + (ref, sem) <- liftIO $ do + r <- newTMVarIO v + s <- atomically (newTSem 1) + pure (r, s) + pure $ Just $ Ref $ MutableRef ref sem builtInWriteRef :: BuiltInFnWithDoc '[ '("ref", MutableRef), '("new_value", Value) ] -builtInWriteRef ((coerce -> (MutableRef ref)) :> (coerce -> v) :> EmptyArgs) = do +builtInWriteRef ((coerce -> (MutableRef ref _)) :> (coerce -> v) :> EmptyArgs) = do void $ liftIO $ atomically $ swapTMVar ref v pure Nothing -builtInReadRef :: BuiltInFnWithDoc '[ '("ref", MutableRef) ] -builtInReadRef ((coerce -> (MutableRef ref)) :> EmptyArgs) = do - v <- liftIO $ atomically $ readTMVar ref - pure $ Just v - builtInModifyRef :: BuiltInFnWithDoc '[ '("ref", MutableRef), '("callback", Callback) ] -builtInModifyRef ((coerce -> (MutableRef ref)) :> (coerce -> callback) :> EmptyArgs) = do - v <- liftIO $ atomically $ takeTMVar ref +builtInModifyRef ((coerce -> (MutableRef ref sem)) :> (coerce -> (callback :: Callback)) :> EmptyArgs) = do + v <- liftIO $ atomically $ do + waitTSem sem + readTMVar ref evaluateCallback callback [v] >>= \case - Just v' -> liftIO $ atomically $ putTMVar ref v' Nothing -> throwErr MissingProcedureReturn + Just r -> liftIO $ atomically $ do + _ <- swapTMVar ref r + signalTSem sem pure Nothing + +builtInReadRef :: BuiltInFnWithDoc '[ '("ref", MutableRef) ] +builtInReadRef ((coerce -> (MutableRef ref _)) :> EmptyArgs) = do + v <- liftIO $ atomically $ readTMVar ref + pure $ Just v diff --git a/src/Interpreter/Lib/Crypto.hs b/src/Interpreter/Lib/Crypto.hs new file mode 100644 --- /dev/null +++ b/src/Interpreter/Lib/Crypto.hs @@ -0,0 +1,33 @@ +module Interpreter.Lib.Crypto where + +import Crypto.Hash +import Data.ByteString as BS +import Data.ByteArray +import Data.Coerce +import Data.Text + +import Interpreter.Common + +builtInHash :: BuiltInFnWithDoc '[ '("algo", Text), '("bytes", BS.ByteString) ] +builtInHash ((coerce -> (algo :: Text)) :> (coerce -> (bs :: ByteString)) :> EmptyArgs) = + case algo of + "md5" -> pure $ Just $ BytesValue $ convert $ hash @_ @MD5 bs + _ -> error "Unknown algorithm" + +builtInHashInit :: BuiltInFnWithDoc '[ '("algo", Text) ] +builtInHashInit ((coerce -> (algo :: Text)) :> EmptyArgs) = + case algo of + "md5" -> pure $ Just $ HashContextValue (MD5HashContext (hashInit @MD5)) + _ -> error "Unknown algorithm" + +builtInHashUpdate :: BuiltInFnWithDoc '[ '("context", HashContext), '("input", ByteString) ] +builtInHashUpdate ((coerce -> (context :: HashContext)) :> (coerce -> (input :: ByteString)) :> EmptyArgs) = + case context of + MD5HashContext ctx -> do + pure $ Just $ HashContextValue (MD5HashContext $ hashUpdate ctx input) + +builtInHashFinalize :: BuiltInFnWithDoc '[ '("context", HashContext) ] +builtInHashFinalize ((coerce -> (context :: HashContext)) :> EmptyArgs) = + case context of + MD5HashContext ctx -> do + pure $ Just $ BytesValue $ convert $ (hashFinalize ctx) diff --git a/src/Interpreter/Lib/FileSystem.hs b/src/Interpreter/Lib/FileSystem.hs new file mode 100644 --- /dev/null +++ b/src/Interpreter/Lib/FileSystem.hs @@ -0,0 +1,113 @@ +module Interpreter.Lib.FileSystem where + +import Control.Concurrent.STM (newTVarIO) +import Control.Monad.IO.Class +import qualified Data.ByteString as BS +import qualified Data.ByteString.Internal as BSI +import Data.Coerce +import Data.Maybe (fromMaybe) +import Data.Text as T +import Data.Text.Encoding +import Data.Text.IO as T +import System.Directory +import qualified System.IO as SIO +import System.Posix.Directory as POSIX +import System.FilePath + +import Interpreter.Common + +builtInWriteFile :: BuiltInFnWithDoc '[ '("filename", FilePath), '("data", BytesOrText)] +builtInWriteFile ((coerce -> filepath) :> (coerce -> bot) :> EmptyArgs) = liftIO $ case bot of + BTBytes bin -> do + BS.writeFile filepath bin + pure Nothing + BTText dat -> do + T.writeFile filepath dat + pure Nothing + +builtInReadFile :: BuiltInFnWithDoc '[ '("filename", FilePath)] +builtInReadFile ((coerce -> filepath) :> _) = liftIO $ do + c <- BS.readFile filepath + pure $ Just $ BytesValue c + +builtInIsFile :: BuiltInFnWithDoc '[ '("filename", FilePath)] +builtInIsFile ((coerce -> filepath) :> _) = liftIO $ do + c <- doesFileExist filepath + pure $ Just $ BoolValue c + +builtInIsDir :: BuiltInFnWithDoc '[ '("filename", FilePath)] +builtInIsDir ((coerce -> filepath) :> _) = liftIO $ do + c <- doesDirectoryExist filepath + pure $ Just $ BoolValue c + +builtInOpenFileHandle :: BuiltInFnWithDoc '[ '("filepath", FilePath), '("openmode", Text) ] +builtInOpenFileHandle ((coerce -> filepath) :> (coerce -> (openmode :: Text)) :> EmptyArgs) = liftIO $ do + let + oMode = case openmode of + "r" -> SIO.ReadMode + "w" -> SIO.WriteMode + "a" -> SIO.AppendMode + "rw" -> SIO.ReadWriteMode + _ -> error "Unknown file open mode" + handle <- SIO.openBinaryFile filepath oMode + pure $ Just $ FileHandleValue $ FileHandle handle + +builtInReadFileHandle :: BuiltInFnWithDoc '[ '("handle", SIO.Handle), '("length", Int) ] +builtInReadFileHandle ((coerce -> (handle :: SIO.Handle)) :> (coerce -> len) :> EmptyArgs) = liftIO $ do + dat <- BSI.createAndTrim len (\buf -> SIO.hGetBuf handle buf len) + pure $ Just $ BytesValue dat + +builtInGetFileSize :: BuiltInFnWithDoc '[ '("handle", SIO.Handle) ] +builtInGetFileSize ((coerce -> (handle :: SIO.Handle)) :> EmptyArgs) = liftIO $ do + s <- SIO.hFileSize handle + pure $ Just $ NumberValue $ NumberInt s + +builtInWriteFileHandle :: BuiltInFnWithDoc '[ '("filepath", SIO.Handle), '("data", BS.ByteString) ] +builtInWriteFileHandle ((coerce -> (handle :: SIO.Handle)) :> (coerce -> dat) :> EmptyArgs) = liftIO $ do + BS.useAsCString dat (\buf -> SIO.hPutBuf handle buf (BS.length dat)) + pure Nothing + +builtInOpenDir :: BuiltInFnWithDoc '[ '("dirpath", FilePath), '("recursive", Maybe Bool)] +builtInOpenDir ((coerce -> filepath) :> (coerce -> mrecursive) :> _) = liftIO $ do + afp <- makeAbsolute filepath + ds <- POSIX.openDirStream filepath + ref <- newTVarIO [DirStreamInfo (AbsoluteFilePath afp) (Just ds)] + pure $ Just $ DirectoryStack $ DirHandleRef (fromMaybe False mrecursive) ref + +builtInGetCurrentDir :: BuiltInFnWithDoc '[] +builtInGetCurrentDir _ = liftIO $ do + Just . StringValue . T.pack <$> getCurrentDirectory + +builtInReadTextFile :: BuiltInFnWithDoc '[ '("filename", FilePath)] +builtInReadTextFile ((coerce -> filepath) :> _) = do + c <- decodeUtf8 <$> (liftIO $ BS.readFile filepath) + pure $ Just $ StringValue c + +builtInRenameFile :: BuiltInFnWithDoc '[ '("filename", FilePath), '("newfilename", FilePath)] +builtInRenameFile ((coerce -> filepath) :> (coerce -> newfile) :> _) = do + liftIO $ renameFile filepath ((takeDirectory filepath) newfile) + pure Nothing + +builtInTakeFilename :: BuiltInFnWithDoc '[ '("filepath", FilePath)] +builtInTakeFilename ((coerce -> filepath) :> _) = + pure $ Just $ StringValue $ T.pack $ takeFileName filepath + +builtInTakeDirectory :: BuiltInFnWithDoc '[ '("filepath", FilePath)] +builtInTakeDirectory ((coerce -> filepath) :> _) = + pure $ Just $ StringValue $ T.pack $ takeDirectory filepath + +builtInTakeExtension :: BuiltInFnWithDoc '[ '("filepath", FilePath)] +builtInTakeExtension ((coerce -> filepath) :> _) = + pure $ Just $ StringValue $ T.pack $ takeExtension filepath + +builtInDropExtension :: BuiltInFnWithDoc '[ '("filepath", FilePath)] +builtInDropExtension ((coerce -> filepath) :> _) = + pure $ Just $ StringValue $ T.pack $ dropExtension filepath + +builtInTakeBaseName :: BuiltInFnWithDoc '[ '("filepath", FilePath)] +builtInTakeBaseName ((coerce -> filepath) :> _) = + pure $ Just $ StringValue $ T.pack $ takeBaseName filepath + +builtInJoinPaths :: BuiltInFnWithDoc '[ '("filepath", FilePath), '("filepath", FilePath)] +builtInJoinPaths ((coerce -> filepath1) :> (coerce -> filepath2) :> _) = + pure $ Just $ StringValue $ T.pack $ filepath1 filepath2 diff --git a/src/Interpreter/Lib/Misc.hs b/src/Interpreter/Lib/Misc.hs --- a/src/Interpreter/Lib/Misc.hs +++ b/src/Interpreter/Lib/Misc.hs @@ -1,7 +1,7 @@ module Interpreter.Lib.Misc where -import Control.Concurrent.STM.TSem import Control.Concurrent.STM (atomically) +import Control.Concurrent.STM.TSem import Control.Monad.IO.Class import Control.Monad.State.Strict as SM import qualified Data.Aeson as A @@ -11,78 +11,279 @@ import qualified Data.ByteString.Lazy as BSL import Data.Coerce import Data.Map as M +import Data.Proxy import qualified Data.Scientific as S import Data.Text as T import Data.Text.Encoding import Data.Text.IO as T import Data.Vector as V import qualified System.IO as S -import qualified System.IO as SIO -import Text.Read (readMaybe) +import Text.Hex (decodeHex, encodeHex) import Text.Printf (printf) +import Text.Read (readMaybe) +import Data.Typeable import Common import DiffRender.DiffRender import Interpreter.Common -import UI.Widgets.Common +import UI.Widgets.BorderBox +import UI.Widgets.Common hiding (getSelection) +import UI.Widgets.Spade.Layout +import UI.Widgets.Spade.Button +import UI.Widgets.Spade.TextContainer +import UI.Widgets.Spade.TextLabel +import UI.Widgets.Spade.RefLabel +import UI.Widgets.Spade.Selector +import UI.Widgets.Spade.Input initCharScreen :: BuiltInFnWithDoc '[] initCharScreen _ = do isTerminalParams <$> get >>= \case Just (_, dm) -> do - dfr <- liftIO $ emptyDiffRender dm - SM.modify (\is -> is { isDiffRender = Just dfr }) - Nothing -> throwErr $ CustomRTE "Unknown terminal size" + csInitialize dm + -- modifyDiffRender (\dfr -> dfr { dfDebug = True }) + Nothing -> throwErr $ CustomRTE "Unknown terminal size" pure Nothing charScreenGoto :: BuiltInFnWithDoc '[ '("x", Int), '("y", Int)] charScreenGoto ((coerce -> x) :> (coerce -> y) :> _) = do - isDiffRender <$> get >>= \case - Just dm -> SM.modify (\is -> is { isDiffRender = Just $ dfSetCursorPosition x y dm }) - Nothing -> throwErr $ CustomRTE "Char screen not initialized" + charScreenGoto' x y pure Nothing -charScreenPrint :: BuiltInFnWithDoc '[ '("values", Variadic)] -charScreenPrint ((coerce -> Variadic vals) :> _) = do +charGetDimensions :: BuiltInFnWithDoc '[] +charGetDimensions EmptyArgs = do + isTerminalParams <$> get >>= \case + Just (_, dm) -> + pure $ Just $ ObjectValue $ M.fromList [("width", NumberValue $ NumberInt $ fromIntegral $ diW dm), ("height", NumberValue $ NumberInt $ fromIntegral $ diH dm)] + Nothing -> throwErr $ CustomRTE "Unknown terminal size" + +charScreenGoto' :: Int -> Int -> InterpretM () +charScreenGoto' x y = csSetCursorPosition x y + +charScreenGet' :: InterpretM ScreenPos +charScreenGet' = do isDiffRender <$> get >>= \case - Just dm -> dfPutText (Plain (T.concat $ toStringVal <$> vals)) dm + Just dm -> pure $ dfGetCursorPosition dm Nothing -> throwErr $ CustomRTE "Char screen not initialized" - pure Nothing -charScreenClear :: BuiltInFnWithDoc '[] -charScreenClear _ = do +charScreenGet :: BuiltInFnWithDoc '[] +charScreenGet EmptyArgs = do + sp <- charScreenGet' + pure $ Just $ ObjectValue $ M.fromList [("x", NumberValue $ NumberInt $ fromIntegral $ sX sp), ("y", NumberValue $ NumberInt $ fromIntegral $ sY sp)] + +charScreenMove :: BuiltInFnWithDoc '[ '("x", Int), '("y", Int)] +charScreenMove ((coerce -> x) :> (coerce -> y) :> _) = charScreenMove' x y >> pure Nothing + +charScreenMove' :: Int -> Int -> InterpretM () +charScreenMove' x y = do isDiffRender <$> get >>= \case - Just dm -> dfClear dm + Just dm -> SM.modify (\is -> is { isDiffRender = Just $ dfSetCursorPosition (+ x) (+ y) dm }) Nothing -> throwErr $ CustomRTE "Char screen not initialized" + +charScreenPrint :: BuiltInFnWithDoc '[ '("values", Variadic)] +charScreenPrint ((coerce -> Variadic vals) :> _) = charScreenPrint' (T.concat $ toStringVal <$> vals) >> pure Nothing + +charScreenPrintLn :: BuiltInFnWithDoc '[ '("values", Variadic)] +charScreenPrintLn ((coerce -> Variadic vals) :> _) = do + charScreenClearLine' + charScreenPrint' (T.concat $ toStringVal <$> vals) + charScreenMove' 0 1 pure Nothing +charScreenPrint' :: Text -> InterpretM () +charScreenPrint' txt = csPutText (Plain txt) + +charScreenInputLine :: BuiltInFnWithDoc '[ '("prompt", Text)] +charScreenInputLine ((coerce -> prompt) :> _) = (Just . StringValue) <$> (charScreenInputLine' prompt) + +charScreenInputLine' :: Text -> InterpretM Text +charScreenInputLine' prompt = do + charScreenPrint' prompt + charScreenDraw' + charScreenMove' (T.length prompt) 0 + readCharScreenInput >>= \case + Nothing -> do + charScreenGoto' 0 -1 + charScreenClearLine' + charScreenInputLine' prompt + Just x -> pure x + +charScreenClear :: BuiltInFnWithDoc '[] +charScreenClear _ = csClear >> pure Nothing + +charScreenClearLine :: BuiltInFnWithDoc '[] +charScreenClearLine EmptyArgs = charScreenClearLine' >> pure Nothing + +charScreenClearLine' :: InterpretM () +charScreenClearLine' = csClearLine + charScreenDraw :: BuiltInFnWithDoc '[] -charScreenDraw _ = do - isDiffRender <$> get >>= \case - Just dm -> do - tp <- isTerminalParams <$> get - dfr' <- do - isStdoutLock <$> get >>= \case - Just sem -> do - liftIO $ atomically $ waitTSem sem - d' <- dfDraw tp dm - liftIO $ atomically $ signalTSem sem - pure d' - Nothing -> dfDraw tp dm - SM.modify (\is -> is { isDiffRender = Just dfr' }) - Nothing -> throwErr $ CustomRTE "Char screen not initialized" +charScreenDraw _ = charScreenDraw' >> pure Nothing + +charScreenDraw' :: InterpretM () +charScreenDraw' = do + tp <- isTerminalParams <$> get + isStdoutLock <$> get >>= \case + Just sem -> do + liftIO $ atomically $ waitTSem sem + csDraw tp + liftIO $ atomically $ signalTSem sem + Nothing -> csDraw tp + +readCharScreenInput :: InterpretM (Maybe Text) +readCharScreenInput = readInput "" + where + readInput ti = do + c <- interpreterInputChar + case c of + '\n' -> pure $ Just $ T.reverse $ T.pack ti + '\ESC' -> pure Nothing + '\BS' -> readInput ti + _ -> do + charScreenPrint' (T.singleton c) + charScreenMove' 1 0 + charScreenDraw' + readInput (c:ti) + +builtInInitWIdgets :: BuiltInFnWithDoc '[] +builtInInitWIdgets EmptyArgs = do + isWidgetState <$> get >>= \case + Nothing -> UI.Widgets.Common.modify (\is -> is { isWidgetState = Just emptyWidgetState }) + Just _ -> pass pure Nothing +builtInLayoutWidget :: BuiltInFnWithDoc '[ '("orientation", Text), '("child_layout", [[Double]]), '("children", [SomeWidgetRef])] +builtInLayoutWidget ((coerce -> (orientation :: Text )) :> (coerce -> (cl :: [[Double]])) :> (coerce -> children) :> EmptyArgs) = do + layout <- layoutWidget (if orientation == "h" then Horizontal else Vertical) cl children + pure $ Just (WidgetValue (SomeWidgetRef layout)) + +builtInLayoutWidgetSimple :: BuiltInFnWithDoc '[ '("orientation", Text), '("children", [SomeWidgetRef]) ] +builtInLayoutWidgetSimple ((coerce -> (orientation :: Text )) :> (coerce -> children) :> EmptyArgs) = do + layout <- simpleLayoutWidget (if orientation == "h" then Horizontal else Vertical) children + pure $ Just (WidgetValue (SomeWidgetRef layout)) + +builtInTextContainerWidget :: BuiltInFnWithDoc '[] +builtInTextContainerWidget EmptyArgs = do + tc <- textContainer (ScreenPos 0 0) (Dimensions 20 5) + pure $ Just (WidgetValue (SomeWidgetRef tc)) + +builtInInputWidget :: BuiltInFnWithDoc '[] +builtInInputWidget EmptyArgs = do + iw <- input (Dimensions 60 10) + pure $ Just (WidgetValue (SomeWidgetRef iw)) + +builtInSingleLineInputWidget :: BuiltInFnWithDoc '[] +builtInSingleLineInputWidget EmptyArgs = do + iw <- input (Dimensions 60 1) + pure $ Just (WidgetValue (SomeWidgetRef iw)) + +builtInTextLabelWidget :: BuiltInFnWithDoc '[ '("label", Text)] +builtInTextLabelWidget ((coerce -> label) :> EmptyArgs) = do + tc <- textLabel (ScreenPos 0 0) (Dimensions 20 1) label + pure $ Just (WidgetValue (SomeWidgetRef tc)) + +builtInTextRefLabelWidget :: BuiltInFnWithDoc '[ '("reflabel", MutableRef)] +builtInTextRefLabelWidget (((mref . coerce) -> label) :> EmptyArgs) = do + tc <- textRefLabel (ScreenPos 0 0) (Dimensions 20 1) label + pure $ Just (WidgetValue (SomeWidgetRef tc)) + +builtInSelectorWidget :: BuiltInFnWithDoc '[ '("label", Text), '("options", [(Value, Text)]), '("action", Maybe Callback)] +builtInSelectorWidget ((coerce -> (label :: Text)) :> (coerce -> options) :> (coerce -> cb) :> EmptyArgs) = do + tc <- selector label (ScreenPos 0 0) (Dimensions 20 1) options cb + pure $ Just (WidgetValue (SomeWidgetRef tc)) + +builtInButtonWidget :: BuiltInFnWithDoc '[ '("label", Text), '("action", Maybe Callback)] +builtInButtonWidget ((coerce -> (label :: Text)) :> (coerce -> (cb :: Maybe Callback)) :> EmptyArgs) = do + tc <- button (ScreenPos 0 0) (Dimensions (T.length label + 5) 3) label cb + pure $ Just (WidgetValue (SomeWidgetRef tc)) + +builtInGetSelection :: BuiltInFnWithDoc '[ '("select", SomeWidgetRef) ] +builtInGetSelection ((coerce -> (SomeWidgetRef ref)) :> EmptyArgs) = + case cast ref of + Just selectRef -> do + getSelection selectRef >>= \case + Just x -> do + pure $ Just x + Nothing -> pure $ Just Void + Nothing -> error "Selector widget is required" + +builtInSetOptions :: BuiltInFnWithDoc '[ '("select", SomeWidgetRef), '("option", [(Value ,Text)]) ] +builtInSetOptions ((coerce -> (SomeWidgetRef ref)) :> (coerce -> (options :: [(Value, Text)])) :> EmptyArgs) = do + case cast ref of + Just selectRef -> setOptions selectRef options + Nothing -> error "Selector widget is required" + pure Nothing + +builtInGetOptions :: BuiltInFnWithDoc '[ '("select", SomeWidgetRef) ] +builtInGetOptions ((coerce -> (SomeWidgetRef ref)) :> EmptyArgs) = do + case cast ref of + Just selectRef -> do + options <- getOptions selectRef + pure $ Just $ ArrayValue $ V.fromList ((ArrayValue . V.fromList . (\(a, b) -> [a, StringValue b])) <$> options) + Nothing -> error "Selector widget is required" + +builtInBorderBox :: BuiltInFnWithDoc '[ '("child", SomeWidgetRef) ] +builtInBorderBox ((coerce -> (c :: SomeWidgetRef)) :> EmptyArgs) = do + bb <- borderBox (ScreenPos 0 0) (Dimensions 0 0) c + pure $ Just (WidgetValue (SomeWidgetRef bb)) + +builtInAddWidget :: BuiltInFnWithDoc '[ '("widget", SomeWidgetRef), '("child", SomeWidgetRef)] +builtInAddWidget ((coerce -> (SomeWidgetRef parent)) :> (coerce -> (SomeWidgetRef child)) :> EmptyArgs) = do + withCapability (LayoutCap parent) $ do + addWidget parent child + pure Nothing + +builtInAddWidgetAt :: BuiltInFnWithDoc '[ '("widget", SomeWidgetRef), '("stackorder", Int), '("child", SomeWidgetRef)] +builtInAddWidgetAt ((coerce -> (SomeWidgetRef parent)) :> (coerce -> so) :> (coerce -> (SomeWidgetRef child)) :> EmptyArgs) = do + withCapability (LayoutCap parent) $ do + addWidget' parent so child + pure Nothing + +builtInDrawWidget :: BuiltInFnWithDoc '[ '("widget", SomeWidgetRef) ] +builtInDrawWidget ((coerce -> (SomeWidgetRef w)) :> EmptyArgs) = do + withCapability (DrawableCap w) $ draw w + pure Nothing + +builtInSetWidgetSize :: BuiltInFnWithDoc '[ '("widget", SomeWidgetRef), '("size_x", Int), '("size_y", Int) ] +builtInSetWidgetSize ((coerce -> (SomeWidgetRef w)) :> (coerce -> sx) :> (coerce -> sy) :> EmptyArgs) = do + withCapability (MoveableCap w) $ resize w (\d -> d { diW = sx, diH = sy }) + pure Nothing + +builtInSetFocus :: BuiltInFnWithDoc '[ '("widget", SomeWidgetRef), '("bool", Bool) ] +builtInSetFocus ((coerce -> (SomeWidgetRef w)) :> (coerce -> b) :> EmptyArgs) = do + withCapability (FocusableCap w) $ setFocus w b + pure Nothing + +builtInSetTextWidgetContent :: BuiltInFnWithDoc '[ '("widget", SomeWidgetRef), '("content", Text)] +builtInSetTextWidgetContent ((coerce -> (SomeWidgetRef w)) :> (coerce -> (content :: Text)) :> EmptyArgs) = do + withCapability (ContainerCap w (Proxy @Text)) $ setContent w content + pure Nothing + +builtInHandleInput :: BuiltInFnWithDoc '[ '("widget", SomeWidgetRef), '("keyevent", [KeyEvent]) ] +builtInHandleInput ((coerce -> (SomeWidgetRef w)) :> (coerce -> (ke :: [KeyEvent])) :> EmptyArgs) = do + withCapability (KeyInputCap w) $ UI.Widgets.Common.mapM_ (handleInput w) ke + pure Nothing + toStringValFmt :: (Text, Int, [Int]) -> Value -> Text toStringValFmt (s, _, p) v@(NumberValue (NumberInt _)) = amountFormat s p $ toStringVal v toStringValFmt (s, f, p) (NumberValue (NumberFractional x)) = amountFormat s p $ T.pack $ printf ("%0." Prelude.++ show f Prelude.++ "f") x toStringValFmt _ v = toStringVal v +builtinEncodeBytes :: BuiltInFnWithDoc '[ '("bytes", BS.ByteString)] +builtinEncodeBytes ((coerce -> bs) :> EmptyArgs) = + pure $ Just $ StringValue $ encodeHex bs + +builtinDecodeBytes :: BuiltInFnWithDoc '[ '("string", Text)] +builtinDecodeBytes ((coerce -> ebs) :> EmptyArgs) = + case decodeHex ebs of + Just bs -> pure $ Just $ BytesValue bs + Nothing -> error "Input cannot be decoded as bytes" + printValLn :: BuiltInFnWithDoc '[ '("value", Variadic)] printValLn ((coerce -> (Variadic vals)) :> EmptyArgs) = do outH <- isOutputHandle <$> get tstrFn <- isDefaultPrintParams <$> get >>= \case - Just p -> pure $ toStringValFmt p + Just p -> pure $ toStringValFmt p Nothing -> pure toStringVal liftIO $ do UI.Widgets.Common.mapM_ (T.hPutStr outH) (tstrFn <$> vals) @@ -94,7 +295,7 @@ printVal ((coerce -> (Variadic vals)) :> EmptyArgs) = do outH <- isOutputHandle <$> get tstrFn <- isDefaultPrintParams <$> get >>= \case - Just p -> pure $ toStringValFmt p + Just p -> pure $ toStringValFmt p Nothing -> pure toStringVal liftIO $ do UI.Widgets.Common.mapM_ (T.hPutStr outH) (tstrFn <$> vals) @@ -152,6 +353,17 @@ 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' +getkey :: BuiltInFnWithDoc '[ '("dictionary", M.Map Text Value), '("key", Text)] +getkey ((coerce -> (map' :: M.Map Text Value)) :> (coerce -> key) :> _) = case M.lookup key map' of + Just v -> pure $ Just v + Nothing -> pure $ Just $ ErrorValue $ "Key '" <> key <> "' not found in dictionary" + +addkey :: BuiltInFnWithDoc '[ '("dictionary", M.Map Text Value), '("key", Text), '("value", Value)] +addkey ((coerce -> (map' :: M.Map Text Value)) :> (coerce -> key) :> (coerce -> val) :> EmptyArgs) = pure $ Just $ ObjectValue $ M.insert key val map' + +builtInRepeat :: BuiltInFnWithDoc ['("count", Int), '("source", Value)] +builtInRepeat ((coerce -> c) :> (coerce -> vl) :> EmptyArgs) = pure $ Just $ ArrayValue $ V.fromList $ Prelude.take c $ repeat vl + builtInTake :: BuiltInFnWithDoc ['("count", Int), '("source", TextOrList)] builtInTake ((coerce -> c) :> (coerce -> vl) :> EmptyArgs) = case vl of TCText t -> pure $ Just $ StringValue $ T.take c t @@ -168,25 +380,6 @@ builtInArrayInsertRight :: BuiltInFnWithDoc ['("initial_list", Vector Value), '("item", Value)] builtInArrayInsertRight ((coerce -> v1) :> (coerce -> c) :> _) = pure $ Just $ ArrayValue (V.snoc v1 c) -builtInWriteFile :: BuiltInFnWithDoc '[ '("filename", FilePath), '("data", BytesOrText)] -builtInWriteFile ((coerce -> filepath) :> (coerce -> bot) :> EmptyArgs) = liftIO $ case bot of - BTBytes bin -> do - BS.writeFile filepath bin - pure Nothing - BTText dat -> do - T.writeFile filepath dat - pure Nothing - -builtInReadFile :: BuiltInFnWithDoc '[ '("filename", FilePath)] -builtInReadFile ((coerce -> filepath) :> _) = liftIO $ do - c <- BS.readFile filepath - pure $ Just $ BytesValue c - -builtInReadTextFile :: BuiltInFnWithDoc '[ '("filename", FilePath)] -builtInReadTextFile ((coerce -> filepath) :> _) = do - c <- decodeUtf8 <$> (liftIO $ BS.readFile filepath) - pure $ Just $ StringValue c - builtInHead :: BuiltInFnWithDoc '[ '("source_list", Vector Value)] builtInHead ((coerce -> v1) :> _) = case V.uncons v1 of Just (x, _) -> pure $ Just x @@ -212,7 +405,7 @@ builtInInspect :: BuiltInFnWithDoc '[ '("value", Value)] builtInInspect ((coerce -> (v :: Value)) :> _) = do - vText <- (decodeUtf8) <$> serializeJSON v + vText <- decodeUtf8 <$> serializeJSON v interpreterOutput vText interpreterOutputFlush pure Nothing @@ -227,6 +420,15 @@ Right val -> pure $ Just $ fromAesonVal val Left err -> throwErr $ CustomRTE ("JSON decoding failed with error:" <> (T.pack err)) +builtInError :: BuiltInFnWithDoc '[ '("message", Text)] +builtInError ((coerce -> v) :> EmptyArgs) = + pure $ Just $ ErrorValue v + +builtInIsError :: BuiltInFnWithDoc '[ '("value", Value)] +builtInIsError ((coerce -> v) :> _) = case v of + ErrorValue _ -> pure $ Just $ BoolValue True + _ -> pure $ Just $ BoolValue False + builtInDebug :: BuiltInFnWithDoc '[] builtInDebug _ = do SM.modify (\is -> case isRunMode is of @@ -263,8 +465,8 @@ waitForKey :: BuiltInFnWithDoc '[] waitForKey _ = do inputHandle <- isInputHandle <$> get - c <- liftIO $ SIO.hGetChar inputHandle - pure $ Just $ StringValue $ T.singleton c + c <- liftIO $ readKey_ inputHandle + pure $ Just $ ArrayValue $ V.fromList (EventValue <$> strToKeyEvent c) builtinInputLine :: BuiltInFnWithDoc '[ '("prompt", Text)] builtinInputLine ((coerce -> prompt) :> _) = do @@ -276,4 +478,6 @@ valueSize ((coerce -> v1) :> _) = case v1 of ArrayValue v -> pure $ Just $ NumberValue $ NumberInt $ fromIntegral $ V.length v ObjectValue m -> pure $ Just $ NumberValue $ NumberInt $ fromIntegral $ M.size m - v -> throwErr (UnexpectedType ("Array or Object", v)) + StringValue t -> pure $ Just $ NumberValue $ NumberInt $ fromIntegral $ T.length t + BytesValue t -> pure $ Just $ NumberValue $ NumberInt $ fromIntegral $ BS.length t + v -> throwErr (UnexpectedType ("Array/Object/Bytes/String", v)) diff --git a/src/Interpreter/Lib/SDL.hs b/src/Interpreter/Lib/SDL.hs --- a/src/Interpreter/Lib/SDL.hs +++ b/src/Interpreter/Lib/SDL.hs @@ -31,22 +31,30 @@ [0 :: Int32 .. 22050] createGraphicsWindow :: BuiltInFnWithDoc ['("width", Int), '("height", Int), '("accelerated", Maybe Bool)] -createGraphicsWindow ((coerce -> w) :> (coerce -> h) :> (coerce -> maccelerated) :>_) = - initGraphics (Just (w, h)) (fromMaybe False maccelerated) +createGraphicsWindow ((coerce -> w) :> (coerce -> h) :> (coerce -> maccelerated) :>_) = + initGraphics (Just (w, h)) False (fromMaybe False maccelerated) +createGraphicsFullscrenRes :: BuiltInFnWithDoc ['("width", Int), '("height", Int), '("accelerated", Maybe Bool)] +createGraphicsFullscrenRes ((coerce -> w) :> (coerce -> h) :> (coerce -> maccelerated) :>_) = + initGraphics (Just (w, h)) True (fromMaybe False maccelerated) + createGraphicsFullscreen :: BuiltInFnWithDoc '[ '("accelerated", Maybe Bool)] createGraphicsFullscreen ((coerce -> maccelerated) :>_) = - initGraphics Nothing (fromMaybe False maccelerated) + initGraphics Nothing True (fromMaybe False maccelerated) -initGraphics :: Maybe (Int, Int) -> Bool -> InterpretM (Maybe Value) -initGraphics md acc = do +initGraphics :: Maybe (Int, Int) -> Bool -> Bool -> InterpretM (Maybe Value) +initGraphics md isfulscren acc = do let windowName = "S.P.A.D.E Program" (renderer, window) <- liftIO $ do SDL.initialize [SDL.InitVideo, SDL.InitAudio, SDL.InitEvents, SDL.InitTimer] SDLM.openAudio SDLM.defaultAudio 256 - window <- case md of - Just (w, h) -> SDL.createWindow windowName (windowConfig w h) - Nothing -> SDL.createWindow windowName fullscreenConfig + window <- if isfulscren + then case md of + Just (w, h) -> SDL.createWindow windowName (fullscreenConfigRes (fromIntegral w) (fromIntegral h)) + Nothing -> SDL.createWindow windowName fullscreenConfig + else case md of + Just (w, h) -> SDL.createWindow windowName (windowConfig w h) + Nothing -> SDL.createWindow windowName (windowConfig 800 600) renderer <- case acc of True -> SDL.createRenderer window (-1) SDL.defaultRenderer _ -> SDL.createRenderer window (-1) $ SDL.defaultRenderer { rendererType = SoftwareRenderer } @@ -66,6 +74,13 @@ , windowMode = FullscreenDesktop } +fullscreenConfigRes :: CInt -> CInt -> SDL.WindowConfig +fullscreenConfigRes x y = SDL.defaultWindow + { windowHighDPI = False + , windowMode = FullscreenDesktop + , windowInitialSize = V2 x y + } + windowConfig :: Int -> Int -> SDL.WindowConfig windowConfig w h = SDL.defaultWindow { windowHighDPI = False @@ -82,6 +97,163 @@ pure Nothing Nothing -> throwErr $ SDLError "Graphics not Initialized" +loadTexture' :: FilePath -> InterpretM Value +loadTexture' fp = do + renderer <- getDefaultRenderer + surface <- SDL.loadBMP fp + texture <- SDL.createTextureFromSurface renderer surface + pure $ SDLValue $ Texture texture + +textureInfo' :: SDL.Texture -> InterpretM (CInt, CInt) +textureInfo' texture = do + ti <- SDL.queryTexture texture + pure (SDL.textureWidth ti, SDL.textureHeight ti) + +copyTexture' :: SDL.Texture -> CInt -> CInt -> CInt -> CInt -> InterpretM () +copyTexture' texture x y w h = do + renderer <- getDefaultRenderer + SDL.copy renderer texture Nothing (Just $ SDL.Rectangle (SDL.P (SDL.V2 x y)) (SDL.V2 w h)) + +copyTexturePart' :: SDL.Texture -> CInt -> CInt -> CInt -> CInt -> CInt -> CInt -> CInt -> CInt -> InterpretM () +copyTexturePart' texture sx sy sw sh x y w h = do + renderer <- getDefaultRenderer + SDL.copy renderer texture + (Just $ SDL.Rectangle (SDL.P (SDL.V2 sx sy)) (SDL.V2 sw sh)) + (Just $ SDL.Rectangle (SDL.P (SDL.V2 x y)) (SDL.V2 w h)) + +copyTextureRotated' + :: SDL.Texture + -> CInt + -> CInt + -> CInt + -> CInt + -> CInt + -> CInt + -> CInt + -> CInt + -> CDouble + -> CInt + -> CInt + -> Bool + -> Bool + -> InterpretM () +copyTextureRotated' texture sx sy sw sh x y w h rotationDeg rx ry fx fy = do + renderer <- getDefaultRenderer + SDL.copyEx renderer texture + (Just $ SDL.Rectangle (SDL.P (SDL.V2 sx sy)) (SDL.V2 sw sh)) + (Just $ SDL.Rectangle (SDL.P (SDL.V2 x y)) (SDL.V2 w h)) + rotationDeg + (Just $ mkPoint rx ry) + (SDL.V2 fx fy) + +loadTexture :: BuiltInFnWithDoc '[ '("bmp_file", FilePath)] +loadTexture ((coerce -> fp) :> EmptyArgs) = + Just <$> loadTexture' fp + +destroyTexture :: BuiltInFnWithDoc '[ '("texture", SDL.Texture)] +destroyTexture ((coerce -> texture) :> EmptyArgs) = do + SDL.destroyTexture texture + pure Nothing + +textureInfo :: BuiltInFnWithDoc + '[ '("texture", SDL.Texture) + ] +textureInfo + ( (coerce -> texture) :> EmptyArgs) = do + (w, h) <- textureInfo' texture + pure $ Just $ ObjectValue $ M.fromList + [ ("width", NumberValue $ NumberInt $ fromIntegral w) + , ("height", NumberValue $ NumberInt $ fromIntegral h) + ] + +copyTexture :: BuiltInFnWithDoc + '[ '("texture", SDL.Texture) + , '("dst_x", CInt) + , '("dst_y", CInt) + , '("dst_w", CInt) + , '("dst_h", CInt) + ] +copyTexture + ( (coerce -> texture) + :> (coerce -> dx) + :> (coerce -> dy) + :> (coerce -> dh) + :> (coerce -> dw) + :> EmptyArgs) = do + copyTexture' texture dx dy dh dw + pure Nothing + +copyTexturePart :: BuiltInFnWithDoc + '[ '("texture", SDL.Texture) + , '("src_x", CInt) + , '("src_y", CInt) + , '("src_w", CInt) + , '("src_h", CInt) + + , '("dst_x", CInt) + , '("dst_y", CInt) + , '("dst_w", CInt) + , '("dst_h", CInt) + ] +copyTexturePart + ( (coerce -> texture) + + :> (coerce -> sx) + :> (coerce -> sy) + :> (coerce -> sh) + :> (coerce -> sw) + + :> (coerce -> dx) + :> (coerce -> dy) + :> (coerce -> dh) + :> (coerce -> dw) + :> EmptyArgs) = do + copyTexturePart' texture sx sy sh sw dx dy dh dw + pure Nothing + +copyTextureRotated :: BuiltInFnWithDoc + '[ '("texture", SDL.Texture) + , '("src_x", CInt) + , '("src_y", CInt) + , '("src_w", CInt) + , '("src_h", CInt) + + , '("dst_x", CInt) + , '("dst_y", CInt) + , '("dst_w", CInt) + , '("dst_h", CInt) + + , '("rotation_deg", CDouble) + , '("rotation_x", CInt) + , '("rotation_y", CInt) + + , '("flipx", Bool) + , '("flipy", Bool) + ] +copyTextureRotated + ( (coerce -> texture) + + :> (coerce -> sx) + :> (coerce -> sy) + :> (coerce -> sh) + :> (coerce -> sw) + + :> (coerce -> dx) + :> (coerce -> dy) + :> (coerce -> dh) + :> (coerce -> dw) + + :> (coerce -> rDeg) + :> (coerce -> rx) + :> (coerce -> ry) + + :> (coerce -> flipx) + :> (coerce -> flipy) + + :> EmptyArgs) = do + copyTextureRotated' texture sx sy sh sw dx dy dh dw rDeg rx ry flipx flipy + pure Nothing + getDefaultWindow :: InterpretM SDL.Window getDefaultWindow = isDefaultWindow <$> get >>= \case Just x -> pure x @@ -105,12 +277,21 @@ (Just False) -> draw' _ -> pure () -setDrawColor :: BuiltInFnWithDoc ['("red_component", Word8), '("green_component", Word8), '("blue_component", Word8)] +setDrawColor :: BuiltInFnWithDoc '[ '("red_component", Word8), '("green_component", Word8), '("blue_component", Word8)] setDrawColor ((coerce -> r) :> (coerce -> g) :> (coerce -> b) :> _) = do - getDefaultRenderer >>= \renderer -> do - SDL.rendererDrawColor renderer $= V4 r g b 0 + setDrawColor' r g b 255 pure Nothing +setDrawColorAlpha :: BuiltInFnWithDoc '[ '("red_component", Word8), '("green_component", Word8), '("blue_component", Word8), '("alpha", Word8)] +setDrawColorAlpha ((coerce -> r) :> (coerce -> g) :> (coerce -> b) :> (coerce -> a) :> _) = do + setDrawColor' r g b a + pure Nothing + +setDrawColor' :: Word8 -> Word8 -> Word8 -> Word8 -> InterpretM () +setDrawColor' r g b a = do + getDefaultRenderer >>= \renderer -> do + SDL.rendererDrawColor renderer $= V4 r g b a + clear :: BuiltInFnWithDoc '[] clear _ = do getDefaultRenderer >>= SDL.clear @@ -132,6 +313,11 @@ drawLines :: BuiltInFnWithDoc '[ '("points", VS.Vector (SDL.Point V2 CInt))] drawLines ((coerce -> v) :> _) = do + drawLines' v + pure Nothing + +drawLines' :: VS.Vector (SDL.Point V2 CInt) -> InterpretM () +drawLines' v = do renderer <- getDefaultRenderer SDL.drawLines renderer v if VS.length v > 0 then do @@ -140,8 +326,70 @@ SDL.drawPoint renderer last' else pure () drawIfNotAccelerated + +v2ToTuple :: Point V2 a -> (a, a) +v2ToTuple (P (V2 a b)) = (a, b) + +v2Fst :: Point V2 a -> a +v2Fst (P (V2 a _)) = a + +v2Snd :: Point V2 a -> a +v2Snd (P (V2 _ a)) = a + +drawPoly :: BuiltInFnWithDoc '[ '("points", VS.Vector (SDL.Point V2 CInt)), '("fill", Maybe Bool)] +drawPoly ((coerce -> v) :> (coerce -> f) :> EmptyArgs) = do + drawPoly' v f pure Nothing +drawPoly' :: VS.Vector (SDL.Point V2 CInt) -> Maybe Bool -> InterpretM () +drawPoly' v f = do + let fill = fromMaybe False f + renderer <- getDefaultRenderer + SDL.drawLines renderer v + if VS.length v > 0 then do + let last' = VS.last v + let first' = VS.head v + SDL.drawLine renderer last' first' + SDL.drawPoint renderer last' + SDL.drawPoint renderer last' + if fill then do + let points = v2ToTuple <$> (VS.toList v) + let pointsY = snd <$> points + let between v1 (b1, b2) = (b1 <= v1 && b2 >= v1) || (b2 <= v1 && b1 >= v1) + let minY = minimum pointsY + let maxY = maximum pointsY + let pointPairs = zip points ((drop 1 points) <> [head points]) + let + getXes :: CInt -> [Maybe CInt] + getXes y = + flip fmap pointPairs $ \((x1, y1), (x2, y2)) -> + if y `between` (y1, y2) + then + if (not $ y1 == y2) + then do + let slope = ((realToFrac $ x2 - x1) :: Double)/(realToFrac $ y2 - y1) + Just $ x1 + (round $ (realToFrac $ y - y1 :: Double) * slope) + else Nothing + else Nothing + let + dlPairs :: MonadIO m => [(CInt, CInt)] -> m () + dlPairs ((x1, y1) : (x2, y2) : xs) = do + SDL.drawLine renderer (mkPoint x1 y1) (mkPoint x2 y2) + dlPairs xs + dlPairs _ = pure () + let + drawY :: MonadIO m => CInt -> m () + drawY y = do + let mxses = getXes y + let xses = catMaybes mxses + let cords = zip (DL.sort $ DL.nub xses) (repeat y) + dlPairs cords + forM_ [minY..maxY] drawY + else pure () + else pure () + + drawIfNotAccelerated + drawLine :: BuiltInFnWithDoc ['("start_x", CInt), '("start_y", CInt), '("end_x", CInt), '("end_y", CInt)] drawLine ((coerce -> x) :> (coerce -> y) :> (coerce -> xEnd) :> (coerce -> yEnd) :>_) = do renderer <- getDefaultRenderer @@ -168,19 +416,28 @@ drawIfNotAccelerated pure Nothing -drawCircle :: BuiltInFnWithDoc ['("center_x", Double), '("center_y", Double), '("radius", Double)] -drawCircle ((coerce -> x) :> (coerce -> y) :> (coerce -> radius) :> _) = do - renderer <- getDefaultRenderer - let fullCircle = 2.0 * pi - let segments = 50 - let (oneSegment :: Double) = fullCircle/segments - let points = VS.fromList $ (\a -> mkPoint (round $ x + cos (oneSegment * a) * radius) (round $ y + sin (oneSegment * a) * radius)) <$> [0..segments] - SDL.drawLines renderer points - let last' = VS.last points - SDL.drawPoint renderer last' - SDL.drawPoint renderer last' - drawIfNotAccelerated +drawArc :: BuiltInFnWithDoc ['("center_x", CInt), '("center_y", CInt), '("radius", Double), '("angle_start", Double), '("angle_end", Double), '("fill", Maybe Bool)] +drawArc ((coerce -> x) :> (coerce -> y) :> (coerce -> radius) :> (coerce -> angles) :> (coerce -> anglee) :> (coerce -> f) :> _) = do + drawArc' x y radius (fromMaybe False f) angles anglee pure Nothing + +drawCircle :: BuiltInFnWithDoc ['("center_x", CInt), '("center_y", CInt), '("radius", Double), '("fill", Maybe Bool)] +drawCircle ((coerce -> x) :> (coerce -> y) :> (coerce -> radius) :> (coerce -> f) :> _) = do + drawArc' x y radius (fromMaybe False f) 0 360 + pure Nothing + +drawArc' :: CInt -> CInt -> Double -> Bool -> Double -> Double -> InterpretM () +drawArc' x y radius f angles anglee = do + let start_angle = angles * 2 * pi / 360 + let end_angle = anglee * 2 * pi / 360 + let one_degree = 2 * pi / 360 + let angle_list = takeWhile (\a -> a <= end_angle) $ (DL.iterate' (+ one_degree) start_angle) + let dx = realToFrac x + let dy = realToFrac y + let points = (\a -> mkPoint (round $ dx + (cos a) * radius) (round $ dy + (sin a) * radius)) <$> (angle_list <> [end_angle]) + if f then drawPoly' (VS.fromList (points <> [mkPoint x y])) (Just True) + else drawLines' (VS.fromList points) + drawIfNotAccelerated waitForSDLKey :: BuiltInFnWithDoc '[] waitForSDLKey _ = do diff --git a/src/Interpreter/Lib/String.hs b/src/Interpreter/Lib/String.hs --- a/src/Interpreter/Lib/String.hs +++ b/src/Interpreter/Lib/String.hs @@ -25,6 +25,22 @@ builtInSplit ((coerce -> b) :> (coerce -> d) :> EmptyArgs) = pure $ Just $ ArrayValue $ V.fromList $ StringValue <$> T.splitOn b d +builtInTrim :: BuiltInFnWithDoc '[ '("text", Text)] +builtInTrim ((coerce -> d) :> EmptyArgs) = + pure $ Just $ StringValue $ T.strip d + +builtInToLower :: BuiltInFnWithDoc '[ '("text", Text)] +builtInToLower ((coerce -> d) :> EmptyArgs) = + pure $ Just $ StringValue $ T.toLower d + +builtInToUpper :: BuiltInFnWithDoc '[ '("text", Text)] +builtInToUpper ((coerce -> d) :> EmptyArgs) = + pure $ Just $ StringValue $ T.toUpper d + +builtInReplace :: BuiltInFnWithDoc '[ '("needle", Text), '("replacement", Text), '("haystack", Text) ] +builtInReplace ((coerce -> needle) :> (coerce -> replacement) :> (coerce -> haystack) :> EmptyArgs) = + pure $ Just $ StringValue $ T.replace needle replacement haystack + builtInToString :: BuiltInFnWithDoc '[ '("value", Value)] builtInToString ((coerce -> b) :> EmptyArgs) = pure $ Just $ StringValue $ toStringVal b diff --git a/src/UI/Chars.hs b/src/UI/Chars.hs --- a/src/UI/Chars.hs +++ b/src/UI/Chars.hs @@ -25,3 +25,9 @@ verticalRight :: Char verticalRight = chr 0x2524 + +block :: Char +block = chr 0x2588 + +downarrow :: Char +downarrow = chr 0x25bc diff --git a/src/UI/Terminal/IO.hs b/src/UI/Terminal/IO.hs --- a/src/UI/Terminal/IO.hs +++ b/src/UI/Terminal/IO.hs @@ -6,7 +6,10 @@ ) where import Data.Text (Text) +import Data.Text.IO as T import qualified System.IO as S +import qualified System.Console.ANSI as A +import Control.Monad.IO.Class class Monad m => HasTerminal m where setCursorPosition :: Int -> Int -> m () @@ -21,3 +24,27 @@ hWaitForInput :: m Bool clearscreen :: m () clearline :: m () + +instance (Monad m, MonadIO m) => HasTerminal m where + setCursorPosition x y = do + liftIO $ A.setCursorPosition y x + hFlush + hideCursor = liftIO A.hideCursor + showCursor = do + liftIO A.showCursor + hFlush + putText t = liftIO $ do + T.putStr t + putTextFlush t = do + putText t + hFlush + hFlush = liftIO $ S.hFlush S.stdout + hSetEcho h b = liftIO $ S.hSetEcho h b + hGetChar = liftIO $ S.hGetChar S.stdin + hSetBuffering h b = liftIO $ S.hSetBuffering h b + hWaitForInput = liftIO $ S.hWaitForInput S.stdin 0 + clearscreen = do + liftIO A.clearScreen + hFlush + clearline = liftIO $ A.hClearFromCursorToLineEnd S.stdout + diff --git a/src/UI/Widgets/AutoComplete.hs b/src/UI/Widgets/AutoComplete.hs --- a/src/UI/Widgets/AutoComplete.hs +++ b/src/UI/Widgets/AutoComplete.hs @@ -69,6 +69,7 @@ hasCapability (ContainerCap _ (_ :: Proxy cnt)) = case eqT @cnt @([(Text, Text)]) of Just Refl -> Just Dict Nothing -> Nothing + hasCapability _ = Nothing instance Drawable AutoCompleteWidget where setVisibility ref v = modifyWRef ref (\c -> c { acwVisibility = v }) @@ -95,5 +96,5 @@ else csPutText (colorTextFg White (T.pack $ printf stx (snd item))) autoComplete - :: WidgetM m (WRef AutoCompleteWidget) + :: WidgetC m => m (WRef AutoCompleteWidget) autoComplete = newWRef $ AutoCompleteWidget [] 0 origin False diff --git a/src/UI/Widgets/BorderBox.hs b/src/UI/Widgets/BorderBox.hs --- a/src/UI/Widgets/BorderBox.hs +++ b/src/UI/Widgets/BorderBox.hs @@ -24,10 +24,6 @@ resize ref cb = modifyWRef ref (\low -> low { bbwDim = cb $ bbwDim low }) -instance Widget BorderBoxWidget where - hasCapability (DrawableCap _) = Just Dict - hasCapability _ = Nothing - instance Drawable BorderBoxWidget where setVisibility ref v = modifyWRef ref (\b -> b { bbwVisible = v }) getVisibility ref = bbwVisible <$> readWRef ref @@ -44,11 +40,16 @@ move a (moveDown 1 $ moveRight 1 $ bbwPos w) draw a +instance Widget BorderBoxWidget where + hasCapability (DrawableCap _) = Just Dict + hasCapability (MoveableCap _) = Just Dict + hasCapability _ = Nothing + borderBox - :: forall m. ScreenPos + :: forall m. WidgetC m => ScreenPos -> Dimensions -> SomeWidgetRef - -> WidgetM m (WRef BorderBoxWidget) + -> m (WRef BorderBoxWidget) borderBox pos dim child = do newWRef $ BorderBoxWidget diff --git a/src/UI/Widgets/Common.hs b/src/UI/Widgets/Common.hs --- a/src/UI/Widgets/Common.hs +++ b/src/UI/Widgets/Common.hs @@ -42,9 +42,9 @@ import qualified System.IO as S data WidgetState = WidgetState - { wsWidgets :: Map Int SomeWidget - , wsCursorWidget :: Maybe SomeKeyInputWidget -- Widget that authoritativly decide the status/location of cursor. Does not decide what widgets receive keyboard input - , wsCursorVisible :: Bool + { wsWidgets :: Map Int SomeWidget + , wsCursorWidget :: Maybe SomeKeyInputWidget -- Widget that authoritativly decide the status/location of cursor. Does not decide what widgets receive keyboard input + , wsCursorVisible :: Bool } data UIState = UIState @@ -58,12 +58,13 @@ class HasCharScreen m where csInitialize :: Dimensions -> m () csClear :: m () - csDraw :: m () + csClearLine :: m () + csDraw :: Maybe (ScreenPos, Dimensions) -> m () csPutText :: StyledText -> m () csSetCursorPosition :: Int -> Int -> m () setCursorVisibility :: WidgetC m => Bool -> m () -setCursorVisibility b = modify $ liftWSMod (\ws -> ws { wsCursorVisible = b }) +setCursorVisibility b = modifyWidgetState (\ws -> ws { wsCursorVisible = b }) emptyWidgetState :: WidgetState emptyWidgetState = do @@ -74,67 +75,120 @@ dfr <- emptyDiffRender dim pure $ UIState emptyWidgetState dfr -type WidgetM m a = MonadIO m => StateT UIState m a +type WidgetM m a = (MonadIO m, WidgetC m) => m a -runWidgetM' :: MonadIO m => WidgetM m a -> m (a, UIState) +runWidgetM' :: MonadIO m => StateT UIState m a -> m (a, UIState) runWidgetM' act = do ws <- liftIO $ emptyUIState $ Dimensions 0 0 runWidgetM'' ws act -runWidgetM'' :: MonadIO m => UIState -> WidgetM m a -> m (a, UIState) +runWidgetM'' :: MonadIO m => UIState -> StateT UIState m a -> m (a, UIState) runWidgetM'' ws act = flip runStateT ws act -runWidgetM :: MonadIO m => WidgetM m a -> m a +runWidgetM :: MonadIO m => StateT UIState m a -> m a runWidgetM act = fst <$> runWidgetM' act +class HasDiffRender m where + getDiffRender :: m DiffRender + putDiffRender :: DiffRender -> m () + modifyDiffRender :: (DiffRender -> DiffRender) -> m () + +class HasWidgetState m where + getWidgetState :: m WidgetState + getWidgetStateMaybe :: m (Maybe WidgetState) + putWidgetState :: WidgetState -> m () + modifyWidgetState :: (WidgetState -> WidgetState) -> m () + +instance MonadIO m => HasDiffRender (StateT UIState m) where + getDiffRender = usDiffRender <$> get + putDiffRender dfr = modify (\us -> us { usDiffRender = dfr }) + modifyDiffRender fn = modify (\us -> us { usDiffRender = fn $ usDiffRender us }) + +instance MonadIO m => HasWidgetState (StateT UIState m) where + getWidgetState = usWidgetState <$> get + getWidgetStateMaybe = (Just . usWidgetState) <$> get + putWidgetState ws = modify (\us -> us { usWidgetState = ws }) + modifyWidgetState fn = modify (\us -> us { usWidgetState = fn $ usWidgetState us }) + type WidgetC m = - ( HasCallStack - , HasCharScreen m - , HasRandom m + ( HasRandom m , HasLog m , HasTerminal m - , MonadState UIState m , MonadIO m + , HasDiffRender m + , HasWidgetState m + , Typeable m ) getScreenBounds :: WidgetC m => m Dimensions getScreenBounds = do - screenState <- (dfScreenState . usDiffRender) <$> get + screenState <- dfScreenState <$> getDiffRender let screenLines = ssLines screenState screenColumns = ssColumns screenState pure $ Dimensions screenColumns (MV.length screenLines) -instance MonadIO m => HasRandom (StateT UIState m) where +instance MonadIO m => HasRandom m where getRandom = liftIO randomIO -instance MonadIO m => HasCharScreen (StateT UIState m) where +instance (MonadIO m, WidgetC m) => HasCharScreen m where csInitialize dim = do emptyDfr <- liftIO $ emptyDiffRender dim - modify (\ws -> ws { usDiffRender = emptyDfr }) + putDiffRender emptyDfr - csClear = usDiffRender <$> get >>= dfClear + csClear = do + dfIn <- getDiffRender + let bb = dfScreenStateBack dfIn + liftIO $ MV.set (ssLines bb) [Plain (T.replicate (ssColumns bb) " ")] - csDraw = do - nDfr <- usDiffRender <$> get >>= dfDraw Nothing - modify (\ws -> ws { usDiffRender = nDfr }) + csClearLine = do + dfIn <- getDiffRender + let bb = dfScreenStateBack dfIn + liftIO $ MV.modify (ssLines bb) (\_ -> [Plain (T.replicate (ssColumns bb) " ")]) (sY $ ssCursorPos bb) - (wsCursorVisible . usWidgetState) <$> get >>= \case - False -> pure () - True -> - ((wsCursorWidget . usWidgetState) <$> get) >>= \case - Just (SomeKeyInputWidget fref) -> getCursorInfo fref >>= \case - Just (cl, csst) -> do - liftIO $ A.setCursorPosition (sY cl) (sX cl) - putTextFlush $ cursorStyleCode csst - Nothing -> pure () - Nothing -> pure () + -- This function accepts a screen position and a window dimension to which the + -- output should be rendered. This is used to render the program output to the + -- output widget when the program is executed in the IDE. + csDraw mScreenParams = do + dfr@(DiffRender { dfDebug = _, dfScreenStateBack = (ssLines -> ssb), dfScreenState = (ssLines -> ss) }) <- getDiffRender + let + (screenOffsetX, screenOffsetY) = case mScreenParams of + Just (sp, _) -> (sX sp, sY sp) + Nothing -> (0, 0) - csPutText t = usDiffRender <$> get >>= dfPutText t + liftIO $ MV.imapM_ (\idx neLine -> do + oldLine <- MV.read ss idx + if (oldLine /= neLine) + then do + -- if isDebug then + -- appendLog (oldLine, neLine) + -- else pass + A.setCursorPosition (idx + screenOffsetY) screenOffsetX + -- mapM_ (\x -> do T.putStr x; S.hFlush S.stdout; wait 0.05;) (stRender <$> neLine) + mapM_ T.putStr (stRender <$> neLine) + S.hFlush S.stdout + else pure () + ) ssb + liftIO $ copyScreenState (dfScreenStateBack dfr) (dfScreenState dfr) + getWidgetStateMaybe >>= \case + Nothing -> pass + Just ws -> do + case wsCursorVisible ws of + False -> pass + True -> + case wsCursorWidget ws of + Just (SomeKeyInputWidget fref) -> getCursorInfo fref >>= \case + Just (cl, csst) -> do + liftIO $ A.setCursorPosition (sY cl + screenOffsetY) (sX cl + screenOffsetX) + putTextFlush $ cursorStyleCode csst + Nothing -> pass + Nothing -> pass + + csPutText t = getDiffRender >>= dfPutText t + csSetCursorPosition x y = do - dfr <- usDiffRender <$> get - modify (\ws -> ws { usDiffRender = dfSetCursorPosition x y dfr }) + modifyDiffRender (dfSetCursorPosition (const x) (const y)) getTerminalSizeIO :: IO (Maybe (Int, Int)) getTerminalSizeIO = do @@ -142,32 +196,6 @@ Just (y, x) -> pure $ Just (x, y) Nothing -> pure Nothing -instance MonadIO m => HasTerminal (StateT UIState m) where - setCursorPosition x y = do - liftIO $ A.setCursorPosition y x - hFlush - hideCursor = liftIO A.hideCursor - showCursor = do - liftIO A.showCursor - hFlush - putText t = liftIO $ do - T.putStr t - putTextFlush t = do - putText t - hFlush - hFlush = liftIO $ S.hFlush S.stdout - hSetEcho h b = liftIO $ S.hSetEcho h b - hGetChar = liftIO $ S.hGetChar S.stdin - hSetBuffering h b = liftIO $ S.hSetBuffering h b - hWaitForInput = liftIO $ S.hWaitForInput stdin 0 - clearscreen = do - liftIO A.clearScreen - hFlush - clearline = liftIO $ A.hClearFromCursorToLineEnd stdout - -instance MonadIO m => HasLog (StateT UIState m) where - appendLog a = liftIO (appendLog a) - -- Below, the type parameter `a` is left in case we need to use tagged -- references, like an IORef. newtype WRef (a :: Type) = WRef Int @@ -182,6 +210,8 @@ strToKeyEvent ('\ESC': '[' : 'F' : rst) = (KeyCtrl False False False End) : strToKeyEvent rst strToKeyEvent ('\ESC': '[' : 'C' : rst) = (KeyCtrl False False False ArrowRight) : strToKeyEvent rst strToKeyEvent ('\ESC': '[' : 'D' : rst) = (KeyCtrl False False False ArrowLeft) : strToKeyEvent rst +strToKeyEvent ('\ESC': '[' : '5': '~': rst) = (KeyCtrl False False False PageUp) : strToKeyEvent rst +strToKeyEvent ('\ESC': '[' : '6': '~': rst) = (KeyCtrl False False False PageDown) : strToKeyEvent rst strToKeyEvent ('\ESC': '[' : '2' : '~': rst) = (KeyCtrl False False False Insert) : strToKeyEvent rst strToKeyEvent ('\ESC': '[' : '3' : '~': rst) = (KeyCtrl False False False Del) : strToKeyEvent rst strToKeyEvent ('\ESC': '[' : '1' : '5': '~': rst) = (KeyCtrl False False False (Fun 5)) : strToKeyEvent rst @@ -198,10 +228,12 @@ -- Linux term strToKeyEvent ('\ESC': '[' : '[' : 'E': rst) = (KeyCtrl False False False (Fun 5)) : strToKeyEvent rst +strToKeyEvent ('\ESC': '[' : 'Z': rst) = (KeyCtrl False True False Tab) : strToKeyEvent rst -- strToKeyEvent ('\ESC': c : rst ) = (KeyChar False False True c) : strToKeyEvent rst strToKeyEvent ('\ESC' : rst) = (KeyCtrl False False False Esc) : strToKeyEvent rst strToKeyEvent ('\n': rst) = (KeyCtrl False False False Return) : strToKeyEvent rst +strToKeyEvent ('\t': rst) = (KeyCtrl False False False Tab) : strToKeyEvent rst strToKeyEvent str = KeyChar False False False <$> str -- Some terminals sets the eighth bit, instead of sending @@ -219,7 +251,7 @@ readTerminalEvent = TERM.awaitEvent >>= \case Left _ -> do pure [TerminalInterrupt] - Right x -> + Right x -> do case x of TERM.WindowEvent TERM.WindowSizeChanged -> do TERM.Size h w <- TERM.getWindowSize @@ -231,12 +263,15 @@ 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.PageUpKey -> [setModifiers mods $ KeyCtrl False False False PageUp] + TERM.PageDownKey -> [setModifiers mods $ KeyCtrl False False False PageDown] 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] + TERM.TabKey -> [setModifiers mods $ KeyCtrl False False False Tab] _ -> [] _ -> pure [] where @@ -246,18 +281,18 @@ readKey :: IO [KeyEvent] readKey = do - k <- readKey_ + k <- readKey_ S.stdin pure $ strToKeyEvent k -readKey_ :: IO String -readKey_ = do - char <- S.hGetChar S.stdin +readKey_ :: S.Handle -> IO String +readKey_ h = do + char <- S.hGetChar h readRest [char] where readRest :: [Char] -> IO [Char] - readRest t = S.hWaitForInput stdin 0 >>= \case + readRest t = S.hWaitForInput h 0 >>= \case True -> do - c <- S.hGetChar S.stdin + c <- S.hGetChar h readRest (c:t) False -> pure $ Prelude.reverse t @@ -275,22 +310,22 @@ readWRef :: forall a m. (WidgetC m, Widget a) => WRef a -> m a readWRef (WRef ref) = do - (fromMaybe (error "not found") . M.lookup ref . wsWidgets . usWidgetState) <$> get >>= \case + (fromMaybe (error "not found") . M.lookup ref . wsWidgets) <$> getWidgetState >>= \case SomeWidget w -> case cast w of Just a -> pure a Nothing -> error "Unexpected type" modifyWRef :: (WidgetC m, Widget a) => WRef a -> (a -> a) -> m () modifyWRef (WRef ref) fn = - modify $ liftWSMod $ \s -> s { wsWidgets = M.update (Just . (modifySomeWidget fn)) ref $ wsWidgets s } + modifyWidgetState $ \s -> s { wsWidgets = M.update (Just . (modifySomeWidget fn)) ref $ wsWidgets s } modifyWRefM :: (WidgetC m, Widget a) => WRef a -> (a -> m a) -> m () modifyWRefM (WRef ref) fn = do - m <- (wsWidgets . usWidgetState) <$> get + m <- wsWidgets <$> getWidgetState case M.lookup ref m of Just sw -> do nSw <- modifySomeWidgetM fn sw - modify $ liftWSMod $ \s -> s { wsWidgets = M.update (\_ -> Just nSw) ref $ wsWidgets s } + modifyWidgetState $ \s -> s { wsWidgets = M.update (\_ -> Just nSw) ref $ wsWidgets s } Nothing -> pure () modifySomeWidget :: Widget a => (a -> a) -> SomeWidget -> SomeWidget @@ -310,7 +345,7 @@ newWRef :: (WidgetC m, Widget a) => a -> m (WRef a) newWRef a = do ref <- getRandom - modify $ liftWSMod $ \s -> s { wsWidgets = M.insert ref (SomeWidget a) $ wsWidgets s } + modifyWidgetState $ \s -> s { wsWidgets = M.insert ref (SomeWidget a) $ wsWidgets s } pure (WRef ref) data CtrlKey @@ -323,8 +358,11 @@ | ArrowRight | ArrowUp | ArrowDown + | PageUp + | PageDown | Backspace | Fun Int + | Tab | Return deriving (Show, Ord, Eq) @@ -340,20 +378,42 @@ 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 +pushTerminalEventToHandle handle' kv = do + case kv of + TerminalKey (KeyChar False False False c) -> do + SIO.hPutChar handle' c + SIO.hFlush handle' + TerminalKey (KeyCtrl False False False Del) -> do + SIO.hPutStr handle' "\ESC[3~" + SIO.hFlush handle' + TerminalKey (KeyCtrl False False False Backspace) -> do + SIO.hPutChar handle' '\DEL' + 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' + TerminalKey (KeyCtrl False False False Tab) -> do + SIO.hPutChar handle' '\t' + SIO.hFlush handle' + TerminalKey (KeyCtrl False True False Tab) -> do + SIO.hPutStr handle' "\ESC[Z" + SIO.hFlush handle' + TerminalKey (KeyCtrl False False False ArrowUp) -> do + SIO.hPutStr handle' "\ESC[1;2A" + SIO.hFlush handle' + TerminalKey (KeyCtrl False False False ArrowDown) -> do + SIO.hPutStr handle' "\ESC[1;2B" + SIO.hFlush handle' + TerminalKey (KeyCtrl False False False ArrowLeft) -> do + SIO.hPutStr handle' "\ESC[D" + SIO.hFlush handle' + TerminalKey (KeyCtrl False False False ArrowRight) -> do + SIO.hPutStr handle' "\ESC[C" + SIO.hFlush handle' + _ -> pass data TerminalException = TerminalException Text @@ -368,8 +428,16 @@ getCursor :: m CursorInfo class Layout a where - addWidget :: (WidgetC m, Widget child) => WRef a -> Text -> WRef child -> m () + addWidget' :: (WidgetC m, Widget child) => WRef a -> StackingOrder -> WRef child -> m () + addWidget :: (WidgetC m, Widget child) => WRef a -> WRef child -> m () + addWidget ref cref = addWidget' ref 0 cref + focusNext :: (WidgetC m) => WRef a -> Int -> m Bool + +class Focusable a where + setFocus :: WidgetC m => WRef a -> Bool -> m () + getFocus :: WidgetC m => WRef a -> m Bool + class Drawable a where draw :: WidgetC m => WRef a -> m () setVisibility :: WidgetC m => WRef a -> Bool -> m () @@ -393,10 +461,12 @@ handleInput :: WidgetC m => WRef a -> KeyEvent -> m () data WidgetCapability a (c :: Constraint) where + FocusableCap :: WRef a -> WidgetCapability a (Focusable a) KeyInputCap :: WRef a -> WidgetCapability a (KeyInput a) MoveableCap :: WRef a -> WidgetCapability a (Moveable a) SelectableCap :: WRef a -> WidgetCapability a (Selectable a) DrawableCap :: WRef a -> WidgetCapability a (Drawable a) + LayoutCap :: WRef a -> WidgetCapability a (Layout a) ContainerCap :: Typeable cnt => WRef a -> Proxy cnt -> WidgetCapability a (Container a cnt) class Typeable a => Widget a where @@ -413,6 +483,9 @@ data SomeWidgetRef where SomeWidgetRef :: forall a. (Typeable a, Widget a) => WRef a -> SomeWidgetRef +instance Show SomeWidgetRef where + show _ = "(Widget)" + data SomeKeyInputWidget where SomeKeyInputWidget :: KeyInput a => WRef a -> SomeKeyInputWidget @@ -451,15 +524,22 @@ csPutText $ Plain $ C.concat [C.singleton verticalLine] ) -drawBorderBox :: WidgetC m => ScreenPos -> Dimensions -> m () -drawBorderBox sp Dimensions {..} = do +drawBorderBox' :: WidgetC m => ScreenPos -> Dimensions -> (Text -> StyledText) -> m () +drawBorderBox' sp Dimensions {..} fn = do wSetCursor sp - csPutText $ Plain $ C.concat [C.singleton cornerLT, C.replicate (diW - 2) (C.singleton horizontalLine), C.singleton cornerRT] + csPutText $ fn $ C.concat [C.singleton cornerLT, C.replicate (diW - 2) (C.singleton horizontalLine), C.singleton cornerRT] wSetCursor $ moveDown (diH - 1) sp - csPutText $ Plain $ C.concat [C.singleton cornerLB, C.replicate (diW - 2) (C.singleton horizontalLine), C.singleton cornerRB] + csPutText $ fn $ C.concat [C.singleton cornerLB, C.replicate (diW - 2) (C.singleton horizontalLine), C.singleton cornerRB] forM_ [1..(diH - 2)] (\r -> do wSetCursor $ moveDown r sp - csPutText $ Plain $ C.concat [C.singleton verticalLine] + csPutText $ fn $ C.concat [C.singleton verticalLine] wSetCursor $ moveRight (diW - 1) $ moveDown r sp - csPutText $ Plain $ C.concat [C.singleton verticalLine] + csPutText $ fn $ C.concat [C.singleton verticalLine] ) + +drawBorderBox :: WidgetC m => ScreenPos -> Dimensions -> m () +drawBorderBox sp dim = drawBorderBox' sp dim Plain + +type StackingOrder = Int + +data StackedWidget = StackedWidget { swSo :: StackingOrder, swSw :: SomeWidgetRef } diff --git a/src/UI/Widgets/Editor.hs b/src/UI/Widgets/Editor.hs --- a/src/UI/Widgets/Editor.hs +++ b/src/UI/Widgets/Editor.hs @@ -368,10 +368,14 @@ | otherwise = (r1, r2) data CursorMovement - = CVert CursorMovementVertical | CRIGHT Int | CLEFT | CHOME | CEND + = CVert CursorMovementVertical + | CRIGHT Int + | CLEFT + | CHOME + | CEND data CursorMovementVertical - = CUP | CDOWN + = CUP Int | CDOWN Int adjustScrollOffset :: WidgetC m => WRef EditorWidget -> m () adjustScrollOffset r = @@ -386,7 +390,6 @@ putCursor :: Maybe [Int] -> Int -> EditorWidget -> EditorWidget putCursor mll nc ew = let lineLengths = fromMaybe (getLineLengths ew) mll - (currentCursorSp, _) = ewCursorInfo ew in case offsetToScreenPos contentWidth lineLengths nc of Just (newsp, cl) -> let newEw = ew { ewCursorLine = cl, ewCursorInfo = (newsp, cStyle), ewCursor = nc } @@ -451,8 +454,8 @@ where newSp' = case cm of - CUP -> moveUp 1 currentSp - CDOWN -> moveDown 1 currentSp + CUP x -> moveUp x currentSp + CDOWN x -> moveDown x currentSp (currentSp, cStyle) = ewCursorInfo ew lineLengths = T.length <$> contentLines contentLines = getContetLines $ ewContent ew @@ -464,8 +467,10 @@ then pure ew else do case ev of - KeyCtrl _ sh _ ArrowUp -> simpleCursorMovement (CVert CUP) sh - KeyCtrl _ sh _ ArrowDown -> simpleCursorMovement (CVert CDOWN) sh + KeyCtrl _ sh _ ArrowUp -> simpleCursorMovement (CVert (CUP 1)) sh + KeyCtrl _ sh _ ArrowDown -> simpleCursorMovement (CVert (CDOWN 1)) sh + KeyCtrl _ sh _ PageUp -> simpleCursorMovement (CVert (CUP (diH $ ewDim ew))) sh + KeyCtrl _ sh _ PageDown -> simpleCursorMovement (CVert (CDOWN (diH $ ewDim ew))) sh KeyCtrl _ sh _ End -> simpleCursorMovement CEND sh KeyCtrl _ sh _ Home -> simpleCursorMovement CHOME sh KeyCtrl _ sh _ ArrowRight -> simpleCursorMovement (CRIGHT 1) sh @@ -559,14 +564,14 @@ then do setVisibility ac False else do - (ewAutocompleteSuggestions ew) key >>= \case - [] -> setVisibility ac False - [s] -> if (fst s) == key - then setVisibility ac False - else pass - suggestions@(_:_) -> withCapability (ContainerCap ac (Proxy @[(Text, Text)])) $ do - setContent ac (sortBy (\(a1, _) (a2, _) -> compare (T.length a1) (T.length a2)) suggestions) - setVisibility ac True + (ewAutocompleteSuggestions ew) key >>= \case + [] -> setVisibility ac False + [s] -> if (fst s) == key + then setVisibility ac False + else withCapability (ContainerCap ac (Proxy @[(Text, Text)])) $ setContent ac [s] + suggestions@(_:_) -> withCapability (ContainerCap ac (Proxy @[(Text, Text)])) $ do + setContent ac (sortBy (\(a1, _) (a2, _) -> compare (T.length a1) (T.length a2)) suggestions) + setVisibility ac True pure () Nothing -> pure () diff --git a/src/UI/Widgets/Layout.hs b/src/UI/Widgets/Layout.hs --- a/src/UI/Widgets/Layout.hs +++ b/src/UI/Widgets/Layout.hs @@ -1,7 +1,5 @@ module UI.Widgets.Layout where -import Data.Coerce -import Data.Map.Ordered as OMap import Data.Maybe import Common @@ -17,20 +15,23 @@ data LayoutWidget = LayoutWidget { lowDim :: Dimensions , lowPos :: ScreenPos - , lowContent :: OMap ContentId SomeWidgetRef + , lowContent :: [SomeWidgetRef] , lowOrientation :: Orientation , lowVisibility :: Bool , lowFloatingContent :: [SomeWidgetRef] - , lowDimensionDistribution :: Int -> [Double] + , lowDimensionDistribution :: [[Double]] } instance Layout LayoutWidget where - addWidget ref (coerce -> contentId) child = - modifyWRef ref (\low -> low { lowContent = (lowContent low) |> (contentId, (SomeWidgetRef child)) }) + addWidget ref child = + modifyWRef ref (\low -> low { lowContent = (lowContent low) ++ [(SomeWidgetRef child)] }) + addWidget' _ _ _ = undefined + focusNext _ = undefined instance Widget LayoutWidget where hasCapability (DrawableCap _) = Just Dict hasCapability (MoveableCap _) = Just Dict + hasCapability (LayoutCap _) = Just Dict hasCapability _ = Nothing instance Moveable LayoutWidget where @@ -57,11 +58,11 @@ case b of True -> pure $ Just sw _ -> pure Nothing - Nothing -> pure Nothing) (snd <$> (OMap.assocs $ lowContent w)) + Nothing -> pure Nothing) (lowContent w) let itemCount = Prelude.length visibileItems - dimensionDistribution = lowDimensionDistribution w itemCount + dimensionDistribution = if itemCount < (Prelude.length (lowDimensionDistribution w)) then (lowDimensionDistribution w) !! itemCount else error ("Dimension distribution has too few items: " <> (show (itemCount, lowDimensionDistribution w))) resizeCallback d = case lowOrientation w of Vertical -> (\dm -> dm { diW = diW $ lowDim w , diH = d}) Horizontal -> (\dm -> dm { diH = diH $ lowDim w, diW = d }) @@ -101,14 +102,14 @@ layoutWidget :: WidgetC m => Orientation - -> (Int -> [Double]) + -> [[Double]] -> m (WRef LayoutWidget) layoutWidget ori distr = do newWRef $ LayoutWidget { lowDim = Dimensions 0 0 , lowPos = origin - , lowContent = OMap.empty + , lowContent = [] , lowOrientation = ori , lowVisibility = True , lowFloatingContent = [] diff --git a/src/UI/Widgets/LogWidget.hs b/src/UI/Widgets/LogWidget.hs --- a/src/UI/Widgets/LogWidget.hs +++ b/src/UI/Widgets/LogWidget.hs @@ -47,7 +47,7 @@ draw (lwContentWidget w) logWidget - :: forall m. WidgetM m (WRef LogWidget) + :: forall m. WidgetC m => m (WRef LogWidget) logWidget = do ew <- editor (\_ -> pure []) Nothing modifyWRef ew (\ew' -> ew' { ewParams = (ewParams ew') { epBorder = False, epGutterSize = 0, epLinenumberRightPad = 0, epLineNos = False }}) diff --git a/src/UI/Widgets/MenuContainer.hs b/src/UI/Widgets/MenuContainer.hs --- a/src/UI/Widgets/MenuContainer.hs +++ b/src/UI/Widgets/MenuContainer.hs @@ -100,10 +100,11 @@ Nothing -> pure () menuContainer - :: SomeWidgetRef + :: WidgetC m + => SomeWidgetRef -> Menu -> SelectionHandler - -> WidgetM m (WRef MenuContainerWidget) + -> m (WRef MenuContainerWidget) menuContainer child menu handler = do newWRef $ MenuContainerWidget diff --git a/src/UI/Widgets/Spade/Button.hs b/src/UI/Widgets/Spade/Button.hs new file mode 100644 --- /dev/null +++ b/src/UI/Widgets/Spade/Button.hs @@ -0,0 +1,84 @@ +module UI.Widgets.Spade.Button where + +import qualified Data.Text as T +import Data.Typeable +import qualified System.Console.ANSI as A + +import Common +import DiffRender.DiffRender +import UI.Widgets.Common + +import Interpreter.Common +import Interpreter.Interpreter + +data ButtonWidget = ButtonWidget + { bwContent :: Text + , bwDim :: Dimensions + , bwPos :: ScreenPos + , bwVisibility :: Bool + , bwFocused :: Bool + , bwAction :: Maybe Callback + } + +instance Container ButtonWidget Text where + setContent ref t = modifyWRef ref (\w -> w { bwContent = t }) + getContent _ = error "undefined" + +instance KeyInput ButtonWidget where + handleInput :: forall m. WidgetC m => WRef ButtonWidget -> KeyEvent -> m () + handleInput ref ev = do + case ev of + KeyCtrl _ _ _ Return -> do + w <- readWRef ref + case (bwAction w) of + Just cb -> case eqT @m @(StateT InterpreterState IO) of + Just Refl -> void $ evaluateCallback cb [] + Nothing -> error "" + Nothing -> pure () + _ -> pass + getCursorInfo _ = pure Nothing + +instance Focusable ButtonWidget where + setFocus ref b = + modifyWRef ref (\w -> w { bwFocused = b }) + getFocus ref = + bwFocused <$> (readWRef ref) + +instance Widget ButtonWidget 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 (FocusableCap _) = Just Dict + hasCapability (KeyInputCap _) = Just Dict + hasCapability _ = Nothing + +instance Moveable ButtonWidget where + getPos ref = bwPos <$> readWRef ref + move ref pos = + modifyWRef ref (\b -> b { bwPos = pos }) + getDim ref = bwDim <$> readWRef ref + resize _ _ = pure () + +instance Drawable ButtonWidget where + setVisibility ref v = modifyWRef ref (\b -> b { bwVisibility = v }) + getVisibility ref = bwVisibility <$> readWRef ref + draw ref = do + w <- readWRef ref + if (bwFocused w) + then drawBorderBox' (bwPos w) (bwDim w) (\x -> StyledText (Fg A.Red) [Plain x]) + else drawBorderBox' (bwPos w) (bwDim w) Plain + wSetCursor (moveDown 1 $ moveRight 1 $ bwPos w) + csPutText $ Plain $ T.replicate ((diW $ bwDim w) - 2) " " + wSetCursor (moveDown 1 $ moveRight 2 $ bwPos w) + csPutText $ Plain $ T.take (diW $ bwDim w) $ bwContent w + +button + :: WidgetC m + => ScreenPos + -> Dimensions + -> Text + -> Maybe Callback + -> m (WRef ButtonWidget) +button sp dim label cb = newWRef $ ButtonWidget label dim sp True False cb diff --git a/src/UI/Widgets/Spade/Input.hs b/src/UI/Widgets/Spade/Input.hs new file mode 100644 --- /dev/null +++ b/src/UI/Widgets/Spade/Input.hs @@ -0,0 +1,71 @@ +module UI.Widgets.Spade.Input where + +import qualified Data.Text as T +import qualified System.Console.ANSI as A + +import Common +import DiffRender.DiffRender +import UI.Chars +import UI.Widgets.Common +import UI.Widgets.Editor + +data InputWidget = InputWidget + { iwEditor :: WRef EditorWidget + , iwFocused :: Bool + } + +instance Widget InputWidget 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 (FocusableCap _) = Just Dict + hasCapability (KeyInputCap _) = Just Dict + hasCapability _ = Nothing + +instance Drawable InputWidget where + draw ref = do + w <- readWRef ref + let ed = iwEditor w + pos <- moveLeft 1 <$> getPos ed + dim <- getDim ed + let + styleFn = if iwFocused w + then (\x -> StyledText (Fg A.Red) [Plain x]) + else Plain + forM_ [0..(diH dim - 1)] (\r -> do + wSetCursor $ moveDown r pos + csPutText $ styleFn $ T.singleton verticalLine + ) + draw ed + getVisibility ref = (iwEditor <$> readWRef ref) >>= getVisibility + setVisibility ref v =(iwEditor <$> readWRef ref) >>= (flip setVisibility v) + +instance Moveable InputWidget where + getPos ref = iwEditor <$> (readWRef ref) >>= getPos >>= (pure . moveLeft 1) + move ref pos = (iwEditor <$> readWRef ref) >>= (flip move (moveRight 1 pos)) + getDim ref = iwEditor <$> (readWRef ref) >>= getDim >>= (pure . amendWidth (\x -> x + 1)) + resize ref cb = + (iwEditor <$> readWRef ref) >>= (flip resize (amendWidth (\x -> x - 1) . cb)) + +instance Focusable InputWidget where + setFocus ref b = modifyWRef ref (\w -> w { iwFocused = b }) + getFocus ref =(iwFocused <$> readWRef ref) + +instance KeyInput InputWidget where + getCursorInfo _ = pure Nothing + handleInput ref ev = do + ed <- iwEditor <$> readWRef ref + handleInput ed ev + draw ref + +input + :: WidgetC m + => Dimensions + -> m (WRef InputWidget) +input dim = do + ew <- editor (\_ -> pure []) Nothing + modifyWRef ew (\e -> e { ewParams = EditorParams 0 0 0 False False }) + resize ew (\_ -> amendWidth (\x -> x - 1) dim) + newWRef $ InputWidget ew False diff --git a/src/UI/Widgets/Spade/Layout.hs b/src/UI/Widgets/Spade/Layout.hs new file mode 100644 --- /dev/null +++ b/src/UI/Widgets/Spade/Layout.hs @@ -0,0 +1,236 @@ +module UI.Widgets.Spade.Layout where + +import Data.Maybe +import Data.List (sortBy) + +import Common +import UI.Widgets.Common + +data Orientation + = Vertical + | Horizontal + deriving Show + +newtype ContentId = ContentId Text + deriving (Show, Ord, Eq) + +data LayoutWidget = LayoutWidget + { lowDim :: Dimensions + , lowPos :: ScreenPos + , lowContent :: [StackedWidget] + , lowOrientation :: Orientation + , lowVisibility :: Bool + , lowFloatingContent :: [SomeWidgetRef] + , lowDimensionDistribution :: [[Double]] + , lowFocusWidget :: Maybe (Int, SomeWidgetRef) + , lowFocused :: Bool + , lowResizeChildren :: Bool + } + +instance Focusable LayoutWidget where + getFocus ref = lowFocused <$> readWRef ref + setFocus ref b = do + modifyWRef ref (\w' -> w' { lowFocused = b }) + w <- readWRef ref + case lowFocusWidget w of + Just (_, SomeWidgetRef elm) -> do + withCapability (FocusableCap elm) $ setFocus elm b + Nothing -> void $ setFocusAt ref 0 1 True + +instance KeyInput LayoutWidget where + getCursorInfo _ = pure Nothing + handleInput ref keyEvent = do + case keyEvent of + KeyCtrl _ False _ Tab -> void $ focusNext ref 1 + KeyCtrl _ True _ Tab -> void $ focusNext ref (-1) + _ -> do + w <- readWRef ref + case lowFocusWidget w of + Just (_, (SomeWidgetRef r)) -> case hasCapability (KeyInputCap r) of + Just Dict -> handleInput r keyEvent + Nothing -> pass + Nothing -> pass + +computeDim :: forall m. WidgetC m => Dimensions -> Orientation -> Bool -> [StackedWidget] -> m Dimensions +computeDim dim _ True _ = pure dim +computeDim _ _ False [] = pure $ Dimensions 0 0 +computeDim _ ori False children = do + dimensions <- mapM getChildDimension children + let heights = diH <$> dimensions + let widths = diW <$> dimensions + case ori of + Vertical -> pure $ Dimensions (Prelude.maximum widths) (sum heights) + Horizontal -> do + pure $ Dimensions (sum widths) (Prelude.maximum heights) + where + getChildDimension :: StackedWidget -> m Dimensions + getChildDimension (StackedWidget _ (SomeWidgetRef ref)) = withCapability (MoveableCap ref) $ getDim ref + +instance Layout LayoutWidget where + addWidget' ref so child = + modifyWRefM ref (\low -> do + let newContent = (lowContent low) ++ [(StackedWidget so (SomeWidgetRef child))] + pure low { lowContent = newContent }) + focusNext ref d = do + w <- readWRef ref + case lowFocusWidget w of + Just (cidx, (SomeWidgetRef cref)) -> do + case hasCapability (LayoutCap cref) of + Nothing -> do + setFocusAt ref (cidx + d) d True >>= \case + True -> setFocusAt ref cidx d False + _ -> pure False + Just Dict -> do + focusNext cref d >>= \case + True -> pure True + False -> do + setFocusAt ref (cidx + d) d True >>= \case + True -> setFocusAt ref cidx d False + _ -> pure False + + Nothing -> pure False + +setFocusAt :: WidgetC m => WRef LayoutWidget -> Int -> Int -> Bool -> m Bool +setFocusAt ref idx dir b = do + w <- readWRef ref + let cSize = Prelude.length (lowContent w) + if idx >= 0 && idx < cSize + then do + case (lowContent w) !! idx of + (StackedWidget _ (SomeWidgetRef c)) -> do + r <- case hasCapability (FocusableCap c) of + Just Dict -> do + setFocus c b + if b then modifyWRef ref (\w' -> w' { lowFocusWidget = Just (idx, SomeWidgetRef c) }) else pass + case hasCapability (KeyInputCap c) of + Just Dict -> do + modifyWidgetState (\ws -> ws { wsCursorVisible = True, wsCursorWidget = Just (SomeKeyInputWidget c) }) + _ -> pass + pure True + Nothing -> do + setFocusAt ref (idx + dir) dir b + pure r + else pure False + +instance Widget LayoutWidget where + hasCapability (DrawableCap _) = Just Dict + hasCapability (MoveableCap _) = Just Dict + hasCapability (LayoutCap _) = Just Dict + hasCapability (FocusableCap _) = Just Dict + hasCapability (KeyInputCap _) = Just Dict + hasCapability _ = Nothing + +instance Moveable LayoutWidget where + getPos ref = lowPos <$> readWRef ref + move ref pos = + modifyWRef ref (\low -> low { lowPos = pos }) + getDim ref = do + low <- readWRef ref + computeDim (lowDim low) (lowOrientation low) (lowResizeChildren low) (lowContent low) + resize ref cb = + modifyWRef ref (\low -> low { lowDim = cb $ lowDim low }) + +instance Drawable LayoutWidget where + setVisibility ref v = modifyWRef ref (\b -> b { lowVisibility = v }) + getVisibility ref = lowVisibility <$> readWRef ref + draw ref = do + w <- readWRef ref + let + dimension = case lowOrientation w of + Vertical -> (diH $ lowDim w) + Horizontal -> (diW $ lowDim w) + visibileItems <- catMaybes <$> mapM (\sw@(StackedWidget _ (SomeWidgetRef cw)) -> case hasCapability (DrawableCap cw) of + Just Dict -> do + b <- getVisibility cw + case b of + True -> pure $ Just sw + _ -> pure Nothing + Nothing -> pure Nothing) (lowContent w) + + let + itemCount = Prelude.length visibileItems + dimensionDistribution = (lowDimensionDistribution w) !! itemCount + resizeCallback d = case lowOrientation w of + Vertical -> (\dm -> dm { diW = diW $ lowDim w , diH = d}) + Horizontal -> (\dm -> dm { diH = diH $ lowDim w, diW = d }) + + if (lowResizeChildren w) + then do + foldM_ (\totalDim (idx, (fraction, StackedWidget _ (SomeWidgetRef cw))) -> + withCapability (MoveableCap cw) $ do + let thisDim' = + if (idx == itemCount) then (dimension - totalDim) else round $ (realToFrac dimension) * fraction + let thisDim = max thisDim' 3 + resize cw (resizeCallback thisDim) + pure (totalDim + thisDim) + ) 0 (Prelude.zip [1..] (Prelude.zip dimensionDistribution visibileItems)) + else do + let + resizeCallback' = case lowOrientation w of + Vertical -> (\dm -> dm { diW = diW $ lowDim w }) + Horizontal -> (\dm -> dm { diH = diH $ lowDim w }) + mapM_ (\(StackedWidget _ (SomeWidgetRef cw)) -> withCapability (MoveableCap cw) $ resize cw resizeCallback') (lowContent w) + + case (lowOrientation w) of + Vertical -> foldM_ (fny (sX $ lowPos w)) (sY $ lowPos w) $ swSw <$> visibileItems + Horizontal -> foldM_ (fn (sY $ lowPos w)) (sX $ lowPos w) $ swSw <$> visibileItems + mapM_ (\(SomeWidgetRef a) -> withCapability (DrawableCap a) $ draw a) $ sortBySo visibileItems + flip mapM_ (lowFloatingContent w) $ \(SomeWidgetRef f) -> do + withCapability (DrawableCap f) $ draw f + where + sortBySo :: [StackedWidget] -> [SomeWidgetRef] + sortBySo ws = swSw <$> (sortBy (\a b -> compare (swSo a) (swSo b)) ws) + + fny x y w = case w of + SomeWidgetRef a -> + withCapability (MoveableCap a) $ do + dim <- getDim a + move a (ScreenPos { sY = y, sX = x }) + pure (y + (diH dim)) + fn y x w = case w of + SomeWidgetRef a -> + withCapability (MoveableCap a) $ do + dim <- getDim a + move a (ScreenPos { sY = y, sX = x }) + pure (x + (diW dim)) + +layoutWidget + :: WidgetC m + => Orientation + -> [[Double]] + -> [SomeWidgetRef] + -> m (WRef LayoutWidget) +layoutWidget ori distr children = do + newWRef $ + LayoutWidget + { lowDim = Dimensions 1 1 + , lowPos = origin + , lowContent = (\c -> StackedWidget 0 c) <$> children + , lowOrientation = ori + , lowVisibility = True + , lowFloatingContent = [] + , lowDimensionDistribution = distr + , lowFocusWidget = Nothing + , lowFocused = False + , lowResizeChildren = True + } + +simpleLayoutWidget + :: WidgetC m + => Orientation + -> [SomeWidgetRef] + -> m (WRef LayoutWidget) +simpleLayoutWidget ori children = do + newWRef $ + LayoutWidget + { lowDim = Dimensions 1 1 + , lowPos = origin + , lowContent = (\c -> StackedWidget 0 c) <$> children + , lowOrientation = ori + , lowVisibility = True + , lowFloatingContent = [] + , lowDimensionDistribution = [] + , lowFocusWidget = Nothing + , lowFocused = False + , lowResizeChildren = False + } diff --git a/src/UI/Widgets/Spade/RefLabel.hs b/src/UI/Widgets/Spade/RefLabel.hs new file mode 100644 --- /dev/null +++ b/src/UI/Widgets/Spade/RefLabel.hs @@ -0,0 +1,47 @@ +module UI.Widgets.Spade.RefLabel where + +import qualified Data.Text as T +import Control.Concurrent.STM + +import DiffRender.DiffRender +import UI.Widgets.Common +import Interpreter.Common +import Common + +data TextRefLabelWidget = TextRefLabelWidget + { trwContent :: TMVar Value + , trwDim :: Dimensions + , trwPos :: ScreenPos + , trwVisibility :: Bool + } + +instance Widget TextRefLabelWidget where + hasCapability (DrawableCap _) = Just Dict + hasCapability (MoveableCap _) = Just Dict + hasCapability _ = Nothing + +instance Moveable TextRefLabelWidget where + getPos ref = trwPos <$> readWRef ref + move ref pos = + modifyWRef ref (\tcw -> tcw { trwPos = pos }) + getDim ref = trwDim <$> readWRef ref + resize ref cb = + modifyWRef ref (\tcw -> tcw { trwDim = cb $ trwDim tcw }) + +instance Drawable TextRefLabelWidget where + setVisibility ref v = modifyWRef ref (\b -> b { trwVisibility = v }) + getVisibility ref = trwVisibility <$> readWRef ref + draw ref = do + w <- readWRef ref + wSetCursor $ (moveRight 1 $ trwPos w) + csPutText $ Plain $ T.replicate (diW $ trwDim w) " " + (liftIO $ atomically $ readTMVar (trwContent w)) >>= \case + StringValue x -> csPutText $ Plain $ T.take (diW $ trwDim w) x + _ -> error "A text value is required for ref-label" +textRefLabel + :: WidgetC m + => ScreenPos + -> Dimensions + -> TMVar Value + -> m (WRef TextRefLabelWidget) +textRefLabel sp dim label = newWRef $ TextRefLabelWidget label dim sp True diff --git a/src/UI/Widgets/Spade/Selector.hs b/src/UI/Widgets/Spade/Selector.hs new file mode 100644 --- /dev/null +++ b/src/UI/Widgets/Spade/Selector.hs @@ -0,0 +1,168 @@ +module UI.Widgets.Spade.Selector where + +import qualified Data.Text as T +import Data.Typeable +import qualified System.Console.ANSI as A + +import Common +import DiffRender.DiffRender +import UI.Chars +import UI.Widgets.Common +import Interpreter.Common +import Interpreter.Interpreter + +setOptions :: WidgetC m => WRef SelectorWidget -> [(Value, Text)] -> m () +setOptions ref options = modifyWRef ref (\s -> s { selHiglighted = Nothing, selSelected = Nothing, selContent = options }) + +getOptions :: WidgetC m => WRef SelectorWidget -> m [(Value, Text)] +getOptions ref = selContent <$> readWRef ref + +getSelection :: WidgetC m => WRef SelectorWidget -> m (Maybe Value) +getSelection ref = do + w <- readWRef ref + let a = selSelected w + let options = selContent w + case a of + Just x -> do + case safeIndex options x of + Just (y, _) -> do + pure $ Just y + Nothing -> error "Invalid selection index" + Nothing -> pure Nothing + +data SelectorWidget = SelectorWidget + { selContent :: [(Value, Text)] + , selLabel :: Text + , selSelected :: Maybe Int + , selHiglighted :: Maybe Int + , selOpen :: Bool + , selOptionsBoxLength :: Int + , selDim :: Dimensions + , selPos :: ScreenPos + , selVisibility :: Bool + , selFocused :: Bool + , selOptionsScrollOffset :: Int + , selAction :: Maybe Callback + } + + +instance Widget SelectorWidget where + hasCapability (DrawableCap _) = Just Dict + hasCapability (MoveableCap _) = Just Dict + hasCapability (FocusableCap _) = Just Dict + hasCapability (KeyInputCap _) = Just Dict + hasCapability _ = Nothing + +instance Moveable SelectorWidget where + getPos ref = selPos <$> readWRef ref + move ref pos = + modifyWRef ref (\tcw -> tcw { selPos = pos }) + getDim ref = selDim <$> readWRef ref + resize ref cb = + modifyWRef ref (\tcw -> tcw { selDim = cb $ selDim tcw }) + +instance Drawable SelectorWidget where + setVisibility ref v = modifyWRef ref (\b -> b { selVisibility = v }) + getVisibility ref = selVisibility <$> readWRef ref + draw ref = do + w <- readWRef ref + let + maxOptionWidth = case selContent w of + [] -> 0 + x -> Prelude.maximum (T.length . snd <$> x) + let + styleFn = if selFocused w + then (\x -> StyledText (Fg A.Red) [Plain x]) + else Plain + let + displayLabel = case selSelected w of + Just idx -> case safeIndex (selContent w) idx of + Just t -> snd t + Nothing -> selLabel w + Nothing -> selLabel w + wSetCursor (selPos w) + csPutText $ styleFn $ T.singleton verticalLine + let + dropBoxWidth = max (diW $ selDim w) maxOptionWidth + cropWidth t = T.take (dropBoxWidth - 3) t + wSetCursor (moveRight 1 $ selPos w) + csPutText (Plain $ (T.singleton downarrow) <> " " <> cropWidth displayLabel) + if selOpen w + then do + let + printOption (idx, (_, txt)) = do + wSetCursor (moveRight 1 $ moveDown (idx+1) $ selPos w) + csPutText $ StyledText (FgBg A.White A.Black) [Plain $ T.replicate dropBoxWidth " "] + case selHiglighted w of + Just x -> if x == idx + (selOptionsScrollOffset w) + then csPutText (StyledText (FgBg A.Red A.Black) [Plain $ " " <> cropWidth txt]) + else csPutText (StyledText (FgBg A.White A.Black) [Plain $ " " <> cropWidth txt]) + Nothing -> csPutText (StyledText (FgBg A.White A.Black) [Plain $ " " <> cropWidth txt]) + let itemsLength = Prelude.length (selContent w) + let itemsBoxLength = min itemsLength (selOptionsBoxLength w) + let maxScrollOffset = max 0 (itemsLength - itemsBoxLength) + let maxScrollbarPos = itemsBoxLength - 1 + let mScrollbarPos = if maxScrollOffset > 0 then Just $ max 0 $ min maxScrollbarPos (div (maxScrollbarPos * (div (selOptionsScrollOffset w * 100) maxScrollOffset)) 100) else Nothing + mapM_ printOption $ Prelude.zip [0..] (Prelude.take itemsBoxLength $ Prelude.drop (selOptionsScrollOffset w) $ selContent w) + case mScrollbarPos of + Just scrollbarPos -> do + wSetCursor $ moveDown (scrollbarPos + 1) (moveRight (diW $ selDim w) $ selPos w) + csPutText $ Plain (T.singleton block) + Nothing -> pass + else pass + +instance KeyInput SelectorWidget where + handleInput :: forall m. WidgetC m => WRef SelectorWidget -> KeyEvent -> m () + handleInput ref ev = do + case ev of + KeyCtrl _ _ _ ArrowUp -> do + w <- readWRef ref + case selOpen w of + True -> modifyWRef ref (moveSelection -1) + False -> modifyWRef ref (\u -> u { selOpen = True }) + KeyCtrl _ _ _ ArrowDown -> do + w <- readWRef ref + case selOpen w of + True -> modifyWRef ref (moveSelection 1) + False -> modifyWRef ref (\u -> u { selOpen = True }) + KeyCtrl _ _ _ Return -> do + w <- readWRef ref + case selOpen w of + True -> do + modifyWRef ref (\u -> u { selSelected = selHiglighted w, selOpen = False }) + case selHiglighted w of + Just _ -> do + case (selAction w) of + Just cb -> case eqT @m @(StateT InterpreterState IO) of + Just Refl -> void $ evaluateCallback cb [WidgetValue (SomeWidgetRef ref)] + Nothing -> error "" + Nothing -> pass + Nothing -> pass + False -> pass + _ -> pass + getCursorInfo _ = pure Nothing + +moveSelection :: Int -> SelectorWidget -> SelectorWidget +moveSelection d w = let + newHiglighted = case selHiglighted w of + Just idx -> idx + d + Nothing -> 0 + newHiglighted' = max 0 (min newHiglighted ((Prelude.length (selContent w)) - 1)) + newScrollOffset = max 0 (newHiglighted' - 4) + in w { selOptionsScrollOffset = newScrollOffset, selHiglighted = Just newHiglighted' } + +instance Focusable SelectorWidget where + setFocus ref b = + modifyWRef ref (\w -> w { selFocused = b }) + getFocus ref = + selFocused <$> (readWRef ref) + +selector + :: WidgetC m + => Text + -> ScreenPos + -> Dimensions + -> [(Value, Text)] + -> Maybe Callback + -> m (WRef SelectorWidget) +selector label sp dim options action = newWRef $ SelectorWidget options label Nothing Nothing False 5 dim sp True False 0 action diff --git a/src/UI/Widgets/Spade/TextContainer.hs b/src/UI/Widgets/Spade/TextContainer.hs new file mode 100644 --- /dev/null +++ b/src/UI/Widgets/Spade/TextContainer.hs @@ -0,0 +1,119 @@ +module UI.Widgets.Spade.TextContainer where + +import qualified Data.Text as T +import Data.Typeable +import qualified System.Console.ANSI as A + +import Common +import UI.Chars +import DiffRender.DiffRender +import UI.Widgets.Common + +data TextContainerWidget = TextContainerWidget + { tcwContent :: Text + , tcwDim :: Dimensions + , tcwPos :: ScreenPos + , tcwVisibility :: Bool + , tcwFocused :: Bool + , tcwScrollOffset :: Int + } + +instance Container TextContainerWidget Text where + setContent ref t = do + modifyWRef ref (\tcw -> tcw { tcwContent = t }) + getContent ref = + 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 (FocusableCap _) = Just Dict + hasCapability (KeyInputCap _) = Just Dict + hasCapability _ = Nothing + +instance KeyInput TextContainerWidget where + getCursorInfo _ = pure Nothing + handleInput ref ev = case ev of + KeyCtrl _ _ _ ArrowUp -> modifyWRef ref (scroll -1) + KeyCtrl _ _ _ ArrowDown -> modifyWRef ref (scroll 1) + _ -> pass + +scroll :: Int -> TextContainerWidget -> TextContainerWidget +scroll d w = + let + contentWidth = (diW $ tcwDim w) - 2 + contentHeight = (diH $ tcwDim w) + contentLines' = + Prelude.concat $ (chunksOf contentWidth <$> (splitOn "\n" (tcwContent w))) + contentLinesSize = Prelude.length contentLines' + maxScrollOffset = max 0 (contentLinesSize - contentHeight) + newScrollOffset = tcwScrollOffset w + d + in w { tcwScrollOffset = min maxScrollOffset (max 0 newScrollOffset) } + +instance Moveable TextContainerWidget where + getPos ref = tcwPos <$> readWRef ref + move ref pos = + modifyWRef ref (\tcw -> tcw { tcwPos = pos }) + getDim ref = tcwDim <$> readWRef ref + resize ref cb = + modifyWRef ref (\tcw -> tcw { tcwDim = cb $ tcwDim tcw }) + +instance Focusable TextContainerWidget where + setFocus ref b = + modifyWRef ref (\w -> w { tcwFocused = b }) + getFocus ref = + tcwFocused <$> (readWRef ref) + +instance Drawable TextContainerWidget where + setVisibility ref v = modifyWRef ref (\b -> b { tcwVisibility = v }) + getVisibility ref = tcwVisibility <$> readWRef ref + draw :: forall m. WidgetC m => WRef TextContainerWidget -> m () + draw ref = do + w <- readWRef ref + let + styleFn = if tcwFocused w + then (\x -> StyledText (Fg A.Red) [Plain x]) + else Plain + + -- drawBorderBox' (tcwPos w) (tcwDim w) styleFn + forM_ [0..(diH $ tcwDim w)] (\r -> do + wSetCursor $ moveDown r (tcwPos w) + csPutText $ styleFn $ T.singleton verticalLine + ) + let + contentWidth = (diW $ tcwDim w) - 2 + contentHeight = (diH $ tcwDim w) + contentLines = + Prelude.concat (chunksOf contentWidth <$> (splitOn "\n" (tcwContent w))) + contentLinesSize = Prelude.length contentLines + visibleContentLines = Prelude.take contentHeight $ + Prelude.drop (tcwScrollOffset w) contentLines + maxScrollOffset = max 0 (contentLinesSize - contentHeight) + maxScrollbarPos = contentHeight - 1 -- Top most position of scroll bar is zero. This is converted to relative location later. + mScrollbarPos = if maxScrollOffset > 0 then Just $ max 0 $ min maxScrollbarPos (div (maxScrollbarPos * (div (tcwScrollOffset w * 100) maxScrollOffset)) 100) else Nothing + let + printLine :: (Int, Text) -> m () + printLine (ln, c) = do + wSetCursor $ moveDown ln (moveRight 1 $ tcwPos w) + csPutText $ Plain c + let emp = T.replicate ((diW $ tcwDim w) - 2) " " + mapM_ printLine (Prelude.zip [0..] (Prelude.take ((diH $ tcwDim w) - 2) $ Prelude.repeat emp)) + mapM_ printLine (Prelude.zip [0..] visibleContentLines) + if (tcwFocused w) then + case mScrollbarPos of + Just scrollbarPos -> do + wSetCursor $ moveDown scrollbarPos (moveRight ((diW $ tcwDim w) - 1) $ tcwPos w) + csPutText $ Plain (T.singleton block) + Nothing -> pass + else pass + where + +textContainer + :: WidgetC m + => ScreenPos + -> Dimensions + -> m (WRef TextContainerWidget) +textContainer sp dim = newWRef $ TextContainerWidget "" dim sp True False 0 diff --git a/src/UI/Widgets/Spade/TextLabel.hs b/src/UI/Widgets/Spade/TextLabel.hs new file mode 100644 --- /dev/null +++ b/src/UI/Widgets/Spade/TextLabel.hs @@ -0,0 +1,54 @@ +module UI.Widgets.Spade.TextLabel where + +import Data.Typeable +import qualified Data.Text as T + +import DiffRender.DiffRender +import UI.Widgets.Common +import Common + +data TextLabelWidget = TextLabelWidget + { tlwContent :: Text + , tlwDim :: Dimensions + , tlwPos :: ScreenPos + , tlwVisibility :: Bool + } + +instance Container TextLabelWidget Text where + setContent ref t = do + modifyWRef ref (\tcw -> tcw { tlwContent = t }) + getContent ref = + tlwContent <$> readWRef ref + +instance Widget TextLabelWidget 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 TextLabelWidget where + getPos ref = tlwPos <$> readWRef ref + move ref pos = + modifyWRef ref (\tcw -> tcw { tlwPos = pos }) + getDim ref = tlwDim <$> readWRef ref + resize ref cb = + modifyWRef ref (\tcw -> tcw { tlwDim = cb $ tlwDim tcw }) + +instance Drawable TextLabelWidget where + setVisibility ref v = modifyWRef ref (\b -> b { tlwVisibility = v }) + getVisibility ref = tlwVisibility <$> readWRef ref + draw ref = do + w <- readWRef ref + wSetCursor $ (moveRight 1 $ tlwPos w) + csPutText $ Plain $ T.replicate (diW $ tlwDim w) " " + csPutText $ Plain $ T.take (diW $ tlwDim w) $ tlwContent w + +textLabel + :: WidgetC m + => ScreenPos + -> Dimensions + -> Text + -> m (WRef TextLabelWidget) +textLabel sp dim label = newWRef $ TextLabelWidget label dim sp True diff --git a/src/UI/Widgets/TextContainer.hs b/src/UI/Widgets/TextContainer.hs --- a/src/UI/Widgets/TextContainer.hs +++ b/src/UI/Widgets/TextContainer.hs @@ -54,7 +54,8 @@ pure lns textContainer - :: ScreenPos + :: WidgetC m + => ScreenPos -> Dimensions - -> WidgetM m (WRef TextContainerWidget) + -> m (WRef TextContainerWidget) textContainer sp dim = newWRef $ TextContainerWidget "" dim sp True diff --git a/src/UI/Widgets/TitledContainer.hs b/src/UI/Widgets/TitledContainer.hs --- a/src/UI/Widgets/TitledContainer.hs +++ b/src/UI/Widgets/TitledContainer.hs @@ -53,7 +53,8 @@ draw cw titledContainer - :: SomeWidgetRef + :: WidgetC m + => SomeWidgetRef -> Text - -> WidgetM m (WRef TitledContainer) + -> m (WRef TitledContainer) titledContainer cont title = newWRef $ TitledContainer title cont (Dimensions 0 0) (ScreenPos 0 0) True False diff --git a/src/UI/Widgets/WatchWidget.hs b/src/UI/Widgets/WatchWidget.hs --- a/src/UI/Widgets/WatchWidget.hs +++ b/src/UI/Widgets/WatchWidget.hs @@ -55,7 +55,7 @@ joinItems (k, v) = k <> " = " <> v watchWidget - :: forall m. WidgetM m (WRef WatchWidget) + :: forall m. WidgetC m => m (WRef WatchWidget) watchWidget = do ew <- editor (\_ -> pure []) Nothing modifyWRef ew (\ew' -> ew' { ewParams = (ewParams ew') { epBorder = False, epGutterSize = 0, epLinenumberRightPad = 0, epLineNos = False }}) diff --git a/test/UI/EditorSpec.hs b/test/UI/EditorSpec.hs --- a/test/UI/EditorSpec.hs +++ b/test/UI/EditorSpec.hs @@ -24,7 +24,7 @@ , rssCursorInfo :: CursorInfo } -assertReferenceScreenState :: ReferenceScreenState -> WRef EditorWidget -> WidgetM IO () +assertReferenceScreenState :: ReferenceScreenState -> WRef EditorWidget -> StateT UIState IO () assertReferenceScreenState ReferenceScreenState {..} ewRef = do EditorWidget {..} <- readWRef ewRef ss <- (dfScreenState . usDiffRender) <$> get @@ -44,7 +44,7 @@ csClear mapM_ (handleInput ewRef) kEvents draw ewRef - csDraw + csDraw Nothing assertReferenceScreenState expectedSs ewRef mkKeys :: Int -> CtrlKey -> [KeyEvent] @@ -183,8 +183,8 @@ describe "Editor bottom cursor positioning" $ do it "test1" $ do let - test :: Expectation - test = do + test' :: Expectation + test' = do ew <- runWidgetM $ do csInitialize $ Dimensions 18 10 ewRef <- editor (\_ -> pure []) Nothing @@ -194,7 +194,7 @@ scrollToBottom ewRef readWRef ewRef (ewScrollOffset ew) `shouldBe` 10 - test + test' mkSimpleToken :: Text -> Int -> SimpleToken mkSimpleToken x offset = NormalToken x (Location 0 0 offset) (offset + T.length x - 1)