├── AUTHORS ├── LICENSE ├── Readme.md ├── about-cl-jupyter.ipynb ├── about-cl-jupyter.pdf ├── cl-jupyter.lisp ├── clean.sh ├── install-cl-jupyter.py ├── profile ├── Jupiter's_storm.jpg ├── Portrait_of_Jupiter_from_Cassini.png ├── commonlisp.js ├── custom.js ├── fish.svg ├── fishbowl-small.svg ├── fishbowl.svg ├── jupyter-sq-text.svg └── lambda.svg └── src ├── cl-jupyter.asd ├── config.lisp ├── display.lisp ├── evaluator.lisp ├── iopub.lisp ├── kernel.lisp ├── message.lisp ├── myjson.lisp ├── packages.lisp ├── shell.lisp ├── user.lisp └── utils.lisp /AUTHORS: -------------------------------------------------------------------------------- 1 | 2 | cl-Jupyter Authors/Contributors 3 | =============================== 4 | 5 | Frederic Peschanski -- creator and maintainer 6 | 7 | Robert Dodier -- enhancements in startup/installation script 8 | 9 | Mike Mann -- installation script updates for Jupyter (Ipython 3.x) migration 10 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014-2015, Frederic Peschanski 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without modification, 5 | are permitted provided that the following conditions are met: 6 | 7 | * Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. 9 | 10 | * Redistributions in binary form must reproduce the above copyright notice, this 11 | list of conditions and the following disclaimer in the documentation and/or 12 | other materials provided with the distribution. 13 | 14 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 15 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 16 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 17 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR 18 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 19 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 20 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 21 | ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 22 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 23 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /Readme.md: -------------------------------------------------------------------------------- 1 | 2 | cl-jupyter 3 | ========== 4 | 5 | An enhanced interactive Shell for Common Lisp (based on the Jupyter protocol) 6 | 7 | ``` 8 | cl-jupyter: an enhanced interactive Common Lisp Shell 9 | (Version 0.8 - Jupyter protocol v.5.0) 10 | --> (C) 2014-2018 Frederic Peschanski (cf. LICENSE) 11 | __________ 12 | / /. 13 | .-----------------. /_________/ | 14 | / / | | | | 15 | /+================+\ | | |====| | | 16 | ||cl-jupyter || | | | | 17 | || || | | |====| | | 18 | ||* (fact 5) || | | | | 19 | ||120 || | | ___ | | 20 | || || | | |166| | | 21 | || ||/@@@ | --- | | 22 | \+================+/ @ |_________|./. 23 | @ .. ....' 24 | ..................@ __.'. ' '' 25 | /oooooooooooooooo// /// 26 | /................// /_/ 27 | ------------------ 28 | ``` 29 | 30 | **Important** : cl-jupyter is entering *maintenance*, I do not plan further enhancement beyond bug fixes. A derivative of cl-jupyter with more features supported is available at: https://github.com/yitzchak/common-lisp-jupyter 31 | 32 | ## Requirements ## 33 | 34 | To try cl-jupyter you need : 35 | 36 | - a Common lisp implementation, for now 37 | 38 | - either SBCL 1.3.x or above (with native threads enabled) 39 | 40 | - or Clozure CL 1.10 or above (with native threads enabled) ... 41 | 42 | - CLASP supported on a separate 'widget' branch (drmeister version) 43 | 44 | - ECL is planned, for other implementations please fill an issue. 45 | 46 | - Quicklisp (cf. http://www.quicklisp.org) 47 | 48 | - Python 3.x (cf. http://www.python.org) 49 | 50 | - Jupyter 4.x (cf. http://www.jupyter.org) 51 | 52 | ## Quick install ## 53 | 54 | Please run the installation script : 55 | 56 | python3 ./install-cl-jupyter.py 57 | 58 | By default, cl-jupyter assumes SBCL as the default lisp implementation. Using CCL instead requires 59 | the following command line: 60 | 61 | python3 ./install-cl-jupyter.py --lisp=ccl 62 | 63 | **Note**: cl-jupyter seems to work better with CCL on MacOS but on Linux everything's fine with SBCL 64 | and it is the most tested configuration. Alas, it seems cl-jupyter does *not* work on Windows (I cannot try myself). 65 | If using a VM I would recommend the Linux/SBCL configuration. 66 | 67 | As an optional step, you can pre-install the quicklisp dependencies to avoid 68 | a veeeerrrry long first startup. 69 | 70 | - using SBCL 71 | 72 | sbcl --load ./cl-jupyter.lisp 73 | 74 | - using CCL 75 | 76 | ccl --load ./cl-jupyter.lisp 77 | 78 | ## Running cl-jupyter 79 | 80 | The following commnad starts the jupyter notebook environment. 81 | 82 | jupyter notebook 83 | 84 | The file [about-cl-jupyter.ipynb](https://github.com/fredokun/cl-jupyter/blob/master/about-cl-jupyter.ipynb) is an example of a Lisp-based notebook. 85 | 86 | The file [about-cl-jupyter.pdf](https://github.com/fredokun/cl-jupyter/blob/master/about-cl-jupyter.pdf) is a printable PDF version of this notebook that can be generated by the Jupyter `nbconvert` tool. 87 | 88 | **Note**: the jupyter console and qtconsole are not (well) supported. 89 | 90 | ---- 91 | 92 | ... have fun ! 93 | 94 | -------------------------------------------------------------------------------- /about-cl-jupyter.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/fredokun/cl-jupyter/a2ecb82fafea1489aa869c12473ae999b3799684/about-cl-jupyter.pdf -------------------------------------------------------------------------------- /cl-jupyter.lisp: -------------------------------------------------------------------------------- 1 | ;; not yet installed in quicklisp directory 2 | (push (truename (format nil "~Asrc/" (directory-namestring *load-truename*))) 3 | asdf:*central-registry*) 4 | 5 | (let ((cmd-args 6 | ;; Borrowed from apply-argv, command-line-arguments. Temporary solution (?) 7 | ;; This is not PvE's code. 8 | #+sbcl (cdr sb-ext:*posix-argv*) ; remove the program argument 9 | #+clozure CCL:*UNPROCESSED-COMMAND-LINE-ARGUMENTS* ;(ccl::command-line-arguments) 10 | #+gcl si:*command-args* 11 | #+ecl (loop for i from 0 below (si:argc) collect (si:argv i)) 12 | #+cmu extensions:*command-line-strings* 13 | #+allegro (sys:command-line-arguments) 14 | #+lispworks sys:*line-arguments-list* 15 | #+clisp ext:*args* 16 | #-(or sbcl clozure gcl ecl cmu allegro lispworks clisp) 17 | (error "get-argv not supported for your implementation"))) 18 | (when (= (length cmd-args) 0) 19 | (progn 20 | (format t "... initialization mode... please wait...~%") 21 | (ql:quickload "cl-jupyter") 22 | (format t "... initialization done...~%") 23 | #+sbcl (sb-ext:exit :code 0) 24 | #+(or openmcl mcl) (ccl::quit) 25 | #-(or sbcl openmcl mcl) 26 | (error 'not-implemented :proc (list 'quit code)))) 27 | (when (not (>= (length cmd-args) 3)) 28 | (error "Wrong number of arguments (given ~A, expecting at least 3)" (length cmd-args))) 29 | (let ((def-dir (truename (car (last cmd-args 3))))) 30 | ;;(run-dir (truename (cadr cmd-args)))) 31 | ;; add the source directory to the ASDF registry 32 | ;; (format t "Definition dir = ~A~%" def-dir) 33 | (push def-dir asdf:*central-registry*))) 34 | 35 | 36 | ;; for debugging only: 37 | ;; (push (truename "./src/") asdf:*central-registry*) 38 | 39 | ;; activate debugging 40 | (declaim (optimize (speed 0) (space 0) (debug 3) (safety 3))) 41 | 42 | ;; in production (?) 43 | ;;(declaim (optimize (speed 3) (space 0) (debug 0) (safety 2))) 44 | 45 | (ql:quickload "cl-jupyter") 46 | 47 | (in-package #:cl-jupyter-user) 48 | 49 | ;; start main loop 50 | (cl-jupyter:kernel-start) 51 | 52 | -------------------------------------------------------------------------------- /clean.sh: -------------------------------------------------------------------------------- 1 | #! /bin/sh 2 | 3 | echo "* Removing temp files *" 4 | 5 | find . -type f -name "*~" -exec rm -vf {} \; 6 | 7 | -------------------------------------------------------------------------------- /install-cl-jupyter.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python3 2 | 3 | ## cl-Jupyter installation script 4 | 5 | ## Note: since the kernel of Jupyter is written itself in Python, 6 | ## it is much simpler to have a Python-based installation script. 7 | 8 | import subprocess 9 | import sys 10 | import shutil 11 | import os 12 | import json 13 | 14 | 15 | class RequirementException(BaseException): 16 | pass 17 | 18 | 19 | def halt(msg): 20 | print(msg, file=sys.stderr) 21 | print("Abort.", file=sys.stderr) 22 | sys.exit(1) 23 | 24 | 25 | CL_JUPYTER_HEADER = """ 26 | cl-Jupyter -- an enhanced interactive Common Lisp shell 27 | (C) 2014-2015 Frederic Peschanski (cf. LICENSE) 28 | ----""" 29 | 30 | print(CL_JUPYTER_HEADER) 31 | 32 | # check that we run as a script 33 | if __name__ != "__main__": 34 | halt("Error: cl-Jupyter startup must be run as a script") 35 | 36 | # check the python version, needs at least 3.2 37 | if sys.version_info.major < 3 \ 38 | or sys.version_info.minor < 3: 39 | halt("Error: cl-Jupyter requires Python v3.3 or above") 40 | 41 | # check if ipython is available 42 | try: 43 | import IPython 44 | except ImportError: 45 | halt("Error: IPython not available (check your Python Path)") 46 | 47 | # check Ipython version 48 | 49 | ipython_version_major, ipython_version_minor, ipython_version_patch, ipython_version_tag = IPython.version_info 50 | if ipython_version_major < 3: 51 | halt("Error: IPython v3.x required (found v{}.{})".format(ipython_version_major, ipython_version_minor)) 52 | 53 | print("... Frontend: using IPython v{}.{}".format(ipython_version_major, ipython_version_minor)) 54 | 55 | ################################### 56 | ## (Ad-hoc) command-line parsing ## 57 | ################################### 58 | 59 | class Config: 60 | def __init__(self): 61 | self.ipython_dir = IPython.paths.get_ipython_dir() 62 | self.ipython_profile_dir = self.ipython_dir + "/profile_cl_jupyter" 63 | self.lisp_implementation = "sbcl" # TODO: ccl support (others ? requires threading) 64 | self.lisp_executable = None # we'll derive executable from implementation later if need be 65 | self.ipython_executable = shutil.which("ipython3") 66 | self.ipython_command = "console" 67 | self.lisp_preload = None 68 | 69 | def process_command_line(argv): 70 | config = Config() 71 | 72 | import inspect 73 | import os.path 74 | config.cl_jupyter_startup_def_dir = os.path.dirname(os.path.realpath(inspect.getsourcefile(Config))) 75 | #print("cl-Jupyter startup def dir = {}".format(config.cl_jupyter_startup_def_dir)) 76 | 77 | config.cl_jupyter_startup_run_dir = os.path.realpath(os.getcwd()) 78 | #print("cl-Jupyter startup run dir = {}".format(config.cl_jupyter_startup_run_dir)) 79 | 80 | config.cl_jupyter_startup_script = os.path.realpath(argv[0]) 81 | #print("cl-Jupyter startup script = {}".format(config.cl_jupyter_startup_script)) 82 | 83 | i = 1 84 | if len(argv) > 1 and not (argv[i].startswith('-')): # first argument should be the ipython command 85 | config.ipython_command = argv[i] 86 | i += 1 87 | 88 | # print("IPython command = {}".format(config.ipython_command)) 89 | # default is "console" 90 | 91 | if config.ipython_command not in { "console", "notebook" }: 92 | halt("Error: command '{}' not available\n ==> choose 'console' (default) or 'notebook'".format(config.ipython_command)) 93 | 94 | profile_dir_set = False 95 | profile_set = False 96 | lisp_set = False 97 | lisp_exec_set = False 98 | ipython_exec_set = False 99 | 100 | while i < len(argv): 101 | #print("cmd line option #{}: {}".format(i, argv[i])) 102 | 103 | if argv[i].startswith("--profile-dir="): 104 | if profile_dir_set or profile_set: 105 | halt("Error: unexpected '--profile-dir' option, profile already set") 106 | config.ipython_profile_dir = argv[i][14:] 107 | profile_dir_set = True 108 | elif argv[i].startswith("--profile="): 109 | if profile_set or profile_dir_set: 110 | halt("Error: unexpected '--profile' option, profile already set") 111 | config.ipython_profile_dir = config.ipython_dir + "/profile_" + argv[i][10:] 112 | profile_set = True 113 | elif argv[i].startswith("--lisp="): 114 | if lisp_set: 115 | halt("Error: --lisp option set twice") 116 | config.lisp_implementation = argv[i][7:] 117 | lisp_set = True 118 | elif argv[i].startswith("--lisp-exec="): 119 | if lisp_exec_set: 120 | halt("Error: --lisp-exec option set twice") 121 | config.lisp_executable = argv[i][12:] 122 | lisp_exec_set = True 123 | elif argv[i].startswith("--ipython-exec="): 124 | if ipython_exec_set: 125 | halt("Error: --ipython-exec option set twice") 126 | config.ipython_executable = shutil.which(argv[i][15:]) 127 | ipython_exec_set = True 128 | elif argv[i].startswith("--lisp-preload="): 129 | config.lisp_preload = argv[i][15:] 130 | else: 131 | halt("Error: unexpected option '{}'".format(argv[i])) 132 | 133 | i += 1 134 | 135 | #print("IPython profile directory = {}".format(config.ipython_profile_dir)) 136 | #print("Lisp implementation = {}".format(config.lisp_implementation)) 137 | #print("IPython executable = {}".format(config.ipython_executable)) 138 | 139 | return config 140 | 141 | config = process_command_line(sys.argv) 142 | 143 | ################################### 144 | ## Check Ipython executable ## 145 | ################################### 146 | 147 | if not config.ipython_executable: 148 | halt("Error: Ipython executable not found") 149 | else: 150 | try: 151 | ipython_version_string = subprocess.check_output([config.ipython_executable, "--version"]).decode() 152 | except FileNotFoundError: 153 | halt("Error: cannot find ipython executable") 154 | except subprocess.CalledProcessError as e: 155 | halt("Error: {}".format(e)) 156 | 157 | #print("ipython version string = {}".format(ipython_version_string)) 158 | import re 159 | # cut off a hyphen and anything following, e.g. "2.4.2-maint" --> "2.4.2" 160 | foo = re.sub ("-.*$", "", ipython_version_string) 161 | ipython_version = tuple([int(d) for d in foo.split(".")]) 162 | #print("ipython version = {}".format(ipython_version)) 163 | if (ipython_version[0] != ipython_version_major) \ 164 | or (ipython_version[1] != ipython_version_minor): 165 | halt("Error: mismatch ipython version ({}.{} vs {}.{})".format(ipython_version[0], ipython_version[1], 166 | ipython_version_major, ipython_version_minor)) 167 | 168 | ################################### 169 | ## Check the lisp implementation ## 170 | ################################### 171 | 172 | if config.lisp_implementation == "sbcl": 173 | if not config.lisp_executable: 174 | config.lisp_executable = 'sbcl' 175 | 176 | try: 177 | sbcl_version_string = subprocess.check_output([config.lisp_executable, "--version"]).decode() 178 | except FileNotFoundError: 179 | halt("Error: Lisp executable '{0}' not in PATH".format (config.lisp_executable)) 180 | except subprocess.CalledProcessError as e: 181 | halt("Error: {} from SBCL".format(e)) 182 | 183 | print("sbcl reports version {}".format(sbcl_version_string)) 184 | 185 | import re 186 | try: 187 | regexp = re.compile(r'(\d+)\.(\d+)\.(\d+)') 188 | version = regexp.findall(sbcl_version_string)[0] 189 | except IndexError: 190 | halt("Error: issue with sbcl version string (please report)") 191 | 192 | config.sbcl_version = map(int, version) 193 | 194 | sbcl_min_version = (1, 2, 0) 195 | for have, need in zip(config.sbcl_version, sbcl_min_version): 196 | if have < need: 197 | message = "found {}; required: sbcl >= {}" 198 | message = message.format(config.sbcl_version, sbcl_min_version) 199 | raise RequirementException(message) 200 | 201 | print("... Kernel: using {}".format(sbcl_version_string)) 202 | 203 | elif config.lisp_implementation == "ccl": 204 | if not config.lisp_executable: 205 | config.lisp_executable = 'ccl' 206 | 207 | try: 208 | ccl_version_string = subprocess.check_output([config.lisp_executable, "-V"]).decode() 209 | except FileNotFoundError: 210 | halt("Error: Lisp executable '{0}' not in PATH".format (config.lisp_executable)) 211 | except subprocess.CalledProcessError as e: 212 | halt("Error: {} from CCL".format(e)) 213 | 214 | #print("ccl version string = {}".format(ccl_version_string)) 215 | 216 | 217 | import re 218 | m = re.match(r".*([0-9]+\.[0-9]+)", ccl_version_string) 219 | if not m: 220 | halt("Error: issue with ccl version string (please report)") 221 | 222 | config.ccl_version = tuple([int(d) for d in m.group(1).split(".")]) 223 | #print("ccl version = {}".format(config.ccl_version)) 224 | if config.ccl_version[0] < 1 or config.ccl_version[1] < 10: 225 | halt("Error: require CCL v1.10 or above") 226 | 227 | print("... Kernel: using {}".format(ccl_version_string)) 228 | 229 | elif config.lisp_implementation == "ecl": 230 | halt("Error: ECL not (yet) supported") 231 | elif config.lisp_implementation == "cmucl": 232 | halt("Error: CMUCL not (yet) supported") 233 | elif config.lisp_implementation == "clisp": 234 | halt("Error: CLisp not (yet) supported") 235 | else: 236 | halt("Error: Common Lisp implementation '{}' not supported".format(config.lisp_implementation)) 237 | 238 | 239 | ############################## 240 | ## Installation of kernel ## 241 | ############################## 242 | 243 | os.makedirs(config.ipython_dir + "/kernels/lisp", exist_ok=True) 244 | 245 | if config.lisp_implementation == "sbcl": 246 | KERNEL_SPEC = { 247 | "argv": [ 248 | config.lisp_executable,'--non-interactive', '--load', 249 | "{0}/cl-jupyter.lisp".format(config.cl_jupyter_startup_def_dir), 250 | "{0}/src".format(config.cl_jupyter_startup_def_dir), 251 | config.cl_jupyter_startup_def_dir, 252 | '{connection_file}'], 253 | "display_name": "SBCL Lisp", 254 | "language": "lisp" 255 | } 256 | elif config.lisp_implementation == "ccl": 257 | KERNEL_SPEC = { 258 | "argv": [ 259 | config.lisp_executable,'--batch', '--load', 260 | "{0}/cl-jupyter.lisp".format(config.cl_jupyter_startup_def_dir), "--", 261 | "{0}/src".format(config.cl_jupyter_startup_def_dir), 262 | config.cl_jupyter_startup_def_dir, 263 | '{connection_file}'], 264 | "display_name": "CCL Lisp", 265 | "language": "lisp" 266 | } 267 | else: 268 | halt("Error: unsupported lisp implementation '{}'".format(lisp_implementation)) 269 | 270 | with open(config.ipython_dir + "/kernels/lisp/kernel.json", "w") as kernel_spec_file: 271 | json.dump(KERNEL_SPEC, kernel_spec_file) 272 | 273 | print("Installation Complete.") 274 | 275 | 276 | 277 | 278 | -------------------------------------------------------------------------------- /profile/Jupiter's_storm.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/fredokun/cl-jupyter/a2ecb82fafea1489aa869c12473ae999b3799684/profile/Jupiter's_storm.jpg -------------------------------------------------------------------------------- /profile/Portrait_of_Jupiter_from_Cassini.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/fredokun/cl-jupyter/a2ecb82fafea1489aa869c12473ae999b3799684/profile/Portrait_of_Jupiter_from_Cassini.png -------------------------------------------------------------------------------- /profile/commonlisp.js: -------------------------------------------------------------------------------- 1 | // This file is extracted from CodeMirror V4 2 | 3 | // CodeMirror, copyright (c) by Marijn Haverbeke and others 4 | // Distributed under an MIT license: http://codemirror.net/LICENSE 5 | 6 | CodeMirror.defineMode("common-lisp", function (config) { 7 | console.log("Defining lisp mode"); 8 | 9 | var specialForm = /^(block|let*|return-from|catch|load-time-value|setq|eval-when|locally|symbol-macrolet|flet|macrolet|tagbody|function|multiple-value-call|the|go|multiple-value-prog1|throw|if|progn|unwind-protect|labels|progv|let|quote)$/; 10 | var assumeBody = /^with|^def|^do|^prog|case$|^cond$|bind$|when$|unless$/; 11 | var numLiteral = /^(?:[+\-]?(?:\d+|\d*\.\d+)(?:[efd][+\-]?\d+)?|[+\-]?\d+(?:\/[+\-]?\d+)?|#b[+\-]?[01]+|#o[+\-]?[0-7]+|#x[+\-]?[\da-f]+)/; 12 | var symbol = /[^\s'`,@()\[\]";]/; 13 | var type; 14 | 15 | function readSym(stream) { 16 | var ch; 17 | while (ch = stream.next()) { 18 | if (ch == "\\") stream.next(); 19 | else if (!symbol.test(ch)) { stream.backUp(1); break; } 20 | } 21 | return stream.current(); 22 | } 23 | 24 | function base(stream, state) { 25 | if (stream.eatSpace()) {type = "ws"; return null;} 26 | if (stream.match(numLiteral)) return "number"; 27 | var ch = stream.next(); 28 | if (ch == "\\") ch = stream.next(); 29 | 30 | if (ch == '"') return (state.tokenize = inString)(stream, state); 31 | else if (ch == "(") { type = "open"; return "bracket"; } 32 | else if (ch == ")" || ch == "]") { type = "close"; return "bracket"; } 33 | else if (ch == ";") { stream.skipToEnd(); type = "ws"; return "comment"; } 34 | else if (/['`,@]/.test(ch)) return null; 35 | else if (ch == "|") { 36 | if (stream.skipTo("|")) { stream.next(); return "symbol"; } 37 | else { stream.skipToEnd(); return "error"; } 38 | } else if (ch == "#") { 39 | var ch = stream.next(); 40 | if (ch == "[") { type = "open"; return "bracket"; } 41 | else if (/[+\-=\.']/.test(ch)) return null; 42 | else if (/\d/.test(ch) && stream.match(/^\d*#/)) return null; 43 | else if (ch == "|") return (state.tokenize = inComment)(stream, state); 44 | else if (ch == ":") { readSym(stream); return "meta"; } 45 | else return "error"; 46 | } else { 47 | var name = readSym(stream); 48 | if (name == ".") return null; 49 | type = "symbol"; 50 | if (name == "nil" || name == "t" || name.charAt(0) == ":") return "atom"; 51 | if (state.lastType == "open" && (specialForm.test(name) || assumeBody.test(name))) return "keyword"; 52 | if (name.charAt(0) == "&") return "variable-2"; 53 | return "variable"; 54 | } 55 | } 56 | 57 | function inString(stream, state) { 58 | var escaped = false, next; 59 | while (next = stream.next()) { 60 | if (next == '"' && !escaped) { state.tokenize = base; break; } 61 | escaped = !escaped && next == "\\"; 62 | } 63 | return "string"; 64 | } 65 | 66 | function inComment(stream, state) { 67 | var next, last; 68 | while (next = stream.next()) { 69 | if (next == "#" && last == "|") { state.tokenize = base; break; } 70 | last = next; 71 | } 72 | type = "ws"; 73 | return "comment"; 74 | } 75 | 76 | return { 77 | startState: function () { 78 | return {ctx: {prev: null, start: 0, indentTo: 0}, lastType: null, tokenize: base}; 79 | }, 80 | 81 | token: function (stream, state) { 82 | if (stream.sol() && typeof state.ctx.indentTo != "number") 83 | state.ctx.indentTo = state.ctx.start + 1; 84 | 85 | type = null; 86 | var style = state.tokenize(stream, state); 87 | if (type != "ws") { 88 | if (state.ctx.indentTo == null) { 89 | if (type == "symbol" && assumeBody.test(stream.current())) 90 | state.ctx.indentTo = state.ctx.start + config.indentUnit; 91 | else 92 | state.ctx.indentTo = "next"; 93 | } else if (state.ctx.indentTo == "next") { 94 | state.ctx.indentTo = stream.column(); 95 | } 96 | state.lastType = type; 97 | } 98 | if (type == "open") state.ctx = {prev: state.ctx, start: stream.column(), indentTo: null}; 99 | else if (type == "close") state.ctx = state.ctx.prev || state.ctx; 100 | return style; 101 | }, 102 | 103 | indent: function (state, _textAfter) { 104 | var i = state.ctx.indentTo; 105 | return typeof i == "number" ? i : state.ctx.start + 1; 106 | }, 107 | 108 | lineComment: ";;", 109 | blockCommentStart: "#|", 110 | blockCommentEnd: "|#" 111 | }; 112 | }); 113 | 114 | CodeMirror.defineMIME("text/x-common-lisp", "common-lisp"); 115 | 116 | -------------------------------------------------------------------------------- /profile/custom.js: -------------------------------------------------------------------------------- 1 | // leave at least 2 line with only a star on it below, or doc generation fails 2 | /** 3 | * 4 | * 5 | * Placeholder for custom user javascript 6 | * mainly to be overridden in profile/static/custom/custom.js 7 | * This will always be an empty file in IPython 8 | * 9 | * User could add any javascript in the `profile/static/custom/custom.js` file 10 | * (and should create it if it does not exist). 11 | * It will be executed by the ipython notebook at load time. 12 | * 13 | * Same thing with `profile/static/custom/custom.css` to inject custom css into the notebook. 14 | * 15 | * Example : 16 | * 17 | * Create a custom button in toolbar that execute `%qtconsole` in kernel 18 | * and hence open a qtconsole attached to the same kernel as the current notebook 19 | * 20 | * $([IPython.events]).on('app_initialized.NotebookApp', function(){ 21 | * IPython.toolbar.add_buttons_group([ 22 | * { 23 | * 'label' : 'run qtconsole', 24 | * 'icon' : 'icon-terminal', // select your icon from http://fortawesome.github.io/Font-Awesome/icons 25 | * 'callback': function () { 26 | * IPython.notebook.kernel.execute('%qtconsole') 27 | * } 28 | * } 29 | * // add more button here if needed. 30 | * ]); 31 | * }); 32 | * 33 | * Example : 34 | * 35 | * Use `jQuery.getScript(url [, success(script, textStatus, jqXHR)] );` 36 | * to load custom script into the notebook. 37 | * 38 | * // to load the metadata ui extension example. 39 | * $.getScript('/static/notebook/js/celltoolbarpresets/example.js'); 40 | * // or 41 | * // to load the metadata ui extension to control slideshow mode / reveal js for nbconvert 42 | * $.getScript('/static/notebook/js/celltoolbarpresets/slideshow.js'); 43 | * 44 | * 45 | * @module IPython 46 | * @namespace IPython 47 | * @class customjs 48 | * @static 49 | */ 50 | 51 | $([IPython.events]).on('notebook_loaded.Notebook', function(){ 52 | // add here logic that should be run once per **notebook load** 53 | // alert(IPython.notebook.metadata.language) 54 | IPython.notebook.metadata.language = 'common-lisp' ; 55 | }); 56 | $([IPython.events]).on('app_initialized.NotebookApp', function(){ 57 | // add here logic that shoudl be run once per **page load** 58 | 59 | $.getScript('/static/components/codemirror/mode/commonlisp/commonlisp.js'); 60 | 61 | CodeMirror.requireMode('common-lisp', function(){ 62 | console.log('Lisp mode should now be available in codemirror.'); 63 | }) 64 | IPython.CodeCell.options_default['cm_config']['mode'] = 'commonlisp'; 65 | IPython.CodeCell.options_default['cm_config']['indentUnit'] = 4; 66 | 67 | var cells = IPython.notebook.get_cells(); 68 | for(var i in cells){ 69 | var c = cells[i]; 70 | if (c.cell_type === 'code') { 71 | // Force the mode to be common lisp 72 | // This is necessary, otherwise sometimes highlighting just doesn't happen. 73 | // This may be an IPython bug. 74 | c.code_mirror.setOption('mode', 'commonlisp'); 75 | c.auto_highlight() 76 | } 77 | } 78 | 79 | }); 80 | document.title = document.title.replace('IPython', 'Fishbowl'); 81 | -------------------------------------------------------------------------------- /profile/fish.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 23 | 26 | 30 | 35 | 40 | 42 | 46 | 51 | 56 | 58 | 61 | 66 | 71 | 76 | 78 | 82 | 87 | 89 | 99 | 109 | 120 | 131 | 142 | 153 | 164 | 174 | 179 | 184 | 186 | 188 | 208 | 214 | 221 | 226 | 231 | 236 | 242 | 248 | 254 | 265 | 270 | 281 | 287 | 292 | 294 | 298 | 303 | 308 | 314 | 320 | 326 | 337 | 342 | 353 | 359 | 364 | 366 | 368 | 370 | 372 | 374 | 376 | image/svg+xml 379 | 382 | 385 | 387 | 390 | Openclipart 393 | 395 | 397 | Pez dorado (gold fish) 400 | 2007-11-18T19:12:47 403 | Pez dorado al estilo web 2.0. Gold fish with web 2.0 style. \nEncuentra mis videotutoriales en: http://www.depinux.blogspot.com 406 | https://openclipart.org/detail/10779/pez-dorado-(gold-fish)-by-pepinux-10779 409 | 411 | 413 | pepinux 416 | 418 | 420 | 422 | 424 | animal 427 | fish 430 | goldfish 433 | nature 436 | 438 | 440 | 442 | 445 | 448 | 451 | 454 | 456 | 458 | 460 | 462 | -------------------------------------------------------------------------------- /profile/fishbowl-small.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 20 | 22 | 32 | 36 | 40 | 41 | 49 | 53 | 57 | 58 | 67 | 71 | 75 | 76 | 86 | 96 | 106 | 116 | 126 | 135 | 144 | 147 | 151 | 152 | 154 | 158 | 162 | 166 | 167 | 170 | 174 | 178 | 179 | 182 | 186 | 190 | 191 | 194 | 200 | 204 | 208 | 215 | 216 | 222 | 227 | 232 | 237 | 238 | 244 | 249 | 254 | 259 | 260 | 261 | 279 | 284 | 286 | 291 | 296 | 301 | 311 | 316 | 321 | 326 | 331 | 336 | 341 | 347 | 348 | 354 | 360 | 366 | 372 | 378 | 384 | 390 | 396 | 402 | 408 | 414 | 420 | 426 | 432 | 438 | 444 | 452 | 460 | 468 | 476 | 481 | 487 | 491 | 496 | 501 | 507 | 513 | 519 | 529 | 534 | 544 | 550 | 555 | 556 | 559 | 564 | 569 | 575 | 581 | 587 | 597 | 602 | 612 | 618 | 623 | 624 | 625 | 626 | 630 | 634 | ( 646 | ( 658 | 659 | Common Lisp 671 | 672 | 674 | 675 | 676 | image/svg+xml 677 | 679 | 681 | 682 | 684 | Openclipart 685 | 686 | 687 | Fishbowl 688 | 2010-05-11T04:48:20 689 | A simple fishbowl, with water only. Drawn in Inkscape. 690 | https://openclipart.org/detail/59905/fishbowl-by-j_alves 691 | 692 | 693 | J_Alves 694 | 695 | 696 | 697 | 698 | aquarium 699 | fish 700 | fish tank 701 | fishbowl 702 | pet 703 | 704 | 705 | 706 | 708 | 710 | 712 | 714 | 715 | 716 | 717 | 718 | -------------------------------------------------------------------------------- /profile/fishbowl.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 20 | 22 | 32 | 36 | 40 | 41 | 49 | 53 | 57 | 58 | 67 | 71 | 75 | 76 | 86 | 96 | 106 | 116 | 126 | 135 | 144 | 147 | 151 | 152 | 154 | 158 | 162 | 166 | 167 | 170 | 174 | 178 | 179 | 182 | 186 | 190 | 191 | 194 | 200 | 204 | 208 | 215 | 216 | 222 | 227 | 232 | 237 | 238 | 244 | 249 | 254 | 259 | 260 | 261 | 279 | 284 | 286 | 291 | 296 | 301 | 311 | 316 | 321 | 326 | 331 | 336 | 341 | 347 | 348 | 354 | 360 | 366 | 372 | 378 | 384 | 390 | 396 | 402 | 408 | 414 | 420 | 426 | 432 | 438 | 444 | 452 | 460 | 468 | 476 | 481 | 487 | 491 | 496 | 501 | 507 | 513 | 519 | 529 | 534 | 544 | 550 | 555 | 556 | 559 | 564 | 569 | 575 | 581 | 587 | 597 | 602 | 612 | 618 | 623 | 624 | 625 | 626 | 630 | 634 | ( 646 | ( 658 | 659 | Common Lisp 671 | 672 | 674 | 675 | 676 | image/svg+xml 677 | 679 | 681 | 682 | 684 | Openclipart 685 | 686 | 687 | Fishbowl 688 | 2010-05-11T04:48:20 689 | A simple fishbowl, with water only. Drawn in Inkscape. 690 | https://openclipart.org/detail/59905/fishbowl-by-j_alves 691 | 692 | 693 | J_Alves 694 | 695 | 696 | 697 | 698 | aquarium 699 | fish 700 | fish tank 701 | fishbowl 702 | pet 703 | 704 | 705 | 706 | 708 | 710 | 712 | 714 | 715 | 716 | 717 | 718 | -------------------------------------------------------------------------------- /profile/lambda.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 25 | 42 | 48 | 54 | 56 | 58 | 60 | 62 | image/svg+xml 65 | 68 | 71 | 73 | 76 | Openclipart 79 | 81 | 83 | lambda 86 | 2008-02-09T00:34:41 89 | 91 | https://openclipart.org/detail/13230/lambda-by-anonymous 94 | 96 | 98 | Anonymous 101 | 103 | 105 | 107 | 109 | greek 112 | lambda 115 | letter 118 | symbol 121 | 123 | 125 | 127 | 130 | 133 | 136 | 139 | 141 | 143 | 145 | 147 | -------------------------------------------------------------------------------- /src/cl-jupyter.asd: -------------------------------------------------------------------------------- 1 | 2 | (asdf:defsystem #:cl-jupyter 3 | :description "An Enhanced Interactive Shell for Common Lisp (based on the Jupyter protocol)." 4 | :version "0.8" 5 | :author "Frederic Peschanski (format nil \"\" \".\" \".\" \"@\" \".\")" 6 | :license "BSD 2-Clause. See LICENSE." 7 | :depends-on (:pzmq 8 | :bordeaux-threads 9 | :uuid 10 | :babel 11 | :ironclad 12 | :cl-base64) 13 | :serial t 14 | :components ((:file "packages") 15 | (:file "utils") 16 | (:file "myjson") 17 | (:file "config") 18 | (:file "message") 19 | (:file "shell") 20 | (:file "iopub") 21 | (:file "display") 22 | (:file "evaluator") 23 | (:file "user") 24 | (:file "kernel"))) 25 | -------------------------------------------------------------------------------- /src/config.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-jupyter) 2 | 3 | (defparameter +KERNEL-IMPLEMENTATION-NAME+ "cl-jupyter") 4 | (defparameter +KERNEL-IMPLEMENTATION-VERSION+ "0.8") 5 | (defparameter +KERNEL-PROTOCOL-VERSION+ "5.0") 6 | -------------------------------------------------------------------------------- /src/display.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package #:cl-jupyter) 3 | 4 | #| 5 | 6 | # Rich display # 7 | 8 | The IPython notebook implements a simple yet powerfull 9 | rich display system that allows to interpret computation results 10 | not only as text for classical, textual display but also : 11 | 12 | - as MARKDOWN for programmatically-generated styled text 13 | 14 | - as LATEX for programmatically-generated math formulas 15 | 16 | - as PNG or JPEG for bitmap image display 17 | 18 | - as SVG or PDF for vectorial drawings 19 | 20 | - as HTML for arbitrary displays (e.g. whole www pages as inner frames, 21 | interactive displays through embedded javascripts, etc.) 22 | 23 | - as JAVASCRIPT for whatever we'd like to do dynamically in the browser. 24 | 25 | |# 26 | 27 | #| 28 | 29 | ## Display objects ## 30 | 31 | A `diplay-object` instance associates a Lisp `value` to some 32 | `data` corresponding to its representation. 33 | 34 | |# 35 | 36 | (defclass display-object () 37 | ((value :initarg :value :reader display-object-value) 38 | (data :initarg :data :reader display-object-data)) 39 | (:documentation "The class of DISPLAY-OBJECTs, i.e. objets supposed 40 | to be displayed by the Fishbowl/IPython frontend.")) 41 | 42 | #| 43 | 44 | ## Renderers ## 45 | 46 | A renderer is a set of generic functions whose purpose is to 47 | build display representations for Lisp values. The only default 48 | representation is the plain text representation produced by the 49 | Lisp printer. The other renderers must be specialized for rich 50 | display of user objects. 51 | 52 | |# 53 | 54 | 55 | #| 56 | 57 | By default values are repsesented as plain text as produced by the 58 | Lisp printer. In most cases this is enough but specializations are 59 | of course possible. 60 | 61 | |# 62 | 63 | (defgeneric render-plain (value) 64 | (:documentation "Render the VALUE as plain text (default rendering).")) 65 | 66 | 67 | (defmethod render-plain ((value t)) 68 | ;; Lisp printer by default 69 | (format nil "~S" value)) 70 | 71 | (example (render-plain '(1 2 3)) 72 | => "(1 2 3)") 73 | 74 | 75 | (defgeneric render-html (value) 76 | (:documentation "Render the VALUE as an HTML document (represented as a sting).")) 77 | 78 | (defmethod render-html ((value t)) 79 | ;; no rendering by default 80 | nil) 81 | 82 | (defgeneric render-markdown (value) 83 | (:documentation "Render the VALUE as MARDOWN text.")) 84 | 85 | (defmethod render-markdown ((value t)) 86 | ;; no rendering by default 87 | nil) 88 | 89 | 90 | (defgeneric render-latex (value) 91 | (:documentation "Render the VALUE as a LATEX document.")) 92 | 93 | (defmethod render-latex ((value t)) 94 | ;; no rendering by default 95 | nil) 96 | 97 | (defgeneric render-png (value) 98 | (:documentation "Render the VALUE as a PNG image. The expected 99 | encoding is a Base64-encoded string.")) 100 | 101 | (defmethod render-png ((value t)) 102 | ;; no rendering by default 103 | nil) 104 | 105 | (defgeneric render-jpeg (value) 106 | (:documentation "Render the VALUE as a JPEG image. The expected 107 | encoding is a Base64-encoded string.")) 108 | 109 | (defmethod render-jpeg ((value t)) 110 | ;; no rendering by default 111 | nil) 112 | 113 | (defgeneric render-svg (value) 114 | (:documentation "Render the VALUE as a SVG image (XML format represented as a string).")) 115 | 116 | (defmethod render-svg ((value t)) 117 | ;; no rendering by default 118 | nil) 119 | 120 | (defgeneric render-json (value) 121 | (:documentation "Render the VALUE as a JSON document. This uses the MYJSON encoding 122 | (alist with string keys)")) 123 | 124 | (defmethod render-json ((value t)) 125 | ;; no rendering by default 126 | nil) 127 | 128 | (defgeneric render-javascript (value) 129 | (:documentation "Render the VALUE as a JAVASCRIPT source (represented as a string).")) 130 | 131 | (defmethod render-javascript ((value t)) 132 | ;; no rendering by default 133 | nil) 134 | 135 | 136 | #| 137 | 138 | ## Display methods ## 139 | 140 | |# 141 | 142 | (defun combine-render (pairs) 143 | (loop 144 | for pair in pairs 145 | when (not (null (cdr pair))) 146 | collect pair)) 147 | 148 | (example (combine-render `(("hello" . "world") 149 | ("bonjour" . nil) 150 | ("griacias" . (1 2 3)))) 151 | => '(("hello" . "world") 152 | ("griacias" . (1 2 3)))) 153 | 154 | (defun display-dispatch (value render-alist) 155 | (if (typep value 'display-object) 156 | value ; already displayed 157 | ;; otherwise needs to display 158 | (let ((data (combine-render (cons `("text/plain" . ,(render-plain value)) ; at least text/plain encoding is required 159 | render-alist)))) 160 | (make-instance 'display-object :value value :data data)))) 161 | 162 | 163 | (defun display (value) 164 | "Display VALUE in all supported representations." 165 | (display-dispatch value `(("text/html" . ,(render-html value)) 166 | ("text/markdown" . ,(render-markdown value)) 167 | ("text/latex" . ,(render-latex value)) 168 | ("image/png" . ,(render-png value)) 169 | ("image/jpeg" . ,(render-jpeg value)) 170 | ("image/svg+xml" . ,(render-svg value)) 171 | ("application/json" . ,(render-json value)) 172 | ("application/javascript" . ,(render-javascript value))))) 173 | 174 | (defun display-html (value) 175 | "Display VALUE as HTML." 176 | (display-dispatch value `(("text/html" . ,(render-html value))))) 177 | 178 | (defun display-markdown (value) 179 | "Display VALUE as MARDOWN text." 180 | (display-dispatch value `(("text/markdown" . ,(render-markdown value))))) 181 | 182 | (defun display-latex (value) 183 | "Display VALUE as a LATEX document." 184 | (display-dispatch value `(("text/latex" . ,(render-latex value))))) 185 | 186 | (defun display-png (value) 187 | "Display VALUE as a PNG image." 188 | (display-dispatch value `(("image/png" . ,(render-png value))))) 189 | 190 | (defun display-jpeg (value) 191 | "Display VALUE as a JPEG image." 192 | (display-dispatch value `(("image/jpeg" . ,(render-jpeg value))))) 193 | 194 | (defun display-svg (value) 195 | "Display VALUE as a SVG image." 196 | (display-dispatch value `(("image/svg+xml" . ,(render-svg value))))) 197 | 198 | (defun display-json (value) 199 | "Display VALUE as a JSON document." 200 | (display-dispatch value `(("application/json" . ,(render-json value))))) 201 | 202 | (defun display-javascript (value) 203 | "Display VALUE as embedded JAVASCRIPT." 204 | (display-dispatch value `(("application/javascript" . ,(render-javascript value))))) 205 | 206 | 207 | -------------------------------------------------------------------------------- /src/evaluator.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-jupyter) 2 | 3 | #| 4 | 5 | # Evaluator # 6 | 7 | The evaluator is where the "interesting stuff" takes place : 8 | user expressions are evaluated here. 9 | 10 | The history of evaluations is also saved by the evaluator. 11 | 12 | |# 13 | 14 | 15 | (defclass evaluator () 16 | ((kernel :initarg :kernel :reader evaluator-kernel) 17 | (history-in :initform (make-array 64 :fill-pointer 0 :adjustable t) 18 | :reader evaluator-history-in) 19 | (history-out :initform (make-array 64 :fill-pointer 0 :adjustable t) 20 | :reader evaluator-history-out))) 21 | 22 | (defvar *evaluator* nil) 23 | 24 | (defun take-history-in (hist-ref) 25 | (let ((history-in (slot-value cl-jupyter::*evaluator* 'cl-jupyter::history-in))) 26 | (let ((href (if (< hist-ref 0) 27 | (+ (+ (length history-in) 1) hist-ref) 28 | hist-ref))) 29 | (if (and (>= href 1) 30 | (<= href (length history-in))) 31 | (aref history-in (- href 1)) 32 | nil)))) 33 | 34 | (defun take-history-out (hist-ref &optional value-ref) 35 | (let ((history-out (slot-value cl-jupyter::*evaluator* 'cl-jupyter::history-out))) 36 | (let ((href (if (< hist-ref 0) 37 | (+ (+ (length history-out) 1) hist-ref) 38 | hist-ref))) 39 | (when (and (>= href 1) 40 | (<= href (length history-out))) 41 | (let ((out-values (aref history-out (- href 1)))) 42 | (if value-ref 43 | (when (and (>= value-ref 1) 44 | (<= value-ref (length out-values))) 45 | (elt out-values (- value-ref 1))) 46 | (values-list out-values))))))) 47 | 48 | (defun make-evaluator (kernel) 49 | (let ((evaluator (make-instance 'evaluator 50 | :kernel kernel))) 51 | (setf (slot-value kernel 'evaluator) evaluator) 52 | evaluator)) 53 | 54 | ;;; macro taken from: http://www.cliki.net/REPL 55 | ;;; modified to handle warnings correctly 56 | (defmacro handling-errors (&body body) 57 | `(handler-case 58 | (handler-bind 59 | ((simple-warning 60 | #'(lambda (wrn) 61 | (format *error-output* "~&~A: ~%" (class-name (class-of wrn))) 62 | (apply (function format) *error-output* 63 | (simple-condition-format-control wrn) 64 | (simple-condition-format-arguments wrn)) 65 | (format *error-output* "~&") 66 | (muffle-warning))) 67 | (warning 68 | #'(lambda (wrn) 69 | (format *error-output* "~&~A: ~% ~A~%" 70 | (class-name (class-of wrn)) wrn) 71 | (muffle-warning)))) 72 | (progn ,@body)) 73 | (simple-condition (err) 74 | (format *error-output* "~&~A: ~%" (class-name (class-of err))) 75 | (apply (function format) *error-output* 76 | (simple-condition-format-control err) 77 | (simple-condition-format-arguments err)) 78 | (format *error-output* "~&")) 79 | (serious-condition (err) 80 | (format *error-output* "~&~A: ~% ~S~%" 81 | (class-name (class-of err)) err)))) 82 | 83 | (defun evaluate-code (evaluator code) 84 | ;;(format t "[Evaluator] Code to evaluate: ~W~%" code) 85 | (let ((execution-count (+ (length (evaluator-history-in evaluator)) 1))) 86 | (let ((code-to-eval (handler-case 87 | (read-from-string (format nil "(progn ~A~%)" code)) 88 | (END-OF-FILE (err) (list :read-error-eof (format nil "~A" (class-name (class-of err))))) 89 | #+sbcl (SB-INT:SIMPLE-READER-ERROR (err) 90 | (list :read-error (format nil "~A (condition of type ~A)" err (class-name (class-of err)))))))) 91 | ;;(format t "code-to-eval = ~A~%" code-to-eval) 92 | (cond 93 | ((and (consp code-to-eval) 94 | (eq (car code-to-eval) :read-error-eof)) 95 | (values execution-count nil "" 96 | (format nil "Reader error: incomplete input (condition of type: ~A)~%" (cadr code-to-eval)))) 97 | ((and (consp code-to-eval) 98 | (eq (car code-to-eval) :read-error)) 99 | (values execution-count nil "" 100 | (format nil "Reader error: ~A~%" (cadr code-to-eval)))) 101 | ((equal code-to-eval '(progn)) 102 | (values execution-count nil "" (format nil "Warning: no evaluable input~%"))) 103 | ((and (consp code-to-eval) 104 | (eql (car code-to-eval) 'quicklisp-client:quickload) 105 | (stringp (cadr code-to-eval))) 106 | ;; quicklisp hook 107 | (let ((results (multiple-value-list (ql:quickload (cadr code-to-eval))))) 108 | (values execution-count results "" ""))) 109 | (t 110 | ;; else "normal" evaluation 111 | ;;(format t "[Evaluator] Code to evaluate: ~W~%" code-to-eval) 112 | (let* ((stdout-str (make-array 0 :element-type 'character :fill-pointer 0 :adjustable t)) 113 | (stderr-str (make-array 0 :element-type 'character :fill-pointer 0 :adjustable t))) 114 | (let ((results (with-output-to-string (stdout stdout-str) 115 | (with-output-to-string (stderr stderr-str) 116 | (let ((*standard-output* stdout) 117 | (*error-output* stderr)) 118 | (handling-errors 119 | ;(if (and (consp code-to-eval) 120 | ; (eql (car code-to-eval) 'quicklisp-client:quickload) 121 | ; (stringp (cadr code-to-eval))) 122 | ;; quicklisp hook 123 | ; (multiple-value-list (ql:quickload (cadr code-to-eval))) 124 | ;; normal evaluation 125 | (let ((*evaluator* evaluator)) 126 | (let ((* (take-history-out -1)) 127 | (** (take-history-out -2)) 128 | (*** (take-history-out -3))) 129 | ;; put the evaluator in the environment 130 | (multiple-value-list (eval code-to-eval)))))))))) 131 | ;;(format t "[Evaluator] : results = ~W~%" results) 132 | (let ((in-code (format nil "~A" code-to-eval))) 133 | (vector-push-extend (subseq in-code 7 (1- (length in-code))) 134 | (evaluator-history-in evaluator))) 135 | (vector-push-extend results (evaluator-history-out evaluator)) 136 | (values execution-count results stdout-str stderr-str)))))))) 137 | 138 | -------------------------------------------------------------------------------- /src/iopub.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package #:cl-jupyter) 3 | 4 | #| 5 | 6 | # The IOPUB publish/subscribe channel # 7 | 8 | |# 9 | 10 | (defclass iopub-channel () 11 | ((kernel :initarg :kernel :reader iopub-kernel) 12 | (socket :initarg :socket :initform nil :accessor iopub-socket))) 13 | 14 | (defun make-iopub-channel (kernel) 15 | (let ((socket (pzmq:socket (kernel-ctx kernel) :pub))) 16 | (let ((iopub (make-instance 'iopub-channel 17 | :kernel kernel 18 | :socket socket))) 19 | (let ((config (slot-value kernel 'config))) 20 | (let ((endpoint (format nil "~A://~A:~A" 21 | (config-transport config) 22 | (config-ip config) 23 | (config-iopub-port config)))) 24 | ;;(format t "[IOPUB] iopub endpoint is: ~A~%" endpoint) 25 | (pzmq:bind socket endpoint) 26 | (setf (slot-value kernel 'iopub) iopub) 27 | iopub))))) 28 | 29 | (defun send-status-starting (iopub session &key (key nil)) 30 | (let ((status-msg (make-orphan-message session "status" nil 31 | `(("execution_state" . "starting"))))) 32 | (message-send (iopub-socket iopub) status-msg :identities '("status") :key key))) 33 | 34 | (defun send-status-update (iopub parent-msg status &key (key nil)) 35 | (let ((status-content `((:execution--state . ,status)))) 36 | (let ((status-msg (make-message parent-msg "status" nil 37 | `(("execution_state" . ,status))))) 38 | (message-send (iopub-socket iopub) status-msg :identities '("status") :key key)))) 39 | 40 | (defun send-execute-code (iopub parent-msg execution-count code &key (key nil)) 41 | (let ((code-msg (make-message parent-msg "execute_input" nil 42 | `(("code" . ,code) 43 | ("execution_count" . ,execution-count))))) 44 | ;;(format t "content to send = ~W~%" (encode-json-to-string (message-content code-msg))) 45 | (message-send (iopub-socket iopub) code-msg :identities '("execute_input") :key key))) 46 | 47 | 48 | (defun send-execute-result (iopub parent-msg execution-count result &key (key nil)) 49 | (let ((display-obj (display result))) 50 | (let ((result-msg (make-message parent-msg "execute_result" nil 51 | `(("execution_count" . ,execution-count) 52 | ("data" . ,(display-object-data display-obj)) 53 | ("metadata" . ()))))) 54 | (message-send (iopub-socket iopub) result-msg :identities '("execute_result") :key key)))) 55 | 56 | (defun send-stream (iopub parent-msg stream-name data &key (key nil)) 57 | (let ((stream-msg (make-message parent-msg "stream" nil 58 | `(("name" . ,stream-name) 59 | ("text" . ,data))))) 60 | (message-send (iopub-socket iopub) stream-msg :identities `(,(format nil "stream.~W" stream-name)) :key key))) 61 | -------------------------------------------------------------------------------- /src/kernel.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-jupyter) 2 | 3 | (defclass kernel () 4 | ((config :initarg :config :reader kernel-config) 5 | (ctx :initarg :ctx :reader kernel-ctx) 6 | (shell :initarg :shell :initform nil :reader kernel-shell) 7 | (iopub :initarg :iopub :initform nil :reader kernel-iopub) 8 | (session :initarg :session :reader kernel-session) 9 | (evaluator :initarg :evaluator :initform nil :reader kernel-evaluator)) 10 | (:documentation "Kernel state representation.")) 11 | 12 | (defun make-kernel (config) 13 | (let ((ctx (pzmq:ctx-new)) 14 | (session-id (format nil "~W" (uuid:make-v4-uuid)))) 15 | (make-instance 'kernel 16 | :config config 17 | :ctx ctx 18 | :session session-id))) 19 | 20 | (defun get-argv () 21 | ;; Borrowed from apply-argv, command-line-arguments. Temporary solution (?) 22 | #+sbcl (cdr sb-ext:*posix-argv*) 23 | #+clozure CCL:*UNPROCESSED-COMMAND-LINE-ARGUMENTS* ;(ccl::command-line-arguments) 24 | #+gcl si:*command-args* 25 | #+ecl (loop for i from 0 below (si:argc) collect (si:argv i)) 26 | #+cmu extensions:*command-line-strings* 27 | #+allegro (sys:command-line-arguments) 28 | #+lispworks sys:*line-arguments-list* 29 | #+clisp ext:*args* 30 | #-(or sbcl clozure gcl ecl cmu allegro lispworks clisp) 31 | (error "get-argv not supported for your implementation")) 32 | 33 | (defun join (e l) 34 | (cond ((endp l) (list)) 35 | ((endp (cdr l)) l) 36 | (t (cons (car l) (cons e (join e (cdr l))))))) 37 | 38 | (example (join 1 '(a b c d e)) 39 | => '(a 1 b 1 c 1 d 1 e)) 40 | 41 | (defun concat-all (kind term ls) 42 | (if (endp ls) 43 | term 44 | (concatenate kind (car ls) (concat-all kind term (cdr ls))))) 45 | 46 | (example (concat-all 'string "" '("a" "b" "c" "d" "e")) 47 | => "abcde") 48 | 49 | (defun banner () 50 | (concat-all 51 | 'string "" 52 | (join (format nil "~%") 53 | '(" __________ " 54 | " / /. " 55 | " .-----------------. /_________/ | " 56 | " / / | | | | " 57 | " /+================+\\ | | |====| | | " 58 | " ||cl-jupyter || | | | | " 59 | " || || | | |====| | | " 60 | " ||* (fact 5) || | | | | " 61 | " ||120 || | | ___ | | " 62 | " || || | | |166| | | " 63 | " || ||/@@@ | --- | | " 64 | " \\+================+/ @ |_________|./. " 65 | " @ .. ....' " 66 | " ..................@ __.'. ' '' " 67 | " /oooooooooooooooo// /// " 68 | " /................// /_/ " 69 | " ------------------ " 70 | "")))) 71 | 72 | ;; (format t (banner)) 73 | 74 | 75 | 76 | (defclass kernel-config () 77 | ((transport :initarg :transport :reader config-transport :type string) 78 | (ip :initarg :ip :reader config-ip :type string) 79 | (shell-port :initarg :shell-port :reader config-shell-port :type fixnum) 80 | (iopub-port :initarg :iopub-port :reader config-iopub-port :type fixnum) 81 | (control-port :initarg :control-port :reader config-control-port :type fixnum) 82 | (stdin-port :initarg :stdin-port :reader config-stdin-port :type fixnum) 83 | (hb-port :initarg :hb-port :reader config-hb-port :type fixnum) 84 | (signature-scheme :initarg :signature-scheme :reader config-signature-scheme :type string) 85 | (key :initarg :key :reader kernel-config-key))) 86 | 87 | (defun kernel-start () 88 | (let ((cmd-args (get-argv))) 89 | ;(princ (banner)) 90 | (write-line "") 91 | (format t "~A: an enhanced interactive Common Lisp REPL~%" +KERNEL-IMPLEMENTATION-NAME+) 92 | (format t "(Version ~A - Jupyter protocol v.~A)~%" 93 | +KERNEL-IMPLEMENTATION-VERSION+ 94 | +KERNEL-PROTOCOL-VERSION+) 95 | (format t "--> (C) 2014-2015 Frederic Peschanski (cf. LICENSE)~%") 96 | (write-line "") 97 | (let ((connection-file-name (car (last cmd-args)))) 98 | ;; (format t "connection file = ~A~%" connection-file-name) 99 | (unless (stringp connection-file-name) 100 | (error "Wrong connection file argument (expecting a string)")) 101 | (let ((config-alist (parse-json-from-string (concat-all 'string "" (read-file-lines connection-file-name))))) 102 | (format t "kernel configuration = ~A~%" config-alist) 103 | (let ((config 104 | (make-instance 'kernel-config 105 | :transport (afetch "transport" config-alist :test #'equal) 106 | :ip (afetch "ip" config-alist :test #'equal) 107 | :shell-port (afetch "shell_port" config-alist :test #'equal) 108 | :iopub-port (afetch "iopub_port" config-alist :test #'equal) 109 | :control-port (afetch "control_port" config-alist :test #'equal) 110 | :hb-port (afetch "hb_port" config-alist :test #'equal) 111 | :signature-scheme (afetch "signature_scheme" config-alist :test #'equal) 112 | :key (let ((str-key (afetch "key" config-alist :test #'equal))) 113 | (if (string= str-key "") 114 | nil 115 | (babel:string-to-octets str-key :encoding :ASCII)))))) 116 | (when (not (string= (config-signature-scheme config) "hmac-sha256")) 117 | ;; XXX: only hmac-sha256 supported 118 | (error "Kernel only support signature scheme 'hmac-sha256' (provided ~S)" (config-signature-scheme config))) 119 | ;;(inspect config) 120 | (let* ((kernel (make-kernel config)) 121 | (evaluator (make-evaluator kernel)) 122 | (shell (make-shell-channel kernel)) 123 | (iopub (make-iopub-channel kernel))) 124 | ;; Launch the hearbeat thread 125 | (let ((hb-socket (pzmq:socket (kernel-ctx kernel) :rep))) 126 | (let ((hb-endpoint (format nil "~A://~A:~A" 127 | (config-transport config) 128 | (config-ip config) 129 | (config-hb-port config)))) 130 | ;;(format t "heartbeat endpoint is: ~A~%" endpoint) 131 | (pzmq:bind hb-socket hb-endpoint) 132 | (let ((heartbeat-thread-id (start-heartbeat hb-socket))) 133 | ;; main loop 134 | (unwind-protect 135 | (progn (format t "[Kernel] Entering mainloop ...~%") 136 | (shell-loop shell)) 137 | ;; clean up when exiting 138 | (bordeaux-threads:destroy-thread heartbeat-thread-id) 139 | (pzmq:close hb-socket) 140 | (pzmq:close (iopub-socket iopub)) 141 | (pzmq:close (shell-socket shell)) 142 | (pzmq:ctx-destroy (kernel-ctx kernel)) 143 | (format t "Bye bye.~%"))))))))))) 144 | 145 | (defun start-heartbeat (socket) 146 | (format t "[Hearbeat] starting...~%") 147 | (let ((thread-id (bordeaux-threads:make-thread 148 | (lambda () 149 | (format t "[Heartbeat] thread started~%") 150 | (pzmq:proxy socket socket (cffi:null-pointer)))))) 151 | 152 | ;; XXX: without proxy 153 | ;; (loop 154 | ;; (pzmq:with-message msg 155 | ;; (pzmq:msg-recv msg socket) 156 | ;; ;;(format t "Heartbeat Received:~%") 157 | ;; (pzmq:msg-send msg socket) 158 | ;; ;;(format t " | message: ~A~%" msg) 159 | ;; )))))) 160 | thread-id)) 161 | -------------------------------------------------------------------------------- /src/message.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package #:cl-jupyter) 3 | 4 | #| 5 | 6 | # Representation and manipulation of kernel messages # 7 | 8 | |# 9 | 10 | #| 11 | 12 | ## Message header ## 13 | 14 | |# 15 | 16 | (defclass header () 17 | ((msg-id :initarg :msg-id :reader header-msg-id :type string) 18 | (username :initarg :username :reader header-username :type string) 19 | (session :initarg :session :reader header-session :type string) 20 | (msg-type :initarg :msg-type :reader header-msg-type :type string) 21 | (version :initarg :version :initform +KERNEL-PROTOCOL-VERSION+ :reader header-version :type string)) 22 | (:documentation "Header representation for IPython messages")) 23 | 24 | #| 25 | 26 | ### JSon encoding ### 27 | 28 | |# 29 | 30 | (defmethod encode-json (stream (object header) &key (indent nil) (first-line nil)) 31 | (with-slots (msg-id username session msg-type version) object 32 | (encode-json stream `(("msg_id" . ,msg-id) 33 | ("username" . ,username) 34 | ("session" . ,session) 35 | ("msg_type" . ,msg-type) 36 | ("version" . ,version)) 37 | :indent indent :first-line first-line))) 38 | 39 | (example-progn 40 | (defparameter *header1* (make-instance 'header 41 | :msg-id "XXX-YYY-ZZZ-TTT" 42 | :username "fredokun" 43 | :session "AAA-BBB-CCC-DDD" 44 | :msg-type "execute_request"))) 45 | 46 | (example 47 | (encode-json-to-string *header1* :indent 0) 48 | => "{ 49 | \"msg_id\": \"XXX-YYY-ZZZ-TTT\", 50 | \"username\": \"fredokun\", 51 | \"session\": \"AAA-BBB-CCC-DDD\", 52 | \"msg_type\": \"execute_request\", 53 | \"version\": \"5.0\" 54 | }") 55 | 56 | 57 | (example 58 | (encode-json-to-string *header1*) 59 | => "{\"msg_id\": \"XXX-YYY-ZZZ-TTT\",\"username\": \"fredokun\",\"session\": \"AAA-BBB-CCC-DDD\",\"msg_type\": \"execute_request\",\"version\": \"5.0\"}") 60 | 61 | #| 62 | 63 | ### JSon decoding ### 64 | 65 | |# 66 | 67 | (example (parse-json-from-string (encode-json-to-string *header1*)) 68 | => '(("msg_id" . "XXX-YYY-ZZZ-TTT") ("username" . "fredokun") 69 | ("session" . "AAA-BBB-CCC-DDD") ("msg_type" . "execute_request") 70 | ("version" . "5.0"))) 71 | 72 | (example 73 | (afetch "msg_id" (parse-json-from-string (encode-json-to-string *header1*)) :test #'equal) 74 | => "XXX-YYY-ZZZ-TTT") 75 | 76 | (example 77 | (afetch "username" (parse-json-from-string (encode-json-to-string *header1*)) :test #'equal) 78 | => "fredokun") 79 | 80 | #| 81 | 82 | ### Wire-deserialization ### 83 | 84 | The deserialization of a message header from a JSon string is then trivial. 85 | 86 | |# 87 | 88 | (defun wire-deserialize-header (hdr) 89 | (let ((json-list (parse-json-from-string hdr))) 90 | (if json-list 91 | (make-instance 'header 92 | :msg-id (afetch "msg_id" json-list :test #'equal) 93 | :username (afetch "username"json-list :test #'equal) 94 | :session (afetch "session" json-list :test #'equal) 95 | :msg-type (afetch "msg_type" json-list :test #'equal)) 96 | nil))) 97 | 98 | (example-progn 99 | (defparameter *header2* (wire-deserialize-header (encode-json-to-string *header1*)))) 100 | 101 | 102 | (example (header-username *header2*) 103 | => "fredokun") 104 | 105 | #| 106 | 107 | ## IPython messages ## 108 | 109 | |# 110 | 111 | (defclass message () 112 | ((header :initarg :header :accessor message-header) 113 | (parent-header :initarg :parent-header :initform nil :accessor message-parent-header) 114 | (metadata :initarg :metadata :initform nil :accessor message-metadata) 115 | (content :initarg :content :initform nil :accessor message-content)) 116 | (:documentation "Representation of IPython messages")) 117 | 118 | (defun make-message (parent_msg msg_type metadata content) 119 | (let ((hdr (message-header parent_msg))) 120 | (make-instance 121 | 'message 122 | :header (make-instance 123 | 'header 124 | :msg-id (format nil "~W" (uuid:make-v4-uuid)) 125 | :username (header-username hdr) 126 | :session (header-session hdr) 127 | :msg-type msg_type 128 | :version (header-version hdr)) 129 | :parent-header hdr 130 | :metadata metadata 131 | :content content))) 132 | 133 | (defun make-orphan-message (session-id msg-type metadata content) 134 | (make-instance 135 | 'message 136 | :header (make-instance 137 | 'header 138 | :msg-id (format nil "~W" (uuid:make-v4-uuid)) 139 | :username "kernel" 140 | :session session-id 141 | :msg-type msg-type 142 | :version +KERNEL-PROTOCOL-VERSION+) 143 | :parent-header '() 144 | :metadata metadata 145 | :content content)) 146 | 147 | (example-progn 148 | (defparameter *msg1* (make-instance 'message :header *header1*))) 149 | 150 | 151 | #| 152 | 153 | ## Wire-serialization ## 154 | 155 | The wire-serialization of IPython kernel messages uses multi-parts ZMQ messages. 156 | 157 | |# 158 | 159 | (defun octets-to-hex-string (bytes) 160 | (apply #'concatenate (cons 'string (map 'list (lambda (x) (format nil "~(~2,'0X~)" x)) bytes)))) 161 | 162 | (defun message-signing (key parts) 163 | (let ((hmac (ironclad:make-hmac key :SHA256))) 164 | ;; updates 165 | (loop for part in parts 166 | do (let ((part-bin (babel:string-to-octets part))) 167 | (ironclad:update-hmac hmac part-bin))) 168 | ;; digest 169 | (octets-to-hex-string (ironclad:hmac-digest hmac)))) 170 | 171 | (example 172 | (message-signing (babel:string-to-octets "toto") '("titi" "tata" "tutu" "tonton")) 173 | => "d32d091b5aabeb59b4291a8c5d70e0c20302a8bf9f642956b6affe5a16d9e134") 174 | 175 | ;; XXX: should be a defconstant but strings are not EQL-able... 176 | (defvar +WIRE-IDS-MSG-DELIMITER+ "") 177 | (defvar +WIRE-IDS-MSG-DELIMITER-UB-VECTOR+ (babel:string-to-octets +WIRE-IDS-MSG-DELIMITER+)) 178 | 179 | (defmethod wire-serialize ((msg message) &key (identities nil) (key nil)) 180 | (with-slots (header parent-header metadata content) msg 181 | (let ((header-json (encode-json-to-string header)) 182 | (parent-header-json (if parent-header 183 | (encode-json-to-string parent-header) 184 | "{}")) 185 | (metadata-json (if metadata 186 | (encode-json-to-string metadata) 187 | "{}")) 188 | (content-json (if content 189 | (encode-json-to-string content) 190 | "{}"))) 191 | (let ((sig (if key 192 | (message-signing key (list header-json parent-header-json metadata-json content-json)) 193 | ""))) 194 | (append identities 195 | (list +WIRE-IDS-MSG-DELIMITER-UB-VECTOR+ 196 | sig 197 | header-json 198 | parent-header-json 199 | metadata-json 200 | content-json)))))) 201 | 202 | (example-progn 203 | (defparameter *wire1* (wire-serialize *msg1* :identities '("XXX-YYY-ZZZ-TTT" "AAA-BBB-CCC-DDD")))) 204 | 205 | 206 | #| 207 | 208 | ## Wire-deserialization ## 209 | 210 | The wire-deserialization part follows. 211 | 212 | |# 213 | 214 | (example (position +WIRE-IDS-MSG-DELIMITER-UB-VECTOR+ *wire1*) 215 | => 2) 216 | 217 | (example (nth (position +WIRE-IDS-MSG-DELIMITER-UB-VECTOR+ *wire1*) *wire1*) 218 | => +WIRE-IDS-MSG-DELIMITER-UB-VECTOR+) 219 | 220 | (example 221 | (subseq *wire1* 0 (position +WIRE-IDS-MSG-DELIMITER-UB-VECTOR+ *wire1*)) 222 | => '("XXX-YYY-ZZZ-TTT" "AAA-BBB-CCC-DDD")) 223 | 224 | (example 225 | (subseq *wire1* (+ 6 (position +WIRE-IDS-MSG-DELIMITER-UB-VECTOR+ *wire1*))) 226 | => nil) 227 | 228 | (example 229 | (let ((delim-index (position +WIRE-IDS-MSG-DELIMITER-UB-VECTOR+ *wire1*))) 230 | (subseq *wire1* (+ 2 delim-index) (+ 6 delim-index))) 231 | => '("{\"msg_id\": \"XXX-YYY-ZZZ-TTT\",\"username\": \"fredokun\",\"session\": \"AAA-BBB-CCC-DDD\",\"msg_type\": \"execute_request\",\"version\": \"5.0\"}" 232 | "{}" "{}" "{}")) 233 | 234 | 235 | (defun wire-deserialize (parts) 236 | (let ((delim-index (position +WIRE-IDS-MSG-DELIMITER-UB-VECTOR+ parts :test #'equalp))) 237 | (when (not delim-index) 238 | (error "no delimiter found in message parts")) 239 | (let ((identities (subseq parts 0 delim-index)) 240 | (signature (nth (1+ delim-index) parts))) 241 | (let ((msg (destructuring-bind (header parent-header metadata content) 242 | (subseq parts (+ 2 delim-index) (+ 6 delim-index)) 243 | (make-instance 'message 244 | :header (wire-deserialize-header (babel:octets-to-string header)) 245 | :parent-header (wire-deserialize-header (babel:octets-to-string parent-header)) 246 | :metadata (babel:octets-to-string metadata) 247 | :content (babel:octets-to-string content)))) 248 | (sig-str (babel:octets-to-string signature)) 249 | (rst (subseq parts (+ 6 delim-index)))) 250 | ;;DEBUG>> 251 | ;;(format t "[deserialize] identities = ~A~%" identities) 252 | ;;(format t " signature = ~A~%" sig-str) 253 | ;;(format t " message = ~A~%" msg) 254 | ;;(format t " rest = ~A~%" rst) 255 | (values identities sig-str msg rst))))) 256 | 257 | ;; XXX: serialization/deserialization is not fully symmetric, hence 258 | ;; the following examples fail 259 | 260 | ;; (example-progn 261 | ;; (defparameter *dewire-1* (multiple-value-bind (ids sig msg raw) 262 | ;; (wire-deserialize *wire1*) 263 | ;; (list ids sig msg raw)))) 264 | 265 | ;; (example 266 | ;; (header-username (message-header (third *dewire-1*))) 267 | ;; => "fredokun") 268 | 269 | #| 270 | 271 | ### Sending and receiving messages ### 272 | 273 | |# 274 | 275 | ;; courtesy of drmeister 276 | (defun bstr (vec) 277 | (with-output-to-string (sout) 278 | (loop for x across vec 279 | do (cond 280 | ((= x #.(char-code #\")) 281 | (princ "\"" sout)) 282 | ((< x 32) 283 | (princ "\\x" sout) 284 | (format sout "~2,'0x" x)) 285 | ((>= x 128) 286 | (princ "\\x" sout) 287 | (format sout "~2,'0x" x)) 288 | (t (write-char (code-char x) sout)))))) 289 | 290 | 291 | ;; Locking, courtesy of dmeister, thanks ! 292 | (defparameter *message-send-lock* (bordeaux-threads:make-lock "message-send-lock")) 293 | 294 | (defun message-send (socket msg &key (identities nil) (key nil)) 295 | (unwind-protect 296 | (progn 297 | (bordeaux-threads:acquire-lock *message-send-lock*) 298 | (let ((wire-parts (wire-serialize msg :identities identities :key key))) 299 | ;;DEBUG>> 300 | ;;(format t "~%[Send] wire parts: ~W~%" wire-parts) 301 | (dolist (part wire-parts) 302 | ;;DEBUG>> 303 | ;;(format t "~%[Send] wire part: ~W~%" part) 304 | ;;(format t " type of part = ~A~%" (type-of part)) 305 | (cond 306 | ((typep part 'string) (pzmq:send socket part :sndmore t)) 307 | ((typep part '(array (unsigned-byte 8))) 308 | (cffi:with-foreign-object ;; courtesy of drmeister 309 | (buf :uint8 (length part)) 310 | (dotimes (i (length part)) (setf (cffi:mem-aref buf :uint8 i) (elt part i))) 311 | ;;DEBUG>> 312 | ;; (format t "message-send (array (unsigned-byte 8)): ~s~%" 313 | ;; (loop for x below (length part) collect (cffi:mem-aref buf :uint8 x))) 314 | ;;(format t " AKA (as byte-string): ~s~%" (bstr part)) 315 | (pzmq:send socket buf :len (length part) :sndmore t))) 316 | (t (error "Cannot send part ~s of type ~s" part (type-of part))))) 317 | (pzmq:send socket nil))) 318 | (bordeaux-threads:release-lock *message-send-lock*))) 319 | 320 | (defun recv-array-bytes (socket &key dontwait (encoding cffi:*default-foreign-encoding*)) 321 | "Receive a message part from a socket as an array of bytes." 322 | (pzmq:with-message 323 | msg 324 | (pzmq:msg-recv msg socket :dontwait dontwait) 325 | (values 326 | (let* ((data (pzmq:msg-data msg)) 327 | (len (pzmq:msg-size msg)) 328 | (array-bytes (make-array len :element-type '(unsigned-byte 8)))) 329 | (loop for index from 0 below len 330 | do (setf (aref array-bytes index) (cffi:mem-aref data :uint8 index))) 331 | array-bytes) 332 | (pzmq:getsockopt socket :rcvmore)))) 333 | 334 | ;; (defun recv-string (socket &key dontwait (encoding cffi:*default-foreign-encoding*)) 335 | ;; "Receive a message part from a socket as a string." 336 | ;; (pzmq:with-message msg 337 | ;; (pzmq:msg-recv msg socket :dontwait dontwait) 338 | ;; (format t "[Shell]: (type-of msg data) => ~A~%" (type-of (pzmq:msg-data msg))) 339 | ;; (let ((bytes (recv 340 | ;; (values 341 | ;; (handler-case 342 | ;; (cffi:foreign-string-to-lisp (pzmq:msg-data msg) :count (pzmq:msg-size msg) :encoding encoding) 343 | ;; (BABEL-ENCODINGS:INVALID-UTF8-STARTER-BYTE 344 | ;; () 345 | ;; ;; if it's not utf-8 we try latin-1 (Ugly !) 346 | ;; (format t "[Recv]: issue with UTF-8 decoding~%") 347 | ;; (cffi:foreign-string-to-lisp (pzmq:msg-data msg) :count (pzmq:msg-size msg) :encoding :latin-1))) 348 | ;; (pzmq:getsockopt socket :rcvmore)))) 349 | 350 | (defun zmq-recv-list (socket &optional (parts nil) (part-num 1)) 351 | (multiple-value-bind (part more) 352 | (recv-array-bytes socket) 353 | ;; (format t "[Shell]: received message part #~A: ~W (more? ~A)~%" part-num part more) 354 | (if more 355 | (zmq-recv-list socket (cons part parts) (+ part-num 1)) 356 | (reverse (cons part parts))))) 357 | 358 | (defparameter *message-recv-lock* (bordeaux-threads:make-lock "message-recv-lock")) 359 | 360 | (defun message-recv (socket) 361 | (unwind-protect 362 | (progn 363 | (bordeaux-threads:acquire-lock *message-recv-lock*) 364 | (let ((parts (zmq-recv-list socket))) 365 | ;;DEBUG>> 366 | ;;(format t "[Recv]: parts: ~A~%" (mapcar (lambda (part) (format nil "~W" part)) parts)) 367 | (wire-deserialize parts))) 368 | (bordeaux-threads:release-lock *message-recv-lock*))) 369 | 370 | 371 | 372 | -------------------------------------------------------------------------------- /src/myjson.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package #:myjson) 3 | 4 | #| 5 | 6 | # (Yet another) JSon encoding/decoding framework # 7 | 8 | There are several libraries available for json encoding and decoding, 9 | but none that satisfies all our requirements. 10 | 11 | |# 12 | 13 | #| 14 | 15 | ## Mapping types ## 16 | 17 | - JSon objects map to Lisp a-lists with string keys 18 | 19 | - Json arrays map to Lisp vectors 20 | 21 | - JSon strings map to Lisp strings 22 | 23 | - JSon true maps to :true 24 | 25 | - JSon false maps to :false 26 | 27 | - JSon null maps to :null 28 | 29 | |# 30 | 31 | #| 32 | 33 | ## Parsing JSon ## 34 | 35 | |# 36 | 37 | (define-condition json-parse-error (error) 38 | ((message :initarg :message 39 | :reader match-error-message)) 40 | (:report (lambda (condition stream) 41 | (format stream "[JSon parse error] ~A" 42 | (match-error-message condition))))) 43 | 44 | (defun char-whitespace-p (char) 45 | (or (char= char #\Space) 46 | (char= char #\Tab) 47 | (char= char #\Return) 48 | (char= char #\Linefeed))) 49 | 50 | (defun read-next-char (input) 51 | (loop 52 | (let ((char (read-char input nil :eof))) 53 | (cond ((eql char :eof) (error 'json-parse-error :message "Unexpected end of file")) 54 | ((char= char #\\) ; c-style escape chars 55 | (let ((char (read-char input nil :eof))) 56 | (cond ((eql char :eof) (error 'json-parse-error :message "Unexpected end of file (after '\'")) 57 | ((char= char #\n) (return #\Newline)) 58 | (t (return char))))) 59 | ((not (char-whitespace-p char)) (return char)))))) 60 | 61 | (example (with-input-from-string (s " { ]") 62 | (list (read-next-char s) 63 | (read-next-char s))) 64 | => '(#\{ #\])) 65 | 66 | (defun peek-next-char (input) 67 | (loop 68 | (let ((char (peek-char nil input nil :eof))) 69 | (cond ((eql char :eof) (error 'json-parse-error :message "Unexpected end of file")) 70 | ((char-whitespace-p char) (read-char input)) 71 | (t (return char)))))) 72 | 73 | (example (with-input-from-string (s " { ]") 74 | (list (peek-next-char s) 75 | (peek-next-char s))) 76 | => '(#\{ #\{)) 77 | 78 | 79 | (defun parse-json (input) 80 | "Parse a JSon document from stream INPUT." 81 | (let ((char (read-next-char input))) 82 | (cond ((char= char #\{) (parse-json-object input)) 83 | ((char= char #\[) (parse-json-array input)) 84 | ((char= char #\") (parse-json-string input)) 85 | ((or (char= char #\-) 86 | (and (char>= char #\0) 87 | (char<= char #\9))) (parse-json-number char input)) 88 | ((char= char #\t) (parse-json-literal-true input)) 89 | ((char= char #\f) (parse-json-literal-false input)) 90 | ((char= char #\n) (parse-json-literal-null input)) 91 | (t (error 'json-parse-error :message (format nil "Unexpected character: ~A" char)))))) 92 | 93 | (defun parse-json-literal (input first literal) 94 | (loop 95 | for expect across literal 96 | do (let ((char (read-char input nil :eof))) 97 | (cond ((eql char :eof) (error 'json-parse-error :message (format nil "Unexpected end of file while parsing literal: ~A~A" first literal))) 98 | ((not (char= char expect)) (error 'json-parse-error :message (format nil "While parsing literal, expecting '~A' instead of: ~A (literal ~A~A)" expect char first literal)))))) 99 | t) 100 | 101 | (defun parse-json-literal-true (input) 102 | (when (parse-json-literal input #\t "rue") 103 | :true)) 104 | 105 | (defun parse-json-literal-false (input) 106 | (when (parse-json-literal input #\f "alse") 107 | :false)) 108 | 109 | (defun parse-json-literal-null (input) 110 | (when (parse-json-literal input #\n "ull") 111 | :null)) 112 | 113 | (defun parse-json-string (input) 114 | (let ((str (make-array 32 :fill-pointer 0 :adjustable t :element-type 'character))) 115 | (loop 116 | (let ((char (read-char input nil :eof))) 117 | ;(format t "char = ~A~%" char) 118 | (cond ((eql char :eof) (error 'json-parse-error :message "Unexpected end of file")) 119 | ((char= char #\\) 120 | (let ((escape-char (read-char input nil :eof))) 121 | ;(format t "escape char = ~A~%" escape-char) 122 | (cond ((eql escape-char :eof) (error 'json-parse-error :message "Unexpected end of file (after '\')")) 123 | ((char= escape-char #\n) (vector-push-extend #\Newline str)) 124 | ((char= escape-char #\t) (vector-push-extend #\Tab str)) 125 | (t 126 | ;;(vector-push-extend char str) ;; XXX: escaping is performed on the lisp side 127 | (vector-push-extend escape-char str))))) 128 | ((char= char #\") (return str)) 129 | (t (vector-push-extend char str))))))) 130 | 131 | (example (with-input-from-string (s "this is a \\\"string\" and the rest") 132 | (parse-json-string s)) 133 | => "this is a \"string") 134 | 135 | 136 | (example (with-input-from-string (s "this is a \\\"string with a \\n newline\" and the rest") 137 | (parse-json-string s)) 138 | => "this is a \"string with a 139 | newline") 140 | 141 | (defun parse-json-object (input) 142 | (let ((obj (list))) 143 | (loop 144 | (let ((ckey (read-next-char input))) 145 | (cond ((char= ckey #\}) (return (nreverse obj))) ;; special case : empty object 146 | ((not (char= ckey #\")) 147 | (error 'json-parse-error :message (format nil "Expecting \" for object key, found: ~A" ckey)))) 148 | (let ((key (parse-json-string input))) 149 | (let ((sep (read-next-char input))) 150 | (when (not (char= sep #\:)) 151 | (error 'json-parse-error :message "Missing key/value separator ':' in object")) 152 | (let ((val (parse-json input))) 153 | (setf obj (cons (cons key val) obj)) 154 | (let ((term (read-next-char input))) 155 | (cond ((char= term #\,) t) ; continue 156 | ((char= term #\}) (return (nreverse obj))) ; in-place is ok 157 | (t (error 'json-parse-error :message (format nil "Unexpected character in object: ~A" term)))))))))))) 158 | 159 | (example (with-input-from-string (s "\"hello\": \"world\", \"val\": \"ue\" } et le reste") 160 | (parse-json-object s)) 161 | => '(("hello" . "world") ("val" . "ue"))) 162 | 163 | (example (with-input-from-string (s "} et le reste") 164 | (parse-json-object s)) 165 | => '()) 166 | 167 | (example (with-input-from-string (s "\"hello\": \"world\", } et le reste") 168 | (parse-json-object s)) 169 | => '(("hello" . "world"))) ; slightly more permissinve with commas 170 | 171 | (defun parse-json-array (input) 172 | (let ((array (make-array 32 :fill-pointer 0 :adjustable t))) 173 | (loop 174 | (let ((char (peek-next-char input))) 175 | (if (char= char #\]) 176 | (progn (read-char input) ; consume the character 177 | (return array)) 178 | ;; any other character 179 | (let ((val (parse-json input))) 180 | (vector-push-extend val array) 181 | (let ((term (read-next-char input))) 182 | (cond ((char= term #\]) (return array)) 183 | ((char= term #\,) t) ; continue 184 | (t (error 'json-parse-error :message (format nil "Unexpected array separator/terminator: ~A" term))))))))))) 185 | 186 | (example (aref (with-input-from-string (s "\"first\", \"second\", \"third\" ] et le reste") 187 | (parse-json-array s)) 2) 188 | => "third") 189 | 190 | (example (length (with-input-from-string (s "] et le reste") 191 | (parse-json-array s))) 192 | => 0) 193 | 194 | 195 | (defun parse-json-digit (input &key (min #\0) (max #\9)) 196 | (let ((char (read-next-char input))) 197 | (if (or (char< char min) 198 | (char> char max)) 199 | (error 'json-parse-error :message (format nil "Expecting digit between in range [~A..~A], found: ~A" min max char)) 200 | char))) 201 | 202 | (example (with-input-from-string (s "43") 203 | (parse-json-digit s)) 204 | => #\4) 205 | 206 | (defun parse-json-digits (input &key (min #\0) (max #\9)) 207 | (let ((digits (make-array 8 :fill-pointer 0 :adjustable t :element-type 'character))) 208 | (loop 209 | (let ((char (peek-char nil input nil :eof))) 210 | (cond ((eql char :eof) (return digits)) 211 | ((and (char>= char min) 212 | (char<= char max)) 213 | (read-char input) 214 | (vector-push-extend char digits)) 215 | (t (return digits))))))) 216 | 217 | (example (with-input-from-string (s "42") 218 | (parse-json-digits s)) 219 | => "42") 220 | 221 | (example (with-input-from-string (s "43 b") 222 | (parse-json-digits s)) 223 | => "43") 224 | 225 | (defun parse-json-number (init input) 226 | (let ((number (format nil "~A" init))) 227 | ;; (format t "Initial = ~A ~%" number) 228 | (let ((fractpart (parse-json-number-fractional-part init input))) 229 | ;; (format t "Fractional = ~A ~%" fractpart) 230 | (setf number (concatenate 'string number fractpart))) 231 | (let ((sep (peek-char nil input nil :eof))) 232 | (when (eql sep #\.) 233 | (read-char input) 234 | (let ((decpart (parse-json-number-decimal-part input))) 235 | ;; (format t "Decimal = ~A ~%" decpart) 236 | (setf number (concatenate 'string number decpart)) 237 | (setf sep (peek-char nil input nil :eof)))) 238 | (when (or (eql sep #\e) (eql sep #\E)) 239 | (read-char input) 240 | (let ((exppart (parse-json-number-exponent-part (format nil "~A" sep) input))) 241 | ;; (format t "Exponent = ~A ~%" exppart) 242 | (setf number (concatenate 'string number exppart))))) 243 | ;; return the resulting number 244 | (read-from-string number))) 245 | 246 | (defun parse-json-number-fractional-part (init input) 247 | (cond ((char= init #\0) "") 248 | ((and (char>= init #\1) 249 | (char<= init #\9)) (parse-json-digits input)) 250 | (t 251 | (concatenate 'string 252 | (format nil "~A" (parse-json-digit input :min #\1)) 253 | (parse-json-digits input))))) 254 | 255 | (example (with-input-from-string (s "132402") 256 | (parse-json-number-fractional-part #\- s)) 257 | => "132402") 258 | 259 | (example (with-input-from-string (s "132402") 260 | (parse-json-number-fractional-part #\4 s)) 261 | => "132402") 262 | 263 | (example (with-input-from-string (s "toto") 264 | (parse-json-number-fractional-part #\0 s)) 265 | => "") 266 | 267 | (defun parse-json-number-decimal-part (input) 268 | (concatenate 'string "." (parse-json-digits input))) 269 | 270 | (defun parse-json-number-exponent-part (exp input) 271 | (let ((exponent exp)) 272 | (let ((char (peek-char nil input nil :eof))) 273 | (cond ((eql char #\+) (read-char input) (setf exponent (concatenate 'string exponent "+"))) 274 | ((eql char #\-) (read-char input) (setf exponent (concatenate 'string exponent "-"))) 275 | ((and (characterp char) 276 | (char>= char #\0) 277 | (char<= char #\9)) (read-char input) (setf exponent (concatenate 'string exponent (format nil "~A" char)))) 278 | (t (error 'json-parse-error :message (format nil "Missing exponent digit(s) or sign, found: ~A" char))))) 279 | (concatenate 'string exponent (parse-json-digits input)))) 280 | 281 | (example (with-input-from-string (s "+009") 282 | (parse-json-number-exponent-part "e" s)) 283 | => "e+009") 284 | 285 | (example (with-input-from-string (s "-909") 286 | (parse-json-number-exponent-part "E" s)) 287 | => "E-909") 288 | 289 | (example (with-input-from-string (s "909") 290 | (parse-json-number-exponent-part "E" s)) 291 | => "E909") 292 | 293 | 294 | (example (with-input-from-string (s "34.212e-42") 295 | (parse-json-number #\- s)) 296 | => -3.42113e-41 :warn-only t) 297 | 298 | (example (with-input-from-string (s "34.212e-42") 299 | (parse-json-number #\1 s)) 300 | => 1.3421076e-40 :warn-only t) 301 | 302 | (example (with-input-from-string (s ".212E+32") 303 | (parse-json-number #\0 s)) 304 | => 2.12e31 :warn-only t) 305 | 306 | 307 | (example (afetch "isAlive" 308 | (with-input-from-string (s "{ 309 | \"firstName\": \"John\", 310 | \"lastName\": \"Smith\", 311 | \"isAlive\": true, 312 | \"age\": 25, 313 | \"height_cm\": 167.6, 314 | \"address\": { 315 | \"streetAddress\": \"21 2nd Street\", 316 | \"city\": \"New York\", 317 | \"state\": \"NY\", 318 | \"postalCode\": \"10021-3100\" 319 | }, 320 | \"phoneNumbers\": [ 321 | { 322 | \"type\": \"home\", 323 | \"number\": \"212 555-1234\" 324 | }, 325 | { 326 | \"type\": \"office\", 327 | \"number\": \"646 555-4567\" 328 | } 329 | ], 330 | \"children\": [ \"alfi\", \"alfo\", \"alfa\" ], 331 | \"spouse\": null 332 | }") 333 | (parse-json s)) :test #'equal) 334 | => :true) 335 | 336 | 337 | (defun parse-json-from-string (str) 338 | "Parse a JSon document encoded in the string STR." 339 | (with-input-from-string (s str) 340 | (parse-json s))) 341 | 342 | (example (parse-json-from-string "40350") 343 | => 40350) 344 | 345 | #| 346 | 347 | ## JSon encoding ## 348 | 349 | |# 350 | 351 | 352 | (defparameter *json-encoder-indent-level* 2 353 | "Indentation level (number of space(s) per indent) for the 354 | JSon encoder (default is 2).") 355 | 356 | (defgeneric encode-json (stream thing &key indent) 357 | (:documentation "Encode on STREAM a JSon representation of THING. 358 | The INDENT can be given for beautiful/debugging output (default is NIL 359 | for deactivating the indentation).")) 360 | 361 | (defun encode-json-to-string (thing &key indent) 362 | "Encode as a string a JSon representation of THING. 363 | The INDENT can be given for beautiful/debugging output (default is NIL 364 | for deactivating the indentation)." 365 | (with-output-to-string (stream) 366 | (encode-json stream thing :indent indent))) 367 | 368 | (defun gen-indent (level) 369 | (if level 370 | (make-string (* level *json-encoder-indent-level*) :initial-element #\Space) 371 | "")) 372 | 373 | (example (gen-indent 5) 374 | => " ") 375 | 376 | (defun string-to-json-string (str) 377 | (let ((jstr (make-array (length str) :fill-pointer 0 :adjustable t :element-type 'character))) 378 | (loop 379 | for char across str 380 | do (cond ((char= char #\Newline) 381 | (vector-push-extend #\\ jstr) 382 | (vector-push-extend #\n jstr)) 383 | ((char= char #\Tab) 384 | (vector-push-extend #\\ jstr) 385 | (vector-push-extend #\t jstr)) 386 | (t (vector-push-extend char jstr)))) 387 | jstr)) 388 | 389 | (example 390 | (string-to-json-string "this is a string 391 | with a new line") 392 | => "this is a string \\nwith a new line") 393 | 394 | (example 395 | (string-to-json-string "this is a string with a tabular character") 396 | => "this is a string\\twith a tabular character") 397 | 398 | (example 399 | (string-to-json-string "(format t \"hello~%\")") 400 | => "(format t \"hello~%\")") 401 | 402 | (defun json-write (stream indent with-newline str) 403 | (when indent 404 | (write-string (gen-indent indent) stream)) 405 | (write-string str stream) 406 | (when with-newline 407 | (terpri stream))) 408 | 409 | (example (with-output-to-string (stream) 410 | (let ((toto '(me toto))) 411 | (json-write stream 2 t (format nil "blabla ~A" toto)))) 412 | => " blabla (ME TOTO) 413 | ") 414 | 415 | (example (with-output-to-string (stream) 416 | (let ((toto '(me toto))) 417 | (json-write stream 2 nil (format nil "blabla ~A" toto)))) 418 | => " blabla (ME TOTO)") 419 | 420 | (example (with-output-to-string (stream) 421 | (let ((toto '(me toto))) 422 | (json-write stream nil nil (format nil "blabla ~A" toto)))) 423 | => "blabla (ME TOTO)") 424 | 425 | (defmethod encode-json (stream (thing cons) &key (indent nil) (first-line nil)) 426 | (json-write stream (if first-line nil indent) (if indent t nil) "{") 427 | (let ((sepstr (if indent (format nil ",~%") ","))) 428 | (loop 429 | for (key . val) in thing 430 | for sep = "" then sepstr 431 | do (progn (json-write stream nil nil sep) 432 | (json-write stream (if indent (1+ indent) nil) nil (format nil "~W: " key)) 433 | (encode-json stream val :indent (if indent (+ 2 indent) nil) :first-line t)))) 434 | (when (and thing indent) 435 | (format stream "~%")) 436 | (json-write stream indent nil "}")) 437 | 438 | (defmethod encode-json (stream (thing null) &key (indent nil) (first-line nil)) 439 | (json-write stream (if first-line nil indent) (if indent t nil) "{}")) 440 | 441 | (defmethod encode-json (stream (thing array) &key (indent nil) (first-line nil)) 442 | (json-write stream (if first-line nil indent) (if indent t nil) "[") 443 | (let ((sepstr (if indent (format nil ",~%") ","))) 444 | (loop 445 | for val across thing 446 | for sep = "" then sepstr 447 | do (progn (json-write stream nil nil sep) 448 | (encode-json stream val :indent (if indent (+ 1 indent) nil) :first-line t)))) 449 | (when (and thing indent) 450 | (format stream "~%")) 451 | (json-write stream indent nil "]")) 452 | 453 | (defmethod encode-json (stream (thing string) &key (indent nil) (first-line nil)) 454 | (json-write stream (if first-line nil indent) nil (string-to-json-string (with-output-to-string (str) (prin1 thing str))))) 455 | 456 | (example 457 | (encode-json-to-string "help me \"man\" yeah !") 458 | => "\"help me \\\"man\\\" yeah !\"") 459 | 460 | (example 461 | (encode-json-to-string "help me \"man\" 462 | yeah !") 463 | => "\"help me \\\"man\\\"\\nyeah !\"") 464 | 465 | (example 466 | (encode-json-to-string "(format t \"hello~%\")") 467 | => "\"(format t \\\"hello~%\\\")\"") 468 | 469 | 470 | (defmethod encode-json (stream (thing integer) &key (indent nil) (first-line nil)) 471 | (json-write stream (if first-line nil indent) nil (format nil "~A" thing))) 472 | 473 | (example 474 | (encode-json-to-string 123) 475 | => "123") 476 | 477 | 478 | (defmethod encode-json (stream (thing float) &key (indent nil) (first-line nil)) 479 | (json-write stream (if first-line nil indent) nil (format nil "~A" thing))) 480 | 481 | (example 482 | (encode-json-to-string -3.242E-12) 483 | => "-3.242E-12" :warn-only t) 484 | 485 | (defmethod encode-json (stream (thing (eql :true)) &key (indent nil) (first-line nil)) 486 | (json-write stream (if first-line nil indent) nil "true")) 487 | 488 | (example 489 | (encode-json-to-string :true) 490 | => "true") 491 | 492 | (defmethod encode-json (stream (thing (eql :false)) &key (indent nil) (first-line nil)) 493 | (json-write stream (if first-line nil indent) nil "false")) 494 | 495 | (example 496 | (encode-json-to-string :false) 497 | => "false") 498 | 499 | (defmethod encode-json (stream (thing (eql :null)) &key (indent nil) (first-line nil)) 500 | (json-write stream (if first-line nil indent) nil "null")) 501 | 502 | (example 503 | (encode-json-to-string :null) 504 | => "null") 505 | 506 | 507 | 508 | (example 509 | (encode-json-to-string '(("name" . "frederic") 510 | ("age" . 41) 511 | ("geek" . :true) 512 | ("socks" . :null))) 513 | => "{\"name\": \"frederic\",\"age\": 41,\"geek\": true,\"socks\": null}") 514 | 515 | (example 516 | (encode-json-to-string '(("name" . "frederic") 517 | ("age" . 41) 518 | ("geek" . :true) 519 | ("socks" . :null)) :indent 0) 520 | => "{ 521 | \"name\": \"frederic\", 522 | \"age\": 41, 523 | \"geek\": true, 524 | \"socks\": null 525 | }") 526 | 527 | (example 528 | (encode-json-to-string '(("name" . "frederic") 529 | ("parent" . #("dany" "robi" "krim" "claude")))) 530 | => "{\"name\": \"frederic\",\"parent\": [\"dany\",\"robi\",\"krim\",\"claude\"]}") 531 | 532 | 533 | 534 | -------------------------------------------------------------------------------- /src/packages.lisp: -------------------------------------------------------------------------------- 1 | 2 | (defpackage #:fredokun-utilities 3 | (:nicknames #:fredo-utils) 4 | (:use #:cl) 5 | (:export #:*example-enabled* 6 | #:*example-equal-predicate* 7 | #:example 8 | #:example-progn 9 | #:*logg-enabled* 10 | #:*logg-level* 11 | #:logg 12 | #:vbinds 13 | #:afetch 14 | #:while 15 | #:read-file-lines 16 | #:read-string-file 17 | #:read-binary-file 18 | #:quit)) 19 | 20 | (defpackage #:myjson 21 | (:use #:cl #:fredo-utils) 22 | (:export #:parse-json 23 | #:parse-json-from-string 24 | #:encode-json 25 | #:encode-json-to-string)) 26 | 27 | (defpackage #:cl-jupyter 28 | (:use #:cl #:fredo-utils #:myjson) 29 | (:export 30 | #:display 31 | #:display-plain render-plain 32 | #:display-html render-html 33 | #:display-markdown render-markdown 34 | #:display-latex render-latex 35 | #:display-png render-png 36 | #:display-jpeg render-jpeg 37 | #:display-svg render-svg 38 | #:display-json render-json 39 | #:display-javascript render-javascript 40 | #:kernel-start)) 41 | 42 | (defpackage #:cl-jupyter-user 43 | (:use #:cl #:fredo-utils #:cl-jupyter #:common-lisp-user) 44 | (:export 45 | #:display 46 | #:display-plain render-plain 47 | #:display-html render-html 48 | #:display-markdown render-markdown 49 | #:display-latex render-latex 50 | #:display-png render-png 51 | #:display-jpeg render-jpeg 52 | #:display-svg render-svg 53 | #:display-json render-json 54 | #:display-javascript render-javascript 55 | #:html #:latex #:svg 56 | #:png-from-file 57 | #:svg-from-file 58 | #:quit)) 59 | 60 | (in-package #:cl-jupyter) 61 | -------------------------------------------------------------------------------- /src/shell.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-jupyter) 2 | 3 | #| 4 | 5 | # The shell router socket # 6 | 7 | |# 8 | 9 | (defclass shell-channel () 10 | ((kernel :initarg :kernel :reader shell-kernel) 11 | (socket :initarg :socket :initform nil :accessor shell-socket))) 12 | 13 | 14 | (defun make-shell-channel (kernel) 15 | (let ((socket (pzmq:socket (kernel-ctx kernel) :router))) 16 | (let ((shell (make-instance 'shell-channel 17 | :kernel kernel 18 | :socket socket))) 19 | (let ((config (slot-value kernel 'config))) 20 | (let ((endpoint (format nil "~A://~A:~A" 21 | (config-transport config) 22 | (config-ip config) 23 | (config-shell-port config)))) 24 | ;; (format t "shell endpoint is: ~A~%" endpoint) 25 | (pzmq:bind socket endpoint) 26 | shell))))) 27 | 28 | (defun shell-loop (shell) 29 | (let ((active t)) 30 | (format t "[Shell] loop started~%") 31 | (send-status-starting (kernel-iopub (shell-kernel shell)) (kernel-session (shell-kernel shell)) :key (kernel-key shell)) 32 | (while active 33 | (vbinds (identities sig msg buffers) (message-recv (shell-socket shell)) 34 | ;;(format t "Shell Received:~%") 35 | ;;(format t " | identities: ~A~%" identities) 36 | ;;(format t " | signature: ~W~%" sig) 37 | ;;(format t " | message: ~A~%" (encode-json-to-string (message-header msg))) 38 | ;;(format t " | buffers: ~W~%" buffers) 39 | 40 | ;; TODO: check the signature (after that, sig can be forgotten) 41 | (let ((msg-type (header-msg-type (message-header msg)))) 42 | (cond ((equal msg-type "kernel_info_request") 43 | (handle-kernel-info-request shell identities msg buffers)) 44 | ((equal msg-type "execute_request") 45 | (setf active (handle-execute-request shell identities msg buffers))) 46 | (t (warn "[Shell] message type '~A' not (yet ?) supported, skipping..." msg-type)))))))) 47 | 48 | 49 | #| 50 | 51 | ### Message type: kernel_info_reply ### 52 | 53 | |# 54 | 55 | ;; for protocol version 5 56 | (defclass content-kernel-info-reply (message-content) 57 | ((protocol-version :initarg :protocol-version :type string) 58 | (implementation :initarg :implementation :type string) 59 | (implementation-version :initarg :implementation-version :type string) 60 | (language-info-name :initarg :language-info-name :type string) 61 | (language-info-version :initarg :language-info-version :type string) 62 | (language-info-mimetype :initarg :language-info-mimetype :type string) 63 | (language-info-pygments-lexer :initarg :language-info-pygments-lexer :type string) 64 | (language-info-codemirror-mode :initarg :language-info-codemirror-mode :type string) 65 | (language-info-nbconvert-exporter :initarg :language-info-nbconvert-exporter :type string) 66 | (banner :initarg :banner :type string) 67 | ;; help links: (text . url) a-list 68 | (help-links :initarg :help-links))) 69 | 70 | ;; for protocol version 4.1 71 | ;;(defclass content-kernel-info-reply (message-content) 72 | ;; ((protocol-version :initarg :protocol-version) 73 | ;; (language-version :initarg :language-version) 74 | ;; (language :initarg :language :type string))) 75 | 76 | (defun help-links-to-json (help-links) 77 | (concatenate 'string "[" 78 | (concat-all 'string "" 79 | (join "," (mapcar (lambda (link) 80 | (format nil "{ \"text\": ~W, \"url\": ~W }" (car link) (cdr link))) 81 | help-links))) 82 | "]")) 83 | 84 | ;; for protocol version 5 85 | (defmethod encode-json (stream (object content-kernel-info-reply) &key (indent nil) (first-line nil)) 86 | (with-slots (protocol-version 87 | implementation implementation-version 88 | language-info-name language-info-version 89 | language-info-mimetype language-info-pygments-lexer language-info-codemirror-mode 90 | language-info-nbconvert-exporter 91 | banner help-links) object 92 | (encode-json stream `(("protocol_version" . ,protocol-version) 93 | ("implementation" . ,implementation) 94 | ("implementation_version" . ,implementation-version) 95 | ("language_info" . (("name" . ,language-info-name) 96 | ("version" . ,language-info-version) 97 | ("mimetype" . ,language-info-mimetype) 98 | ("pygments_lexer" . ,language-info-pygments-lexer) 99 | ("codemirror_mode" . ,language-info-codemirror-mode))) 100 | ;("nbconvert_exporter" . ,language-info-nbconvert-exporter))) 101 | ("banner" . "cl-jupyter")) ; ,banner) 102 | ;("help_links" . ,help-links)) 103 | :indent indent :first-line first-line))) 104 | 105 | (defun kernel-key (shell) 106 | (kernel-config-key (kernel-config (shell-kernel shell)))) 107 | 108 | (defun handle-kernel-info-request (shell identities msg buffers) 109 | ;;(format t "[Shell] handling 'kernel-info-request'~%") 110 | ;; status to busy 111 | ;;(send-status-update (kernel-iopub (shell-kernel shell)) msg "busy" :key (kernel-key shell)) 112 | ;; for protocol version 5 113 | (let ((reply (make-message 114 | msg "kernel_info_reply" nil 115 | (make-instance 116 | 'content-kernel-info-reply 117 | :protocol-version (header-version (message-header msg)) 118 | :implementation +KERNEL-IMPLEMENTATION-NAME+ 119 | :implementation-version +KERNEL-IMPLEMENTATION-VERSION+ 120 | :language-info-name "common-lisp" 121 | :language-info-version "X3J13" 122 | :language-info-mimetype "text/x-common-lisp" 123 | :language-info-pygments-lexer "common-lisp" 124 | :language-info-codemirror-mode "text/x-common-lisp" 125 | :language-info-nbconvert-exporter "" 126 | :banner (banner) 127 | :help-links (vector))))) 128 | ;;'(("Common Lisp Hyperspec" . "http://www.lispworks.com/documentation/HyperSpec/Front/index.htm")))))) 129 | ;; for protocol version 4.1 130 | ;; (let ((reply (make-message-from-parent msg "kernel_info_reply" nil 131 | ;; (make-instance 132 | ;; 'content-kernel-info-reply 133 | ;; :protocol-version #(4 1) 134 | ;; :language-version #(1 2 7) ;; XXX: impl. dependent but really cares ? 135 | ;; :language "common-lisp")))) 136 | (message-send (shell-socket shell) reply :identities identities :key (kernel-key shell)) 137 | ;; status back to idle 138 | ;;(send-status-update (kernel-iopub (shell-kernel shell)) msg "idle" :key (kernel-key shell)) 139 | )) 140 | 141 | #| 142 | 143 | ### Message type: execute_request ### 144 | 145 | |# 146 | 147 | 148 | (defun handle-execute-request (shell identities msg buffers) 149 | ;;(format t "[Shell] handling 'execute_request'~%") 150 | (send-status-update (kernel-iopub (shell-kernel shell)) msg "busy" :key (kernel-key shell)) 151 | (let ((content (parse-json-from-string (message-content msg)))) 152 | ;;(format t " ==> Message content = ~W~%" content) 153 | (let ((code (afetch "code" content :test #'equal))) 154 | ;;(format t " ===> Code to execute = ~W~%" code) 155 | (vbinds (execution-count results stdout stderr) 156 | (evaluate-code (kernel-evaluator (shell-kernel shell)) code) 157 | ;(format t "Execution count = ~A~%" execution-count) 158 | ;(format t "results = ~A~%" results) 159 | ;(format t "STDOUT = ~A~%" stdout) 160 | ;(format t "STDERR = ~A~%" stderr) 161 | ;; broadcast the code to connected frontends 162 | (send-execute-code (kernel-iopub (shell-kernel shell)) msg execution-count code :key (kernel-key shell)) 163 | (when (and (consp results) (typep (car results) 'cl-jupyter-user::cl-jupyter-quit-obj)) 164 | ;; ----- ** request for shutdown ** ----- 165 | (let ((reply (make-message msg "execute_reply" nil 166 | `(("status" . "abort") 167 | ("execution_count" . ,execution-count))))) 168 | (message-send (shell-socket shell) reply :identities identities :key (kernel-key shell))) 169 | (return-from handle-execute-request nil)) 170 | ;; ----- ** normal request ** ----- 171 | ;; send the stdout 172 | (when (and stdout (> (length stdout) 0)) 173 | (send-stream (kernel-iopub (shell-kernel shell)) msg "stdout" stdout :key (kernel-key shell))) 174 | ;; send the stderr 175 | (when (and stderr (> (length stderr) 0)) 176 | (send-stream (kernel-iopub (shell-kernel shell)) msg "stderr" stderr :key (kernel-key shell))) 177 | ;; send the first result 178 | (send-execute-result (kernel-iopub (shell-kernel shell)) 179 | msg execution-count (car results) :key (kernel-key shell)) 180 | ;; status back to idle 181 | (send-status-update (kernel-iopub (shell-kernel shell)) msg "idle" :key (kernel-key shell)) 182 | ;; send reply (control) 183 | (let ((reply (make-message msg "execute_reply" nil 184 | `(("status" . "ok") 185 | ("execution_count" . ,execution-count) 186 | ("payload" . ,(vector)))))) 187 | (message-send (shell-socket shell) reply :identities identities :key (kernel-key shell)) 188 | t))))) 189 | 190 | #| 191 | 192 | ## Message content ## 193 | 194 | |# 195 | 196 | (defclass message-content () 197 | () 198 | (:documentation "The base class of message contents.")) 199 | 200 | -------------------------------------------------------------------------------- /src/user.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package #:cl-jupyter-user) 3 | 4 | (defclass cl-jupyter-quit-obj () 5 | () 6 | (:documentation "A quit object for identifying a request for kernel shutdown.")) 7 | 8 | (defun quit () 9 | (make-instance 'cl-jupyter-quit-obj)) 10 | 11 | 12 | #| 13 | 14 | ## Basic Markdown support ## 15 | 16 | |# 17 | 18 | ;; remark: this is not supported in IPython 2.x (will it be in 3 ?) 19 | (defclass markdown-text () 20 | ((text :initarg :text :reader markdown-text))) 21 | 22 | (defmethod render-markdown ((doc markdown-text)) 23 | (markdown-text doc)) 24 | 25 | (defun markdown (text) 26 | (display-markdown (make-instance 'markdown-text :text text))) 27 | 28 | 29 | #| 30 | 31 | ## Basic Latex support ## 32 | 33 | |# 34 | 35 | (defclass latex-text () 36 | ((text :initarg :text :reader latex-text))) 37 | 38 | (defmethod render-latex ((doc latex-text)) 39 | (with-output-to-string (str) 40 | (format str "~A" (latex-text doc)))) 41 | 42 | (defun latex (text) 43 | (display-latex (make-instance 'latex-text :text text))) 44 | 45 | (example (cl-jupyter::display-object-data (latex "$\\frac{1}{2}$")) 46 | => '(("text/plain" . "#") 47 | ("text/latex" . "$\\frac{1}{2}$")) :warn-only t) 48 | 49 | 50 | #| 51 | 52 | ## Basic HTML support ## 53 | 54 | |# 55 | 56 | (defclass html-text () 57 | ((text :initarg :text :reader html-text))) 58 | 59 | (defmethod render-html ((doc html-text)) 60 | (html-text doc)) 61 | ;(with-output-to-string (str) 62 | ; (format str "~A" (html-text doc)))) 63 | 64 | (defun html (text) 65 | (display-html (make-instance 'html-text :text text))) 66 | 67 | (example (cl-jupyter::display-object-data 68 | (html "

