diff --git a/projects/kiss-vscode/src/Main.kiss b/projects/kiss-vscode/src/Main.kiss index a68dafc6..697e6c7e 100644 --- a/projects/kiss-vscode/src/Main.kiss +++ b/projects/kiss-vscode/src/Main.kiss @@ -1,5 +1,7 @@ -// This also loads Util.kiss: -(load "commands/ExtensionTools.kiss") +(#if test + (load "Util.kiss") + // This also loads Util.kiss: + (load "commands/ExtensionTools.kiss")) (function userHome [] (or (Sys.getEnv "MSYSHOME") (Sys.getEnv "HOME") (Sys.getEnv "UserProfile"))) (function userConfigDir [] @@ -23,6 +25,8 @@ (cmd.shift))] (trySpawnSync program cmd (object cwd activeConfigDir) handleConfigFailure))) +(#when test (var :String->Void warningMessage Prelude.printStr)) + (function :Void tryLoadConfig [&opt :Bool force :Bool fallbackToDefault :String _] (let [handleConfigFailure ->errorMessage { @@ -122,7 +126,8 @@ (let [uniqueConfigFile (joinPath activeConfigDir "$(.toShort (Uuid.v4)).js")] (File.copy file uniqueConfigFile) (set config (the KissConfig .KissConfig (Node.require uniqueConfigFile))) - (set Prelude.printStr ->:Void s (Vscode.window.showInformationMessage s)) + (#unless test + (set Prelude.printStr ->:Void s (Vscode.window.showInformationMessage s))) (set config.tryLoadConfig ->[&opt _] (tryLoadConfig true false)) (set config.extensionPath extensionPath) (config.prepareInterp) diff --git a/projects/kiss-vscode/src/Util.kiss b/projects/kiss-vscode/src/Util.kiss index c00f05b5..28ea6a17 100644 --- a/projects/kiss-vscode/src/Util.kiss +++ b/projects/kiss-vscode/src/Util.kiss @@ -1,118 +1,3 @@ -/** - * Aliases - */ - -// output -(defAlias &call infoMessage Vscode.window.showInformationMessage) -(defAlias &call warningMessage Vscode.window.showWarningMessage) -(defAlias &call errorMessage Vscode.window.showErrorMessage) - -// input -(defAlias &call inputBox Vscode.window.showInputBox) -(defAlias &call _quickPick Vscode.window.showQuickPick) - -(function quickPickItem [label &opt description] - (object - label label - description description - detail null - picked null - alwaysShow null)) - -(function quickPick [:Array strings] - (awaitLet [chosenItem (_quickPick (for string strings (quickPickItem string)))] - (when chosenItem chosenItem.label))) - -// thanks https://stackoverflow.com/a/69842249 -(function autoSuggestPick [:Array strings] - (new js.lib.Promise - ->[resolve reject] (let [qp (Vscode.window.createQuickPick) - :Array items (for string strings (quickPickItem string))] - (set qp.items items) - (qp.onDidChangeValue - ->v (unlessLet [(Some _) (indexOf strings v)] - (set qp.items (concat [(quickPickItem v)] items)))) - (qp.onDidAccept - ->_ { - (resolve .label (first qp.activeItems)) - (qp.hide) - }) - (qp.show)))) - -(function :js.lib.Promise.Thenable quickPickMap [:Map stringMap] - (awaitLet [chosenItem (_quickPick (for =>key value stringMap (quickPickItem key (Std.string value))))] - (when chosenItem (dictGet stringMap chosenItem.label)))) - -(defAlias &call openDialog Vscode.window.showOpenDialog) - -// commands -(defAlias &call executeCommand Vscode.commands.executeCommand) -(function repeatCommand [command times] - (let [iteration - ->[&opt _] (executeCommand command) - &mut promise - (iteration)] - (doFor i (range (- times 1)) - (set promise (promise.then iteration))) - promise)) - -(defMacro awaitCommands [commandsAndArgs &builder b &body body] - (let [commandsAndArgs - (if (isListExp commandsAndArgs) - (.copy (expList commandsAndArgs)) - (throw (CompileError.fromExp commandsAndArgs "First argument to awaitCommands should be a list of commands with optional argument arrays"))) - bindings []] - (while commandsAndArgs - (bindings.push (b.symbol "_")) - (let [nextCommand (commandsAndArgs.shift)] - (bindings.push (b.callSymbol "executeCommand" - (concat [nextCommand] (if (and commandsAndArgs (isListExp (first commandsAndArgs))) (expList (commandsAndArgs.shift)) [])))))) - `(awaitLet ,bindings ,@body))) - -// Other - -(defAlias &call showTextDocument Vscode.window.showTextDocument) -(defAlias &call openTextDocument Vscode.workspace.openTextDocument) - -// Macros for implementing commands in Kiss - -(defMacro withValueOrInputBox [v &body body] - `{ - (if ,v - {,@body} - (awaitLet [,v (inputBox)] - ,@body)) - null - }) - -(defMacro withValueOrQuickPick [v options &body body] - `(if ,v - {,@body} - (awaitLet [,v (quickPick ,options)] - ,@body))) - -(defMacro withValueOrQuickPickMap [v options &body body] - `(if ,v - {,@body} - (awaitLet [,v (quickPickMap ,options)] - ,@body))) - -(function :Void chooseFileInDir [:String->Void openFile :Bool allowNew &opt :String dir] - (withValueOrInputBox dir - (set dir (dir.replace "\\" "/")) - (when (dir.endsWith "/") (set dir (substr dir 0 -1))) - (awaitLet [dirOrFile ((if allowNew autoSuggestPick quickPick) (concat [".."] (sys.FileSystem.readDirectory dir)))] - (let [dirOrFile - (case dirOrFile - (".." - (substr dir 0 (dir.lastIndexOf "/"))) - (otherwise (joinPath dir dirOrFile)))] - (cond - ((sys.FileSystem.isDirectory dirOrFile) - (chooseFileInDir openFile allowNew dirOrFile)) - (true - (openFile dirOrFile))))))) - // This has to be a macro so it can return from tryLoadConfig // TODO this macro should use gensym (defMacro trySpawnSync [command args options onError] @@ -134,24 +19,140 @@ (,onError "result status is null from $command ${args}: $result.stdout $result.stderr") null))))) -(function :Void showCompileError [errorMessage] - (ifLet [compileErrors (R.distinctMatches - (R.group - (R.namedGroup "file" - (R.repeat (R.oneOf R.anyLetter R.anyDigit (R.escape "/")) 1) // filename - (R.escape ".kiss:") - (R.repeat R.anyDigit 1) // line - (R.escape ":") - (R.optional - (R.group - (R.repeat R.anyDigit 1) // column - (R.escape ":")))) - (R.repeat R.anyChar 1)) - errorMessage)] - { - (Vscode.window.showErrorMessage errorMessage) - (awaitLet [chosen (quickPickMap (for match compileErrors =>match.match match))] - (Vscode.window.showErrorMessage chosen.match) - (executeCommand "workbench.action.quickOpen" (substr (chosen.namedGroup "file") 0 -1))) - } - (Vscode.window.showErrorMessage errorMessage))) \ No newline at end of file +(#unless test + /** + * Aliases + */ + + // output + (defAlias &call infoMessage Vscode.window.showInformationMessage) + (defAlias &call warningMessage Vscode.window.showWarningMessage) + (defAlias &call errorMessage Vscode.window.showErrorMessage) + + // input + (defAlias &call inputBox Vscode.window.showInputBox) + (defAlias &call _quickPick Vscode.window.showQuickPick) + + (function quickPickItem [label &opt description] + (object + label label + description description + detail null + picked null + alwaysShow null)) + + (function quickPick [:Array strings] + (awaitLet [chosenItem (_quickPick (for string strings (quickPickItem string)))] + (when chosenItem chosenItem.label))) + + // thanks https://stackoverflow.com/a/69842249 + (function autoSuggestPick [:Array strings] + (new js.lib.Promise + ->[resolve reject] (let [qp (Vscode.window.createQuickPick) + :Array items (for string strings (quickPickItem string))] + (set qp.items items) + (qp.onDidChangeValue + ->v (unlessLet [(Some _) (indexOf strings v)] + (set qp.items (concat [(quickPickItem v)] items)))) + (qp.onDidAccept + ->_ { + (resolve .label (first qp.activeItems)) + (qp.hide) + }) + (qp.show)))) + + (function :js.lib.Promise.Thenable quickPickMap [:Map stringMap] + (awaitLet [chosenItem (_quickPick (for =>key value stringMap (quickPickItem key (Std.string value))))] + (when chosenItem (dictGet stringMap chosenItem.label)))) + + (defAlias &call openDialog Vscode.window.showOpenDialog) + + // commands + (defAlias &call executeCommand Vscode.commands.executeCommand) + (function repeatCommand [command times] + (let [iteration + ->[&opt _] (executeCommand command) + &mut promise + (iteration)] + (doFor i (range (- times 1)) + (set promise (promise.then iteration))) + promise)) + + (defMacro awaitCommands [commandsAndArgs &builder b &body body] + (let [commandsAndArgs + (if (isListExp commandsAndArgs) + (.copy (expList commandsAndArgs)) + (throw (CompileError.fromExp commandsAndArgs "First argument to awaitCommands should be a list of commands with optional argument arrays"))) + bindings []] + (while commandsAndArgs + (bindings.push (b.symbol "_")) + (let [nextCommand (commandsAndArgs.shift)] + (bindings.push (b.callSymbol "executeCommand" + (concat [nextCommand] (if (and commandsAndArgs (isListExp (first commandsAndArgs))) (expList (commandsAndArgs.shift)) [])))))) + `(awaitLet ,bindings ,@body))) + + // Other + + (defAlias &call showTextDocument Vscode.window.showTextDocument) + (defAlias &call openTextDocument Vscode.workspace.openTextDocument) + + // Macros for implementing commands in Kiss + + (defMacro withValueOrInputBox [v &body body] + `{ + (if ,v + {,@body} + (awaitLet [,v (inputBox)] + ,@body)) + null + }) + + (defMacro withValueOrQuickPick [v options &body body] + `(if ,v + {,@body} + (awaitLet [,v (quickPick ,options)] + ,@body))) + + (defMacro withValueOrQuickPickMap [v options &body body] + `(if ,v + {,@body} + (awaitLet [,v (quickPickMap ,options)] + ,@body))) + + (function :Void chooseFileInDir [:String->Void openFile :Bool allowNew &opt :String dir] + (withValueOrInputBox dir + (set dir (dir.replace "\\" "/")) + (when (dir.endsWith "/") (set dir (substr dir 0 -1))) + (awaitLet [dirOrFile ((if allowNew autoSuggestPick quickPick) (concat [".."] (sys.FileSystem.readDirectory dir)))] + (let [dirOrFile + (case dirOrFile + (".." + (substr dir 0 (dir.lastIndexOf "/"))) + (otherwise (joinPath dir dirOrFile)))] + (cond + ((sys.FileSystem.isDirectory dirOrFile) + (chooseFileInDir openFile allowNew dirOrFile)) + (true + (openFile dirOrFile))))))) + + (function :Void showCompileError [errorMessage] + (ifLet [compileErrors (R.distinctMatches + (R.group + (R.namedGroup "file" + (R.repeat (R.oneOf R.anyLetter R.anyDigit (R.escape "/")) 1) // filename + (R.escape ".kiss:") + (R.repeat R.anyDigit 1) // line + (R.escape ":") + (R.optional + (R.group + (R.repeat R.anyDigit 1) // column + (R.escape ":")))) + (R.repeat R.anyChar 1)) + errorMessage)] + { + (Vscode.window.showErrorMessage errorMessage) + (awaitLet [chosen (quickPickMap (for match compileErrors =>match.match match))] + (Vscode.window.showErrorMessage chosen.match) + (executeCommand "workbench.action.quickOpen" (substr (chosen.namedGroup "file") 0 -1))) + } + (Vscode.window.showErrorMessage errorMessage)))) \ No newline at end of file diff --git a/projects/kiss-vscode/test.sh b/projects/kiss-vscode/test.sh index bd743bda..3a272d6f 100755 --- a/projects/kiss-vscode/test.sh +++ b/projects/kiss-vscode/test.sh @@ -1,4 +1,4 @@ #! /bin/bash # Run the build without -D test first, to make sure it works that way too: -haxe build.hxml && haxe -D test build.hxml -cmd "node bin/extension.js" \ No newline at end of file +echo "!test" && haxe build.hxml && echo "test" && haxe -D test build.hxml -cmd "node bin/extension.js" \ No newline at end of file