;; #!/usr/bin/sbcl --script (load "~/quicklisp/setup") (let ((*standard-output* (make-broadcast-stream))) (ql:quickload "cl-readline")) (uiop:define-package :sbcli (:use :common-lisp :trivial-package-local-nicknames) (:import-from :magic-ed :magic-ed) (:export repl sbcli help what *repl-version* *repl-name* *prompt* *prompt2* *result-indicator* *init-file* *quicklisp* *hist-file* *special* *syntax-highlighting* *pygmentize* *pygmentize-options*)) (in-package :sbcli) ;; repl-utilities: nice to have, but don't clutter the CIEL package by exporting them. ;; For instance, "summary" is too common a word to be exported. (cl-reexport:reexport-from :repl-utilities :include '(:repl-utilities :readme ;; :doc ;; conflicts with our little %doc helper. :summary :package-apropos :trace-package :print-hash)) (defvar *repl-version* "0.1.5") ;XXX: print CIEL version. (defvar *banner* " _..._ .-'_..._''. .---. .' .' '.\.--. __.....__ | | / .' |__| .-'' '. | | . ' .--. / .-''''-. `. | | | | | |/ /________\ \| | | | | || || | . ' | |\ .-------------'| | \ '. .| | \ '-.____...---.| | '. `._____.-'/|__| `. .' | | `-.______ / `''-...... -' '---' ` ") (defvar *repl-name* "CIEL's REPL") (defvar *prompt* (format nil "~a" (cl-ansi-text:green "ciel-user> "))) (defvar *prompt2* "....> ") (defvar *result-indicator* "=> ") (defvar *init-file* "~/.cielrc") (defvar *hist-file* "~/.ciel_history") (defvar *hist* (list)) (defvar *syntax-highlighting* nil) (defvar *pygmentize* nil "(optional) Path to a pygments executable. If not set, we try to find it.") (defvar *pygmentize-options* (list "-s" "-l" "lisp")) (defparameter *lisp-critic* nil "If non-nil, give feedback on the code you type using lisp-critic.") (declaim (special *special*)) (defun print-system-info (&optional (stream t)) ;; see also https://github.com/40ants/cl-info (format stream "~&OS: ~a ~a~&" (software-type) (software-version)) (format stream "~&Lisp: ~a ~a~&" (lisp-implementation-type) (lisp-implementation-version)) #+asdf (format stream "~&ASDF: ~a~&" (asdf:asdf-version)) #-asdf (format stream "NO ASDF!") #+quicklisp (format stream "~&Quicklisp: ~a~&" (ql-dist:all-dists)) #-quicklisp (format stream "!! Quicklisp is not installed !!")) (defun read-hist-file () (with-open-file (in *hist-file* :if-does-not-exist :create) (loop for line = (read-line in nil nil) while line ;; hack because cl-readline has no function for this. ;; TODO: it has it now. do (cffi:foreign-funcall "add_history" :string line :void)))) (defun update-hist-file (str) (with-open-file (out *hist-file* :direction :output :if-exists :append :if-does-not-exist :create) (write-line str out))) (defun load-init-file (&optional (init-file *init-file*)) "Load the ~/.cielrc init file. Defaults to `*init-file*'." (load init-file)) (defun end () "Ends the session." (format t "~%Bye!~&") (uiop:quit)) ;; (defun reset () ;; "Resets the session environment" ;; (delete-package 'sbcli) ;; (defpackage :sbcli (:use :common-lisp :ciel)) ;; ;XXX: ? ;; (in-package :sbcli)) (defun novelty-check (str1 str2) (string/= (string-trim " " str1) (string-trim " " str2))) (defun history-add (txt res) (setq *hist* (cons (list txt res) *hist*))) (defun format-output (&rest args) (format (car args) "~a ; => ~a" (caadr args) (cadadr args))) (defun write-to-file (fname) "Writes the current session to a file " (with-open-file (file fname :direction :output :if-exists :supersede :if-does-not-exist :create) (format file "~{~/sbcli:format-output/~^~%~}" (reverse *hist*)))) (defun what (sym) "Gets help on a symbol : :? str" (format t "inspecting ~a.~&~ To inspect further objects, type their number.~&~ To quit, type q and Enter." sym) (handler-case (inspect (read-from-string sym)) (error (c) (format *error-output* "Error during inspection: ~a~%" c)))) (defun help () "Prints this general help message" (format t "~a version ~a~%" *repl-name* *repl-version*) (write-line "Read more on packages with readme or summary. For example: (summary :str)") (write-line "Special commands:") (maphash (lambda (k v) (format t " %~a => ~a~%" k (documentation (cdr v) t))) *special*) ;; (write-line "Currently defined:") ;; (print-currently-defined) (write-line "Press CTRL-D or type %q to exit")) (defun symbol-documentation (symbol) "Print the available documentation for this symbol." ;; Normally, the documentation function takes as second argument the ;; type designator. We loop over each type and print the available ;; documentation. (handler-case (loop for doc-type in '(variable function structure type setf) with sym = (if (stringp symbol) ;; used from the readline REPL (read-from-string symbol) ;; used from Slime symbol) for doc = (unless (consp sym) ;; when a function is quoted: :doc 'defun ;; instead of :doc defun (documentation sym doc-type)) when doc do (format t "~a: ~a~&" doc-type doc) when (and (equal doc-type 'function) (fboundp sym)) do (format t "ARGLIST: ~a~&" (format nil "~(~a~)" (trivial-arguments:arglist sym)))) (error (c) (format *error-output* "Error during documentation lookup: ~a~&" c)))) (defun print-currently-defined () (do-all-symbols (s *package*) (when (and (or (fboundp s) (boundp s)) (eql (symbol-package s) *package*)) (let ((what (cond ((fboundp s) 'function) ((constantp s) 'constant) (t 'variable)))) (format t " ~a: ~a (~a) ~a~%" (string-downcase (string s)) (or (documentation s what) "No documentation") what (if (boundp s) (format nil "(value ~a)" (eval s)) "")))))) (defun dump-disasm (sym) "Dumps the disassembly of a symbol " (handler-case (disassemble (read-from-string sym)) (unbound-variable (var) (format t "~a~%" var)) (type-error (err) (format t "~a~%" err)) (sb-int:compiled-program-error (err) (format t "~a~%" err)) (undefined-function (fun) (format t "~a~%" fun)))) (defun dump-type (expr) "Prints the type of a expression " (handler-case (format t "~a~%" (type-of (eval (read-from-string expr)))) (unbound-variable (var) (format t "~a~%" var)) (type-error (err) (format t "~a~%" err)) (sb-int:compiled-program-error (err) (format t "~a~%" err)) (undefined-function (fun) (format t "~a~%" fun)))) (defun edit-and-load-file (file) "Edit a file with EDITOR and evaluate it." (magic-ed file)) (defun toggle-lisp-critic () "Enable or disable the lisp critic. He critizes the code you type before compiling it." (setf *lisp-critic* (not *lisp-critic*)) (format t "The lisp-critic is ~a.~&" (if *lisp-critic* "enabled" "disabled"))) ;; -1 means take the string as one arg (defvar *special* (alexandria:alist-hash-table `( ;; ("help" . (0 . ,#'general-help)) ("help" . (0 . ,#'help)) ("doc" . (1 . ,#'symbol-documentation)) ("?" . (1 . ,#'what)) ;; ("r" . (1 . ,#'readme)) ;; ("s" . (1 . ,#'summary)) ("w" . (1 . ,#'write-to-file)) ("d" . (1 . ,#'dump-disasm)) ("t" . (-1 . ,#'dump-type)) ("q" . (0 . ,#'end)) ;; ("z" . (0 . ,#'reset)) ("lisp-critic" . (0 . ,#'toggle-lisp-critic)) ("edit" . (1 . ,#'edit-and-load-file)) ) :test 'equal) "All special commands starting with :") (defun special-command-p (text) "A *special* command starts with %." (str:starts-with-p "%" text)) ;; both functions are required to get completion on % (defun list-special-commands () (loop for k being the hash-key of *special* collect (format nil "%~a" k))) (defun intern-special-commands () (loop for k being the hash-key of *special* for symname = (format nil "%~a" k) do (intern symname :sbcli))) (intern-special-commands) (defun call-special (fundef call args) (let ((l (car fundef)) (fun (cdr fundef)) (rl (length args))) (cond ((= -1 l) (funcall fun (str:join " " args))) ((< rl l) (format *error-output* "Expected ~a arguments to ~a, but got ~a!~%" l call rl)) (t (apply fun (subseq args 0 l)))))) (defun handle-special-input (text) (let* ((words (str:words text)) (k (subseq (car words) 1 (length (car words)))) (v (gethash k *special*))) (if v (call-special v (car words) (cdr words)) (format *error-output* "Unknown special command: ~a~%" k)))) (defun evaluate-lisp (text parsed) "Evaluate (EVAL) the user input. In case of evaluation error, print it. Then print the result. Print its multiple values. Save the input history. Handle the special *, + et all REPL history variables." (let ((result-list (multiple-value-list (handler-case (eval parsed) (unbound-variable (var) (format *error-output* "~a~%" var)) (undefined-function (fun) (format *error-output* "~a~%" fun)) (sb-int:compiled-program-error () (format *error-output* "~a" (cl-ansi-text:red "Compiler error.~%"))) (error (condition) (format *error-output* "~a~a~%" (cl-ansi-text:red "Evaluation error: ") condition)))))) (history-add text (car result-list)) (when result-list (setf +++ ++ /// // *** (car ///) ++ + // / ** (car //) + parsed / result-list * (car result-list)) ;; Print the result, and all multple values. They are printed like so: ;; (not the best with =>) ;; ciel-user> (values 1 2 3) ;; => 1 ;; 2 ;; 3 (format t "~a~{~s~&~}~%" *result-indicator* result-list)))) #+(or nil) (let* ((input "(values :one :two)") (result (with-output-to-string (*standard-output*) (evaluate-lisp "whatever" (read-from-string input))))) (assert (and (str:containsp ":one" result :ignore-case t) (str:containsp ":two" result :ignore-case t))) (assert (equal '(:ONE :TWO) /))) (defun lisp-critic-applicable (txt) "TXT is code that should start with a parenthesis. Don't critique global variables." (str:starts-with? "(" (str:trim txt))) (defun handle-lisp (before text) (let* ((new-txt (format nil "~a ~a" before text)) (parsed (handler-case (read-from-string new-txt) (end-of-file () (sbcli new-txt *prompt2*)) (error (condition) (format *error-output* "Parser error: ~a~%" condition)))) (to-critic (when (and *lisp-critic* (lisp-critic-applicable new-txt) parsed) `(lisp-critic:critique ,parsed)))) (when to-critic ;; The call to lisp-critic doesn't evaluate the lisp code, ;; it only scans it and prints feedback. (evaluate-lisp text to-critic)) ;; But even if the lisp-critic is enabled, ;; we want the code we type to be eval'ed. (when parsed (evaluate-lisp text parsed)))) (defun handle-input (before text) (if (and (> (length text) 1) (special-command-p text)) (handle-special-input text) (handle-lisp before text))) (defun get-package-for-search (text) "Return a list with: - the text after the colon or double colon - the package name - T if we look for an external symbol, NIL for an internal one." (let ((pos)) (cond ((setf pos (search "::" text)) (list (subseq text (+ pos 2)) (subseq text 0 pos) nil)) ((setf pos (position #\: text)) (if (zerop pos) (list text nil t) (list (subseq text (1+ pos)) (subseq text 0 pos) t))) (t (list text nil t))))) (defun list-external-symbols (sym-name pkg-name) "List external symbols of PKG-NAME (a string). (the symbol name is currently ignored)." (declare (ignorable sym-name)) (assert (stringp pkg-name)) (loop :for sym :being :the :external-symbols :of (find-package pkg-name) :collect (format nil "~(~a:~a~)" pkg-name sym))) (defun list-internal-symbols (sym-name pkg-name) "List internal symbols of the package named PKG-NAME (a string)." (declare (ignorable sym-name)) (assert (stringp pkg-name)) (loop :for sym :being :the :symbols :of (find-package pkg-name) :collect (format nil "~(~a::~a~)" pkg-name sym))) (defun list-local-nicknames (&optional (package *package*)) "Return a list of local nicknames. (downcased strings, with a trailing colon to denote a package)" (loop :for pair in (package-local-nicknames package) :collect (format nil "~a:" (str:downcase (car pair))))) (defun list-symbols-and-packages (sym-name) "Base case, when the user entered a string with no colon that would delimit a package. Return the current packages, symbols of the current package, current keywords. They are filtered afterwards, in SELECT-COMPLETIONS." (declare (ignorable sym-name)) (concatenate 'list (list-special-commands) (loop :for pkg :in (list-all-packages) :append (loop :for name :in (package-nicknames pkg) :collect (format nil "~(~a:~)" name)) :collect (format nil "~(~a:~)" (package-name pkg))) (list-local-nicknames *package*) (loop :for sym :being :the :symbols :of *package* :collect (string-downcase sym)) (loop :for kw :being :the :symbols :of (find-package "KEYWORD") :collect (format nil ":~(~a~)" kw)))) (defun select-completions (text items) "TEXT is the string entered at the prompt, ITEMS is a list of strings to match candidates against (for example in the form \"package:sym\")." (setf items (loop :for item :in items :when (str:starts-with-p text item) :collect item)) (unless (cdr items) (setf rl:*completion-append-character* (if (str:ends-with-p ":" (car items)) #\nul #\space)) (return-from select-completions items)) (cons (subseq (car items) 0 (loop :for item :in (cdr items) :minimize (or (mismatch (car items) item) (length item)))) items)) #+(or) (progn (assert (member "str:concat" (select-completions "str:con" (list "str:containsp" "str:concat" "str:constant-case")) :test #'string-equal))) (defun shell-passthrough-p (arg) "Return t if arg (string) starts with \"!\". This is used to offer custom TAB completion, not to launch shell commands. The Clesh readtable is responsible of that." (str:starts-with-p "!" arg)) (defun complete-filename-p (text start end &key (line-buffer rl:*line-buffer*)) "Return T if we should feed the tab completion candidates filenames, instead of the regular Lisp symbols. We answer yes when we are tab-completing a secord word on the prompt and a quote comes before it. TEXT, START and END: see `custom-complete'. Ex: !ls \"test TAB => yes return files instead of lisp symbols for completion. !\"tes TAB => well, no. (load \"test TAB => yes (load (test TAB => no " (declare (ignore end)) (and (not (shell-passthrough-p text)) (> start 1) ;; 1 is an opening parenthesis. (char-equal #\" (elt line-buffer (1- start))) ;; after an opening quote. )) #+test-ciel (progn (assert (complete-filename-p "test" 7 10 :line-buffer "(load \"test")) (assert (complete-filename-p "test" 7 10 :line-buffer "(!foo \"test")) (assert (not (complete-filename-p "test" 1 5 :line-buffer "\"test"))) ) (defun filter-candidates (text file-candidates) "Return a list of files (strings) in the current directory that start with TEXT." ;; yeah, this calls for more features. Hold on a minute will you. (remove-if #'null (mapcar (lambda (path) (let ((namestring (file-namestring path))) (when (str:starts-with-p text namestring) namestring))) file-candidates))) (defun complete-binaries-from-path-p (text start end &key (line-buffer rl:*line-buffer*)) "Return T if we should TAB-complete shell executables, and search them on the PATH. START must be 0: we are writing the first word on the readline prompt, TEXT must start with ! the mark of the shell pass-through." (declare (ignore end line-buffer)) (and (zerop start) (str:starts-with-p "!" text))) (defun find-binaries-candidates (text) "Find binaries starting with TEXT in PATH. Return: a list of strings." (loop with s = (string-left-trim "!" text) for dir in (uiop:getenv-absolute-directories "PATH") for res = (filter-candidates s (uiop:directory-files dir)) collect res into candidates finally (return ;; we got "!text", we have to return candidates ;; with the "!" prefix, so that readline agrees they are completions. (mapcar (lambda (bin) (str:concat "!" bin)) (alexandria:flatten candidates))))) (defun custom-complete (text &optional start end) "Custom completer function for readline, triggered when we press TAB. Complete filenames on the current directory when appropriate (after a quote). TEXT is the current word being type. Not the full command line. START is the start of this word. If we type the first word of the command and TAB-complete it, then START equals 0. For a second word, START != 0. Ex: !ls te TAB TEXT is \"te\", START is 4 and END is 6. That way we give other completion candidates depending on START." (when (string-equal text "") (return-from custom-complete nil)) (destructuring-bind (sym-name pkg-name external-p) (get-package-for-search (string-upcase text)) (when (and pkg-name (not (find-package pkg-name))) (return-from custom-complete nil)) (select-completions (str:downcase text) (cond ((complete-binaries-from-path-p text start end :line-buffer rl:*line-buffer*) (find-binaries-candidates text)) ((complete-filename-p text start end :line-buffer rl:*line-buffer*) ;; complete file names on the current directory. ;; Yes we could complete both: lisp symbols AND files. See with usage. (filter-candidates text (uiop:directory-files "."))) ((zerop (length pkg-name)) (list-symbols-and-packages sym-name)) (external-p (list-external-symbols sym-name pkg-name)) (t (list-internal-symbols sym-name pkg-name)))))) #+(or) (progn (assert (member "str:suffixp" (custom-complete "str:suff") :test #'string-equal)) (assert (member "uiop:file-exists-p" (custom-complete "uiop:file-") :test #'string-equal))) (defun format-prompt (text &key (colored t)) (let ((prompt (str:concat text "> "))) (format nil "~a" (if colored (cl-ansi-text:green prompt) prompt)))) (defun sbcli (txt prompt) "Read user input and evaluate it. This function must be called from inside the CIEL-USER package." (let* ((prompt-text (if (functionp prompt) (funcall prompt) prompt)) (cur-pkg-name (package-name *package*)) (text (handler-case (rl:readline :prompt (if (string-equal "CIEL-USER" cur-pkg-name) prompt-text (sbcli::format-prompt cur-pkg-name)) :add-history t :novelty-check #'sbcli::novelty-check) ;; Catch a C-c. (#+sbcl sb-sys:interactive-interrupt #+ccl ccl:interrupt-signal-condition #+clisp system::simple-interrupt-condition #+ecl ext:interactive-interrupt #+allegro excl:interrupt-signal () (write-char #\linefeed) "")))) (unless text (sbcli::end)) (if (string= text "") (sbcli::sbcli "" *prompt*)) (when *hist-file* (sbcli::update-hist-file text)) (cond ;; Handle documentation lookup. ((str:ends-with-p " ?" text) (sbcli::symbol-documentation (last-nested-expr text))) ;; Interactive and visual shell command? ;; They are now handled by Clesh. ;; When on a non "dumb" terminal, all shell commands are run interactively. ;; No need to check for a "!" in the input here, ;; it's done with the clesh readtable when handling lisp. ;; Default: run the lisp command (with the lisp-critic, the shell passthrough ;; and other add-ons). (t (sbcli::handle-input txt text))) (finish-output nil) (format t "~&") (sbcli::sbcli "" *prompt*))) (defun edit-current-input (arg key) ;; experimental, doesn't properly work. (declare (ignore arg key)) (let ((filename "/tmp/ciel-temp.lisp") (current-input rl:*line-buffer*)) (str:to-file filename current-input) (magic-ed filename) ;; ... user writes... ;; (NB: rl:replace-line preserves the point position and that's annoying) ;; (setf rl:*line-buffer* (str:trim (str:from-file filename))) ;; (rl:redisplay) ;; (rl:delete-text 0 rl:+end+) (uiop:format! t "text is: ~a~&" (str:from-file filename)) ;; (rl:insert-text (str:concat "hello" (str:trim (str:from-file filename)))) (setf rl:*line-buffer* (str:trim (str:from-file filename))) (rl:redisplay) )) (defun repl (&key noinform no-usernit) "Toplevel REPL. CLI options: - -h, --help - --noinform: don't print the welcome banner. - --no-userinit: don't load the user's cielrc init file. " (let ((argv (uiop:command-line-arguments))) (when (or (member "-h" argv :test #'string-equal) (member "--help" argv :test #'string-equal)) (format t "~a version ~a~%" *repl-name* *repl-version*) (format t "Contribute on: https://github.com/ciel-lang/CIEL~&") (print-system-info) (format t "CIEL Is an Extended Lisp. It's Common Lisp, batteries included.~&~ It comes in the form of a Quicklisp library that you can use as any other one in your favourite editor, ~ as an SBCL core image and as a readline REPL, with developer goodies.~&") (uiop:quit))) (rl:register-function :complete #'custom-complete) (rl:register-function :redisplay #'syntax-hl) ;; testing… (defun print-some-text (arg key) (declare (ignore arg key)) (rl:insert-text "inserted text")) #+(or) (rl:bind-keyseq "\\C-o" #'print-some-text) (rl:bind-keyseq "\\C-x\\C-e" #'edit-current-input) (rl:set-paren-blink-timeout 500) ;; Print a banner and system info. ;; Checking a CLI arg this way is an old, done before our use of Clingon. (unless (or noinform (member "--noinform" (uiop:command-line-arguments) :test #'string-equal)) (princ *banner*) (write-line (str:repeat 80 "-")) (print-system-info) (write-line (str:repeat 80 "-")) (help) (write-char #\linefeed) (finish-output nil)) ;; Load CIEL's user init file. (unless (or no-usernit (member "--no-userinit" (uiop:command-line-arguments) :test #'string-equal)) (when (uiop:file-exists-p *init-file*) (load-init-file))) (when *hist-file* (read-hist-file)) (in-package :ciel-user) ;; Enable Clesh, only for the readline REPL, ;; part because we don't want to clutter the ciel-user package, ;; part because Clesh is buggy for us on Slime (!! and [...]). ;; We get the ! pass-through shell: ;; !ls ;; as well as [ ... ] on multilines. ;; Beware: the double bang !! doesn't work. See issues. (named-readtables:in-readtable clesh:syntax) (handler-case (sbcli::sbcli "" sbcli::*prompt*) (error (c) ;; Normally lisp code is evaled and protected from errors in evaluate-lisp. ;; We need this for magic-ed. ;; As a special command it doesn't use evaluate-lisp. (format *error-output* "~&Error: ~a~&" c) (sbcli::sbcli "" sbcli::*prompt*)) (sb-sys:interactive-interrupt () (sbcli::end)))) ;; When trying it out with --script: ;; (repl)