cl-Jupyter is cool !

")) 69 | => '(("text/plain" . "#") 70 | ("text/html" 71 | . "

cl-Jupyter is cool !

")) :warn-only t) 72 | 73 | #| 74 | 75 | ## Basic PNG support ## 76 | 77 | |# 78 | 79 | (defclass png-bytes () 80 | ((bytes :initarg :bytes :reader png-bytes))) 81 | 82 | (defmethod render-png ((img png-bytes)) 83 | (cl-base64:usb8-array-to-base64-string (png-bytes img))) 84 | 85 | (defun png-from-file (filename) 86 | (let ((bytes (read-binary-file filename))) 87 | (display-png (make-instance 'png-bytes :bytes bytes)))) 88 | 89 | #| 90 | 91 | ## Basic SVG support ## 92 | 93 | |# 94 | 95 | 96 | (defclass svg-str () 97 | ((str :initarg :str :reader svg-str))) 98 | 99 | (defmethod render-svg ((img svg-str)) 100 | (svg-str img)) 101 | 102 | (defun svg (desc) 103 | (display-svg (make-instance 'svg-str :str desc))) 104 | 105 | (defun svg-from-file (filename) 106 | (let ((str (read-string-file filename))) 107 | (display-svg (make-instance 'svg-str :str str)))) 108 | 109 | 110 | #| 111 | 112 | ## History management 113 | 114 | |# 115 | 116 | (defun %in (hist-ref) 117 | (cl-jupyter::take-history-in hist-ref)) 118 | ;; (let ((history-in (slot-value cl-jupyter::*evaluator* 'cl-jupyter::history-in))) 119 | ;; (if (and (>= hist-ref 0) 120 | ;; (< hist-ref (length history-in))) 121 | ;; (aref history-in hist-ref) 122 | ;; nil))) 123 | 124 | (defun %out (hist-ref &optional value-ref) 125 | (cl-jupyter::take-history-out hist-ref value-ref)) 126 | ;; (let ((history-out (slot-value cl-jupyter::*evaluator* 'cl-jupyter::history-out))) 127 | ;; (if (and (>= hist-ref 0) 128 | ;; (< hist-ref (length history-out))) 129 | ;; (let ((out-values (aref history-out hist-ref))) 130 | ;; (if (and (>= value-ref 0) 131 | ;; (< value-ref (length out-values))) 132 | ;; (elt out-values value-ref) 133 | ;; nil))))) 134 | 135 | 136 | -------------------------------------------------------------------------------- /src/utils.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package #:fredokun-utilities) 3 | 4 | #| 5 | 6 | # CommonTypes: Utilities # 7 | 8 | |# 9 | 10 | ;; To activate the inline examples 11 | (eval-when (:compile-toplevel :load-toplevel :execute) 12 | (defparameter *example-enabled* t) ;; nil in production / t for self-testing 13 | 14 | (defparameter *example-equal-predicate* #'equal) 15 | 16 | (defparameter *example-with-echo* nil) 17 | 18 | ) 19 | 20 | 21 | (defmacro example (expr arrow expected &key (warn-only nil)) 22 | "Show an evaluation example, useful for documentation and lightweight testing. 23 | 24 | (example `EXPR` => `EXPECTED`) evaluates `EXPR` and compare, wrt. `EQUIV` 25 | (EQUAL by default) to `EXPECTED` and raise an error if inequal. 26 | 27 | Set `WARN-ONLY` to T for warning instead of error. 28 | " 29 | (if (not *example-enabled*) 30 | (progn 31 | (when *example-with-echo* 32 | (format t "------------------~%") 33 | (format t "Example:~%~A~%=?= ~A~%" (format nil "~A" expr) expected) 34 | (format t " ===> SKIP~%")) 35 | (values));; synonymous of nil if disabled 36 | ;; when enabled 37 | (let ((result-var (gensym "result-")) 38 | (expected-var (gensym "expected-")) 39 | (err-fun-var (gensym "err-fun-")) 40 | (expr-str (format nil "~A" expr))) 41 | `(progn 42 | (when *example-with-echo* 43 | (format t "------------------~%") 44 | (format t "Example:~%~A~%=?= ~A~%" ,expr-str ,expected)) 45 | (let ((,err-fun-var (if ,warn-only #'warn #'error)) 46 | (,result-var ,expr) 47 | (,expected-var ,expected)) 48 | (if (not (equal (symbol-name (quote ,arrow)) "=>")) 49 | (error "Missing arrow '=>' in example expression")) 50 | (if (funcall *example-equal-predicate* ,result-var ,expected-var) 51 | (progn (if *example-with-echo* 52 | (format t " ===> PASS~%")) 53 | t) 54 | (funcall ,err-fun-var "Failed example:~% Expression: ~S~% ==> expected: ~A~% ==> evaluated: ~A~%" 55 | ,expr-str ,expected-var ,result-var))))))) 56 | 57 | 58 | (defmacro example-progn (&body body) 59 | "The toplevel forms of BODY are evaluated only if examples are enabled" 60 | (if *example-enabled* 61 | `(progn ,@body) 62 | (values))) 63 | 64 | (defmacro logg (level fmt &rest args) 65 | "Log the passed ARGS using the format string FMT and its 66 | arguments ARGS." 67 | (if (or (not *log-enabled*) 68 | (< level *log-level*)) 69 | (values);; disabled 70 | ;; when enabled 71 | `(progn (format ,*log-out-stream* "[LOG]:") 72 | (format ,*log-out-stream* ,fmt ,@args) 73 | (format ,*log-out-stream* "~%")))) 74 | 75 | (defmacro vbinds (binders expr &body body) 76 | "An abbreviation for MULTIPLE-VALUE-BIND." 77 | (labels ((replace-underscores (bs &optional (result nil) (fresh-vars nil) (replaced nil)) 78 | (if (null bs) 79 | (let ((nresult (nreverse result)) 80 | (nfresh (nreverse fresh-vars))) 81 | (values replaced nresult nfresh)) 82 | (if (equal (symbol-name (car bs)) "_") 83 | (let ((fresh-var (gensym "underscore-"))) 84 | (replace-underscores (cdr bs) (cons fresh-var result) (cons fresh-var fresh-vars) t)) 85 | (replace-underscores (cdr bs) (cons (car bs) result) fresh-vars replaced))))) 86 | (multiple-value-bind (has-underscore nbinders fresh-vars) (replace-underscores binders) 87 | (if has-underscore 88 | `(multiple-value-bind ,nbinders ,expr 89 | (declare (ignore ,@fresh-vars)) 90 | ,@body) 91 | `(multiple-value-bind ,binders ,expr ,@body))))) 92 | 93 | (example (vbinds (a _ b) (values 1 2 3) 94 | (cons a b)) 95 | => '(1 . 3)) ;; without a warning 96 | 97 | (example (vbinds (a _ b _) (values 1 2 3 4) 98 | (cons a b)) 99 | => '(1 . 3)) ;; without a warning 100 | 101 | 102 | (defun afetch (comp alist &key (test #'eql)) 103 | (let ((binding (assoc comp alist :test test))) 104 | (if binding 105 | (cdr binding) 106 | (error "No such key: ~A" comp)))) 107 | 108 | (defmacro while (condition &body body) 109 | (let ((eval-cond-var (gensym "eval-cond-")) 110 | (body-val-var (gensym "body-val-"))) 111 | `(flet ((,eval-cond-var () ,`,condition)) 112 | (do ((,body-val-var nil (progn ,@body))) 113 | ((not (,eval-cond-var)) 114 | ,body-val-var))))) 115 | 116 | (example (let ((count 0)) 117 | (while (< count 10) 118 | ;;(format t "~A " count) 119 | (incf count) 120 | count)) 121 | => 10) 122 | 123 | (defun read-file-lines (filename) 124 | (with-open-file (input filename) 125 | (loop 126 | for line = (read-line input nil 'eof) 127 | until (eq line 'eof) 128 | collect line))) 129 | 130 | (defun read-binary-file (filename) 131 | (with-open-file (stream filename :element-type '(unsigned-byte 8)) 132 | (let ((bytes (make-array (file-length stream) :element-type '(unsigned-byte 8)))) 133 | (read-sequence bytes stream) 134 | bytes))) 135 | 136 | (defun read-string-file (filename) 137 | (with-open-file (stream filename) 138 | (let ((str (make-array (file-length stream) :element-type 'character :fill-pointer t))) 139 | (setf (fill-pointer str) (read-sequence str stream)) 140 | str))) 141 | 142 | 143 | ;; Taken from Rob Warnock's post "How to programmatically exit?" 144 | (defun quit (&optional code) 145 | ;; This group from "clocc-port/ext.lisp" 146 | #+allegro (excl:exit code) 147 | #+clisp (#+lisp=cl ext:quit #-lisp=cl lisp:quit code) 148 | #+cmu (ext:quit code) 149 | #+cormanlisp (win32:exitprocess code) 150 | #+gcl (lisp:bye code) ; XXX Or is it LISP::QUIT? 151 | #+lispworks (lw:quit :status code) 152 | #+lucid (lcl:quit code) 153 | #+sbcl (sb-ext:exit :code code) 154 | ;; This group from Maxima 155 | #+kcl (lisp::bye) ; XXX Does this take an arg? 156 | #+scl (ext:quit code) ; XXX Pretty sure this *does*. 157 | #+(or openmcl mcl) (ccl::quit) 158 | #+abcl (cl-user::quit) 159 | #+ecl (si:quit) 160 | ;; This group from 161 | #+poplog (poplog::bye) ; XXX Does this take an arg? 162 | #-(or allegro clisp cmu cormanlisp gcl lispworks lucid sbcl 163 | kcl scl openmcl mcl abcl ecl) 164 | (error 'not-implemented :proc (list 'quit code))) 165 | --------------------------------------------------------------------------------