From 81e7cbbade4fd01e092a2c39a3af90e4abf7f684 Mon Sep 17 00:00:00 2001 From: Arne Babenhauserheide Date: Mon, 11 Mar 2024 06:34:52 +0100 Subject: [PATCH] Add language/wisp, Wisp tests, and SRFI-119 documentation * doc/ref/srfi-modules.texi (srfi-119): add node * module/language/wisp.scm: New file. * module/language/wisp/spec.scm: New file. * test-suite/tests/srfi-119.test: New file. --- am/bootstrap.am | 3 + doc/ref/srfi-modules.texi | 31 + module/language/wisp.scm | 776 ++++++++++++++++++++++++ module/language/wisp/spec.scm | 70 +++ test-suite/Makefile.am | 3 +- test-suite/tests/srfi-119.test | 1040 ++++++++++++++++++++++++++++++++ 6 files changed, 1922 insertions(+), 1 deletion(-) create mode 100644 module/language/wisp.scm create mode 100644 module/language/wisp/spec.scm create mode 100644 test-suite/tests/srfi-119.test diff --git a/am/bootstrap.am b/am/bootstrap.am index a71946958..7c4b5d8a8 100644 --- a/am/bootstrap.am +++ b/am/bootstrap.am @@ -395,6 +395,9 @@ SOURCES = \ \ system/syntax.scm \ \ + language/wisp.scm \ + language/wisp/spec.scm \ + \ system/xref.scm \ \ sxml/apply-templates.scm \ diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index 09b591e89..329e74958 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -64,6 +64,7 @@ get the relevant SRFI documents from the SRFI home page * SRFI-98:: Accessing environment variables. * SRFI-105:: Curly-infix expressions. * SRFI-111:: Boxes. +* SRFI-119:: Wisp: simpler indentation-sensitive Scheme. * SRFI-171:: Transducers @end menu @@ -5662,6 +5663,35 @@ Return the current contents of @var{box}. Set the contents of @var{box} to @var{value}. @end deffn +@node SRFI-119 +@subsection SRFI-119 Wisp: simpler indentation-sensitive Scheme. +@cindex SRFI-119 +@cindex wisp + +The languages shipped in Guile include SRFI-119, also referred to as +@dfn{Wisp} (for ``Whitespace to Lisp''), an encoding of Scheme that +allows replacing parentheses with equivalent indentation and inline +colons. See +@uref{http://srfi.schemers.org/srfi-119/srfi-119.html, the specification +of SRFI-119}. Some examples: + +@example +display "Hello World!" @result{} (display "Hello World!") +@end example + +@example +define : factorial n @result{} (define (factorial n) + if : zero? n @result{} (if (zero? n) + . 1 @result{} 1 + * n : factorial @{n - 1@} @result{} (* n (factorial @{n - 1@})))) +@end example + +To execute a file with Wisp code, select the language and filename +extension @code{.w} vie @code{guile --language=wisp -x .w}. + +In files using Wisp, @xref{SRFI-105} (Curly Infix) is always activated. + + @node SRFI-171 @subsection Transducers @cindex SRFI-171 @@ -5705,6 +5735,7 @@ left-to-right, due to how transducers are initiated. * SRFI-171 Helpers:: Utilities for writing your own transducers @end menu + @node SRFI-171 General Discussion @subsubsection SRFI-171 General Discussion @cindex transducers discussion diff --git a/module/language/wisp.scm b/module/language/wisp.scm new file mode 100644 index 000000000..dae9642ae --- /dev/null +++ b/module/language/wisp.scm @@ -0,0 +1,776 @@ +;;; Wisp + +;; Copyright (C) 2013, 2017, 2018, 2020 Free Software Foundation, Inc. +;; Copyright (C) 2014--2023 Arne Babenhauserheide. +;; Copyright (C) 2023 Maxime Devos + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: + +;; Scheme-only implementation of a wisp-preprocessor which output a +;; Scheme code tree to feed to a Scheme interpreter instead of a +;; preprocessed file. + +;; Limitations: +;; - in some cases the source line information is missing in backtraces. +;; check for set-source-property! + +;;; Code: + +(define-module (language wisp) + #:export (wisp-scheme-read-chunk wisp-scheme-read-all + wisp-scheme-read-file-chunk wisp-scheme-read-file + wisp-scheme-read-string) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11); for let-values + #:use-module (srfi srfi-9); for records + #:use-module (ice-9 rw); for write-string/partial + #:use-module (ice-9 match)) + +;; use curly-infix by default +(eval-when (expand load eval) + (read-enable 'curly-infix)) + + +;; Helpers to preserver source properties + +(define (wisp-add-source-properties-from source target) + "Copy the source properties from source into the target and return the target." + (catch #t + (lambda () + (set-source-properties! target (source-properties source))) + (lambda (key . arguments) + #f)) + target) + +(define (wisp-add-source-properties-from/when-required source target) + "Copy the source properties if target has none." + (if (null? (source-properties target)) + (wisp-add-source-properties-from source target) + target)) + + +;; Helper functions for the indent-and-symbols data structure: '((indent token token ...) ...) +(define make-line list) + +(define (line-indent line) + (car line)) + +(define (line-real-indent line) + "Get the indentation without the comment-marker for unindented lines (-1 is treated as 0)." + (let ((indent (line-indent line))) + (if (= -1 indent) + 0 + indent))) + +(define (line-code line) + "Strip the indentation markers from the beginning of the line and preserve source-properties" + (let ((code (cdr line))) + ;; propagate source properties + (when (not (null? code)) + (wisp-add-source-properties-from/when-required line code)) + code)) + +;; literal values I need +(define readcolon + (string->symbol ":")) + +(define wisp-uuid "e749c73d-c826-47e2-a798-c16c13cb89dd") +;; define an intermediate dot replacement with UUID to avoid clashes. +(define repr-dot ; . + (string->symbol (string-append "REPR-DOT-" wisp-uuid))) + +;; allow using reader additions as the first element on a line to prefix the list +(define repr-quote ; ' + (string->symbol (string-append "REPR-QUOTE-" wisp-uuid))) +(define repr-unquote ; , + (string->symbol (string-append "REPR-UNQUOTE-" wisp-uuid))) +(define repr-quasiquote ; ` + (string->symbol (string-append "REPR-QUASIQUOTE-" wisp-uuid))) +(define repr-unquote-splicing ; ,@ + (string->symbol (string-append "REPR-UNQUOTESPLICING-" wisp-uuid))) + +(define repr-syntax ; #' + (string->symbol (string-append "REPR-SYNTAX-" wisp-uuid))) +(define repr-unsyntax ; #, + (string->symbol (string-append "REPR-UNSYNTAX-" wisp-uuid))) +(define repr-quasisyntax ; #` + (string->symbol (string-append "REPR-QUASISYNTAX-" wisp-uuid))) +(define repr-unsyntax-splicing ; #,@ + (string->symbol (string-append "REPR-UNSYNTAXSPLICING-" wisp-uuid))) + +;; TODO: wrap the reader to return the repr of the syntax reader +;; additions + +(define (equal-rest? chars . args) + (equal? chars args)) + +(define (match-charlist-to-repr char-list) + (let ((chars (reverse char-list))) + (cond + ((equal-rest? chars #\.) repr-dot) + ((equal-rest? chars #\') repr-quote) + ((equal-rest? chars #\,) repr-unquote) + ((equal-rest? chars #\`) repr-quasiquote) + ((equal-rest? chars #\, #\@) repr-unquote-splicing) + ((equal-rest? chars #\# #\') repr-syntax) + ((equal-rest? chars #\# #\,) repr-unsyntax) + ((equal-rest? chars #\# #\`) repr-quasisyntax) + ((equal-rest? chars #\# #\, #\@) repr-unsyntax-splicing) + (else #f)))) + +(define (wisp-read port) + "Wrap read to catch list prefixes: read one or several chars from PORT and return read symbols or replacement-symbols as representation for special forms." + (let ((prefix-maxlen 4)) + (let longpeek ((peeked '()) (repr-symbol #f)) + (cond + ((or (< prefix-maxlen (length peeked)) + (eof-object? (peek-char port)) + (equal? #\space (peek-char port)) + (equal? #\newline (peek-char port))) + (if repr-symbol ; found a special symbol, return it. + repr-symbol + (let unpeek ((remaining peeked)) + (cond + ((equal? '() remaining) + (read port)); let read to the work + (else + (unread-char (car remaining) port) + (unpeek (cdr remaining))))))) + (else + (let* ((next-char (read-char port)) + (peeked (cons next-char peeked))) + (longpeek + peeked + (match-charlist-to-repr peeked)))))))) + + + +(define (line-continues? line) + (equal? repr-dot (car (line-code line)))) + +(define (line-only-colon? line) + (and + (equal? ":" (car (line-code line))) + (null? (cdr (line-code line))))) + +(define (line-empty-code? line) + (null? (line-code line))) + +(define (line-empty? line) + (and + ;; if indent is -1, we stripped a comment, so the line was not really empty. + (= 0 (line-indent line)) + (line-empty-code? line))) + +(define (line-strip-continuation line) + (if (line-continues? line) + (apply make-line + (line-indent line) + (cdr (line-code line))) + line)) + +(define (line-strip-indentation-marker line) + "Strip the indentation markers from the beginning of the line for line-finalize without propagating source-properties (those are propagated in a second step)" + (cdr line)) + +(define (indent-level-reduction indentation-levels level select-fun) + "Reduce the INDENTATION-LEVELS to the given LEVEL and return the value selected by SELECT-FUN" + (let loop ((newlevels indentation-levels) + (diff 0)) + (cond + ((= level (car newlevels)) + (select-fun (list diff indentation-levels))) + ((< level (car newlevels)) + (loop + (cdr newlevels) + (1+ diff))) + (else + (raise-exception (make-exception-from-throw 'wisp-syntax-error (list (format #f "Level ~A not found in the indentation-levels ~A." level indentation-levels)))))))) + +(define (indent-level-difference indentation-levels level) + "Find how many indentation levels need to be popped off to find the given level." + (indent-level-reduction indentation-levels level + (lambda (x); get the count + (car x)))) + +(define (indent-reduce-to-level indentation-levels level) + "Find how many indentation levels need to be popped off to find the given level." + (indent-level-reduction indentation-levels level + (lambda (x); get the levels + (car (cdr x))))) + +(define (chunk-ends-with-period currentsymbols next-char) + "Check whether indent-and-symbols ends with a period, indicating the end of a chunk." + (and (not (null? currentsymbols)) + (equal? #\newline next-char) + (equal? repr-dot + (list-ref currentsymbols (- (length currentsymbols) 1))))) + + +(define (wisp-scheme-read-chunk-lines port) + ;; the line number for this chunk is the line number when starting to read it + ;; a top-level form stops processing, so we only need to retrieve this here. + (define line-number (port-line port)) + (let loop ((indent-and-symbols (list)); '((5 "(foobar)" "\"yobble\"")(3 "#t")) + (in-indent? #t) + (in-underscoreindent? (equal? #\_ (peek-char port))) + (in-comment? #f) + (currentindent 0) + (currentsymbols '()) + (emptylines 0)) + (cond + ((>= emptylines 2) + ;; the chunk end has to be checked + ;; before we look for new chars in the + ;; port to make execution in the REPL + ;; after two empty lines work + ;; (otherwise it shows one more line). + indent-and-symbols) + (else + (let ((next-char (peek-char port))) + (cond + ((eof-object? next-char) + (let ((line (apply make-line currentindent currentsymbols))) + (set-source-property! line 'filename (port-filename port)) + (set-source-property! line 'line line-number) + (append indent-and-symbols (list line)))) + ((and in-indent? + (zero? currentindent) + (not in-comment?) + (not (null? indent-and-symbols)) + (not in-underscoreindent?) + (not (or (equal? #\space next-char) + (equal? #\newline next-char) + (equal? (string-ref ";" 0) next-char)))) + (append indent-and-symbols)); top-level form ends chunk + ((chunk-ends-with-period currentsymbols next-char) + ;; the line ends with a period. This is forbidden in + ;; SRFI-119. Use it to end the line in the REPL without + ;; showing continuation dots (...). + (append indent-and-symbols (list (apply make-line currentindent (drop-right currentsymbols 1))))) + ((and in-indent? (equal? #\space next-char)) + (read-char port); remove char + (loop + indent-and-symbols + #t ; in-indent? + #f ; in-underscoreindent? + #f ; in-comment? + (1+ currentindent) + currentsymbols + emptylines)) + ((and in-underscoreindent? (equal? #\_ next-char)) + (read-char port); remove char + (loop + indent-and-symbols + #t ; in-indent? + #t ; in-underscoreindent? + #f ; in-comment? + (1+ currentindent) + currentsymbols + emptylines)) + ;; any char but whitespace *after* underscoreindent is + ;; an error. This is stricter than the current wisp + ;; syntax definition. + ;; TODO: Fix the definition. Better start too strict. + ;; FIXME: breaks on lines with only underscores which should be + ;; empty lines. + ((and in-underscoreindent? (and (not (equal? #\space next-char)) (not (equal? #\newline next-char)))) + (raise-exception (make-exception-from-throw 'wisp-syntax-error (list "initial underscores without following whitespace at beginning of the line after" (last indent-and-symbols))))) + ((equal? #\newline next-char) + (read-char port); remove the newline + (let* + ;; distinguish pure whitespace lines and lines + ;; with comment by giving the former zero + ;; indent. Lines with a comment at zero indent + ;; get indent -1 for the same reason - meaning + ;; not actually empty. + ((indent + (cond + (in-comment? + (if (= 0 currentindent); specialcase + -1 + currentindent)) + ((not (null? currentsymbols)); pure whitespace + currentindent) + (else + 0))) + (parsedline (apply make-line indent currentsymbols)) + (emptylines + (if (not (line-empty? parsedline)) + 0 + (1+ emptylines)))) + (when (not (= 0 (length (line-code parsedline)))) + ;; set the source properties to parsedline so we can try to add them later. + (set-source-property! parsedline 'filename (port-filename port)) + (set-source-property! parsedline 'line line-number)) + ;; TODO: If the line is empty. Either do it here and do not add it, just + ;; increment the empty line counter, or strip it later. Replace indent + ;; -1 by indent 0 afterwards. + (loop + (append indent-and-symbols (list parsedline)) + #t ; in-indent? + (if (<= 2 emptylines) + #f ; chunk ends here + (equal? #\_ (peek-char port))); are we in underscore indent? + #f ; in-comment? + 0 + '() + emptylines))) + ((equal? #t in-comment?) + (read-char port); remove one comment character + (loop + indent-and-symbols + #f ; in-indent? + #f ; in-underscoreindent? + #t ; in-comment? + currentindent + currentsymbols + emptylines)) + ((or (equal? #\space next-char) (equal? #\tab next-char) (equal? #\return next-char)); remove whitespace when not in indent + (read-char port); remove char + (loop + indent-and-symbols + #f ; in-indent? + #f ; in-underscoreindent? + #f ; in-comment? + currentindent + currentsymbols + emptylines)) + ;; | cludge to appease the former wisp parser + ;; | used for bootstrapping which has a + ;; v problem with the literal comment char + ((equal? (string-ref ";" 0) next-char) + (loop + indent-and-symbols + #f ; in-indent? + #f ; in-underscoreindent? + #t ; in-comment? + currentindent + currentsymbols + emptylines)) + (else ; use the reader + (loop + indent-and-symbols + #f ; in-indent? + #f ; in-underscoreindent? + #f ; in-comment? + currentindent + ;; this also takes care of the hashbang and leading comments. + (append currentsymbols (list (wisp-read port))) + emptylines)))))))) + + +(define (line-code-replace-inline-colons line) + "Replace inline colons by opening parens which close at the end of the line" + ;; format #t "replace inline colons for line ~A\n" line + (let loop ((processed '()) + (unprocessed line)) + (cond + ((null? unprocessed) + ;; format #t "inline-colons processed line: ~A\n" processed + processed) + ;; replace : . with nothing + ((and (<= 2 (length unprocessed)) (equal? readcolon (car unprocessed)) (equal? repr-dot (car (cdr unprocessed)))) + (loop + (append processed + (loop '() (cdr (cdr unprocessed)))) + '())) + ((equal? readcolon (car unprocessed)) + (loop + (append processed + (list (loop '() (cdr unprocessed)))) + '())) + (else + (loop + (append processed + (list (car unprocessed))) + (cdr unprocessed)))))) + +(define (line-replace-inline-colons line) + (cons + (line-indent line) + (line-code-replace-inline-colons (line-code line)))) + +(define (line-strip-lone-colon line) + "A line consisting only of a colon is just a marked indentation level. We need to kill the colon before replacing inline colons." + (if (equal? (line-code line) (list readcolon)) + (make-line (line-indent line)) + line)) + +(define (line-finalize line) + "Process all wisp-specific information in a line and strip it" + (let ((l (line-code-replace-inline-colons + (line-strip-indentation-marker + (line-strip-lone-colon + (line-strip-continuation line)))))) + (when (not (null? (source-properties line))) + (catch #t + (lambda () + (set-source-properties! l (source-properties line))) + (lambda (key . arguments) + #f))) + l)) + +(define (wisp-propagate-source-properties code) + "Propagate the source properties from the sourrounding list into every part of the code." + (let loop ((processed '()) + (unprocessed code)) + (cond + ((and (null? processed) (not (pair? unprocessed)) (not (list? unprocessed))) + unprocessed) + ((and (pair? unprocessed) (not (list? unprocessed))) + (cons + (wisp-propagate-source-properties (car unprocessed)) + (wisp-propagate-source-properties (cdr unprocessed)))) + ((null? unprocessed) + processed) + (else + (let ((line (car unprocessed))) + (wisp-add-source-properties-from/when-required line unprocessed) + (wisp-add-source-properties-from/when-required code unprocessed) + (wisp-add-source-properties-from/when-required unprocessed line) + (wisp-add-source-properties-from/when-required unprocessed code) + (let ((processed (append processed (list (wisp-propagate-source-properties line))))) + ;; must propagate from line, because unprocessed and code can be null, then they cannot keep source-properties. + (wisp-add-source-properties-from/when-required line processed) + (loop processed + (cdr unprocessed)))))))) + +(define* (wisp-scheme-indentation-to-parens lines) + "Add parentheses to lines and remove the indentation markers" + (when + (and + (not (null? lines)) + (not (line-empty-code? (car lines))) + (not (= 0 (line-real-indent (car lines))))); -1 is a line with a comment + (if (= 1 (line-real-indent (car lines))) + ;; accept a single space as indentation of the first line (and ignore the indentation) to support meta commands + (set! lines + (cons + (cons 0 (cdr (car lines))) + (cdr lines))) + (raise-exception + (make-exception-from-throw + 'wisp-syntax-error + (list + (format #f "The first symbol in a chunk must start at zero indentation. Indentation and line: ~A" + (car lines))))))) + (let loop ((processed '()) + (unprocessed lines) + (indentation-levels '(0))) + (let* ((current-line + (if (<= 1 (length unprocessed)) + (car unprocessed) + (make-line 0))); empty code + (next-line + (if (<= 2 (length unprocessed)) + (car (cdr unprocessed)) + (make-line 0))); empty code + (current-indentation + (car indentation-levels)) + (current-line-indentation (line-real-indent current-line))) + ;; format #t "processed: ~A\ncurrent-line: ~A\nnext-line: ~A\nunprocessed: ~A\nindentation-levels: ~A\ncurrent-indentation: ~A\n\n" + ;; . processed current-line next-line unprocessed indentation-levels current-indentation + (cond + ;; the real end: this is reported to the outside world. + ((and (null? unprocessed) (not (null? indentation-levels)) (null? (cdr indentation-levels))) + ;; reverse the processed lines, because I use cons. + processed) + ;; the recursion end-condition + ((and (null? unprocessed)) + ;; this is the last step. Nothing more to do except + ;; for rolling up the indentation levels. return the + ;; new processed and unprocessed lists: this is a + ;; side-recursion + (values processed unprocessed)) + ((null? indentation-levels) + (raise-exception + (make-exception-from-throw + 'wisp-programming-error + (list + "The indentation-levels are null but the current-line is null: Something killed the indentation-levels.")))) + (else ; now we come to the line-comparisons and indentation-counting. + (cond + ((line-empty-code? current-line) + ;; We cannot process indentation without + ;; code. Just switch to the next line. This should + ;; only happen at the start of the recursion. + (loop + processed + (cdr unprocessed) + indentation-levels)) + ((and (line-empty-code? next-line) (<= 2 (length unprocessed))) + ;; take out the next-line from unprocessed. + (loop + processed + (cons current-line + (cdr (cdr unprocessed))) + indentation-levels)) + ((> current-indentation current-line-indentation) + ;; this just steps back one level via the side-recursion. + (let ((previous-indentation (car (cdr indentation-levels)))) + (if (<= current-line-indentation previous-indentation) + (values processed unprocessed) + (begin ;; not yet used level! TODO: maybe throw an error here instead of a warning. + (let ((linenumber (- (length lines) (length unprocessed)))) + (format (current-error-port) ";;; WARNING:~A: used lower but undefined indentation level (line ~A of the current chunk: ~S). This makes refactoring much more error-prone, therefore it might become an error in a later version of Wisp.\n" (source-property current-line 'line) linenumber (cdr current-line))) + (loop + processed + unprocessed + (cons ; recursion via the indentation-levels + current-line-indentation + (cdr indentation-levels))))))) + ((= current-indentation current-line-indentation) + (let ((line (line-finalize current-line)) + (next-line-indentation (line-real-indent next-line))) + (cond + ((>= current-line-indentation next-line-indentation) + ;; simple recursiive step to the next line + (loop + (append processed + (if (line-continues? current-line) + line + (wisp-add-source-properties-from line (list line)))) + (cdr unprocessed); recursion here + indentation-levels)) + ((< current-line-indentation next-line-indentation) + ;; side-recursion via a sublist + (let-values + (((sub-processed sub-unprocessed) + (loop + line + (cdr unprocessed); recursion here + indentation-levels))) + (loop + (append processed (list sub-processed)) + sub-unprocessed ; simply use the recursion from the sub-recursion + indentation-levels)))))) + ((< current-indentation current-line-indentation) + (loop + processed + unprocessed + (cons ; recursion via the indentation-levels + current-line-indentation + indentation-levels))) + (else + (raise-exception + (make-exception-from-throw + 'wisp-not-implemented + (list + (format #f "Need to implement further line comparison: current: ~A, next: ~A, processed: ~A." + current-line next-line processed))))))))))) + + +(define (wisp-scheme-replace-inline-colons lines) + "Replace inline colons by opening parens which close at the end of the line" + (let loop ((processed '()) + (unprocessed lines)) + (if (null? unprocessed) + processed + (loop + (append processed (list (line-replace-inline-colons (car unprocessed)))) + (cdr unprocessed))))) + + +(define (wisp-scheme-strip-indentation-markers lines) + "Strip the indentation markers from the beginning of the lines" + (let loop ((processed '()) + (unprocessed lines)) + (if (null? unprocessed) + processed + (loop + (append processed (cdr (car unprocessed))) + (cdr unprocessed))))) + +(define (wisp-unescape-underscore-and-colon code) + "replace \\_ and \\: by _ and :" + (wisp-add-source-properties-from/when-required + code + (cond ((list? code) (map wisp-unescape-underscore-and-colon code)) + ((eq? code '\:) ':) + ;; Look for symbols like \____ and remove the \. + ((symbol? code) + (let ((as-string (symbol->string code))) + (if (and (>= (string-length as-string) 2) ; at least a single underscore + (char=? (string-ref as-string 0) #\\) + (string-every #\_ (substring as-string 1))) + (string->symbol (substring as-string 1)) + code))) + (#t code)))) + + +(define (wisp-replace-empty-eof code) + "replace ((#)) by ()" + ;; This is a hack which fixes a bug when the + ;; parser hits files with only hashbang and comments. + (if (and (not (null? code)) (pair? (car code)) (eof-object? (car (car code))) (null? (cdr code)) (null? (cdr (car code)))) + (wisp-add-source-properties-from code (list)) + code)) + + +(define (wisp-replace-paren-quotation-repr code) + "Replace lists starting with a quotation symbol by + quoted lists." + (wisp-add-source-properties-from/when-required + code + (match code + (('REPR-QUOTE-e749c73d-c826-47e2-a798-c16c13cb89dd a ...) + (list 'quote (map wisp-replace-paren-quotation-repr a))) + ((a ... 'REPR-QUOTE-e749c73d-c826-47e2-a798-c16c13cb89dd b); this is the quoted empty list + (append + (map wisp-replace-paren-quotation-repr a) + (list (list 'quote (map wisp-replace-paren-quotation-repr b))))) + (('REPR-QUASIQUOTE-e749c73d-c826-47e2-a798-c16c13cb89dd 'REPR-UNQUOTE-e749c73d-c826-47e2-a798-c16c13cb89dd a ...) + (list 'quasiquote (list 'unquote (map wisp-replace-paren-quotation-repr a)))) + (('REPR-UNQUOTE-e749c73d-c826-47e2-a798-c16c13cb89dd a ...) + (list 'unquote (map wisp-replace-paren-quotation-repr a))) + ((a ... 'REPR-UNQUOTE-e749c73d-c826-47e2-a798-c16c13cb89dd b) + (append + (map wisp-replace-paren-quotation-repr a) + (list (list 'unquote (map wisp-replace-paren-quotation-repr b))))) + (('REPR-QUASIQUOTE-e749c73d-c826-47e2-a798-c16c13cb89dd a ...) + (list 'quasiquote (map wisp-replace-paren-quotation-repr a))) + ((a ... 'REPR-QUASIQUOTE-e749c73d-c826-47e2-a798-c16c13cb89dd b); this is the quoted empty list + (append + (map wisp-replace-paren-quotation-repr a) + (list (list 'quasiquote (map wisp-replace-paren-quotation-repr b))))) + (('REPR-UNQUOTESPLICING-e749c73d-c826-47e2-a798-c16c13cb89dd a ...) + (list 'unquote-splicing (map wisp-replace-paren-quotation-repr a))) + (('REPR-SYNTAX-e749c73d-c826-47e2-a798-c16c13cb89dd a ...) + (list 'syntax (map wisp-replace-paren-quotation-repr a))) + (('REPR-UNSYNTAX-e749c73d-c826-47e2-a798-c16c13cb89dd a ...) + (list 'unsyntax (map wisp-replace-paren-quotation-repr a))) + (('REPR-QUASISYNTAX-e749c73d-c826-47e2-a798-c16c13cb89dd a ...) + (list 'quasisyntax (map wisp-replace-paren-quotation-repr a))) + (('REPR-UNSYNTAXSPLICING-e749c73d-c826-47e2-a798-c16c13cb89dd a ...) + (list 'unsyntax-splicing (map wisp-replace-paren-quotation-repr a))) + ;; literal array as start of a line: # (a b) c -> (#(a b) c) + ((#\# a ...) + (with-input-from-string ;; hack to defer to read + (string-append "#" + (with-output-to-string + (λ () + (write (map wisp-replace-paren-quotation-repr a) + (current-output-port))))) + read)) + ((a ...) + (map wisp-replace-paren-quotation-repr a)) + (a + a)))) + +(define (wisp-make-improper code) + "Turn (a #{.}# b) into the correct (a . b). + +read called on a single dot creates a variable named #{.}# (|.| +in r7rs). Due to parsing the indentation before the list +structure is known, the reader cannot create improper lists +when it reads a dot. So we have to take another pass over the +code to recreate the improper lists. + +Match is awesome!" + (define is-proper? #t) + ;; local alias + (define (add-prop/req form) + (wisp-add-source-properties-from/when-required code form)) + (wisp-add-source-properties-from/when-required + code + (let ((improper + (match code + ((a ... b 'REPR-DOT-e749c73d-c826-47e2-a798-c16c13cb89dd c) + (set! is-proper? #f) + (wisp-add-source-properties-from/when-required + code + (append (map wisp-make-improper (map add-prop/req a)) + (cons (wisp-make-improper (add-prop/req b)) + (wisp-make-improper (add-prop/req c)))))) + ((a ...) + (add-prop/req + (map wisp-make-improper (map add-prop/req a)))) + (a + a)))) + (define (syntax-error li msg) + (raise-exception + (make-exception-from-throw + 'wisp-syntax-error + (list (format #f "incorrect dot-syntax #{.}# in code: ~A: ~A" msg li))))) + (if is-proper? + improper + (let check ((tocheck improper)) + (match tocheck + ;; lists with only one member + (('REPR-DOT-e749c73d-c826-47e2-a798-c16c13cb89dd) + (syntax-error tocheck "list with the period as only member")) + ;; list with remaining dot. + ((a ...) + (if (and (member repr-dot a)) + (syntax-error tocheck "leftover period in list") + (map check a))) + ;; simple pair - this and the next do not work when parsed from wisp-scheme itself. Why? + (('REPR-DOT-e749c73d-c826-47e2-a798-c16c13cb89dd . c) + (syntax-error tocheck "dot as first element in already improper pair")) + ;; simple pair, other way round + ((a . 'REPR-DOT-e749c73d-c826-47e2-a798-c16c13cb89dd) + (syntax-error tocheck "dot as last element in already improper pair")) + ;; more complex pairs + ((? pair? a) + (let ((head (drop-right a 1)) + (tail (last-pair a))) + (cond + ((equal? repr-dot (car tail)) + (syntax-error tocheck "equal? repr-dot : car tail")) + ((equal? repr-dot (cdr tail)) + (syntax-error tocheck "equal? repr-dot : cdr tail")) + ((member repr-dot head) + (syntax-error tocheck "member repr-dot head")) + (else + a)))) + (a + a))))))) + +(define (wisp-scheme-read-chunk port) + "Read and parse one chunk of wisp-code" + (with-fluids ((%read-hash-procedures (fluid-ref %read-hash-procedures))) + (read-hash-extend #\# (lambda args #\#)) + (let ((lines (wisp-scheme-read-chunk-lines port))) + (wisp-make-improper + (wisp-replace-empty-eof + (wisp-unescape-underscore-and-colon + (wisp-replace-paren-quotation-repr + (wisp-propagate-source-properties + (wisp-scheme-indentation-to-parens lines))))))))) + +(define (wisp-scheme-read-all port) + "Read all chunks from the given port" + (let loop ((tokens '())) + (cond + ((eof-object? (peek-char port)) + tokens) + (else + (loop + (append tokens (wisp-scheme-read-chunk port))))))) + +(define (wisp-scheme-read-file path) + (call-with-input-file path wisp-scheme-read-all)) + +(define (wisp-scheme-read-file-chunk path) + (call-with-input-file path wisp-scheme-read-chunk)) + +(define (wisp-scheme-read-string str) + (call-with-input-string str wisp-scheme-read-all)) + +(define (wisp-scheme-read-string-chunk str) + (call-with-input-string str wisp-scheme-read-chunk)) diff --git a/module/language/wisp/spec.scm b/module/language/wisp/spec.scm new file mode 100644 index 000000000..f7fd794e0 --- /dev/null +++ b/module/language/wisp/spec.scm @@ -0,0 +1,70 @@ +;;; Language interface for Wisp in Guile + +;; Copyright (C) 2005--2014 by David A. Wheeler and Alan Manuel K. Gloria +;; Copyright (C) 2014--2023 Arne Babenhauserheide. +;; Copyright (C) 2023 Maxime Devos + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;; adapted from spec.scm: https://gitorious.org/nacre/guile-sweet/?p=nacre:guile-sweet.git;a=blob;f=sweet/spec.scm;hb=ae306867e371cb4b56e00bb60a50d9a0b8353109 + +(define-module (language wisp spec) + #:use-module (language wisp) + #:use-module (system base compile) + #:use-module (system base language) + #:use-module (language scheme compile-tree-il) + #:use-module (language scheme decompile-tree-il) + #:export (wisp)) + +;;; +;;; Language definition +;;; + + +(define (read-one-wisp-sexp port env) + ;; Allow using "# foo" as #(foo). + ;; Don't use the globally-acting read-hash-extend, because this + ;; doesn't make much sense in parenthese-y (non-Wisp) Scheme. + ;; Instead, use fluids to temporarily add the extension. + (with-fluids ((%read-hash-procedures (fluid-ref %read-hash-procedures))) + (read-hash-extend #\# (lambda args #\# )) + ;; Read Wisp files as UTF-8, to support non-ASCII characters. + ;; TODO: would be nice to support ';; coding: whatever' lines + ;; like in parenthese-y Scheme. + (set-port-encoding! port "UTF-8") + (if (eof-object? (peek-char port)) + (read-char port) ; return eof: we’re done + (let ((chunk (wisp-scheme-read-chunk port))) + (and (not (null? chunk)) ; <---- XXX: maybe (pair? chunk) + (car chunk)))))) + +(define-language wisp + #:title "Wisp Scheme Syntax. See SRFI-119 for details" + ;; . #:reader read-one-wisp-sexp + #:reader read-one-wisp-sexp ; : lambda (port env) : let ((x (read-one-wisp-sexp port env))) (display x)(newline) x ; + #:compilers `((tree-il . ,compile-tree-il)) + #:decompilers `((tree-il . ,decompile-tree-il)) + #:evaluator (lambda (x module) (primitive-eval x)) + #:printer write ; TODO: backtransform to Wisp? Use source-properties? + #:make-default-environment + (lambda () + ;; Ideally we'd duplicate the whole module hierarchy so that `set!', + ;; `fluid-set!', etc. don't have any effect in the current environment. + (let ((m (make-fresh-user-module))) + ;; Provide a separate `current-reader' fluid so that + ;; compile-time changes to `current-reader' are + ;; limited to the current compilation unit. + (module-define! m 'current-reader (make-fluid)) + m))) diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 81e63bce2..247d97746 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -162,7 +162,8 @@ SCM_TESTS = tests/00-initial-env.test \ tests/srfi-98.test \ tests/srfi-105.test \ tests/srfi-111.test \ - tests/srfi-171.test \ + tests/srfi-119.test \ + tests/srfi-171.test \ tests/srfi-4.test \ tests/srfi-9.test \ tests/statprof.test \ diff --git a/test-suite/tests/srfi-119.test b/test-suite/tests/srfi-119.test new file mode 100644 index 000000000..5390a25b3 --- /dev/null +++ b/test-suite/tests/srfi-119.test @@ -0,0 +1,1040 @@ +;;;; srfi-119.test --- Test suite for Guile's SRFI-119 reader. -*- scheme -*- +;;;; +;;;; Copyright (C) 2023 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (test-srfi-119) + #:use-module (test-suite lib) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) ;; cut + #:use-module (language wisp)) + +(define (read-string s) + (with-input-from-string s read)) + +(define (with-read-options opts thunk) + (let ((saved-options (read-options))) + (dynamic-wind + (lambda () + (read-options opts)) + thunk + (lambda () + (read-options saved-options))))) + +(define (wisp->list str) + (wisp-scheme-read-string str)) + +(define (scheme->list str) + (with-input-from-string str + (λ () + (let loop ((result '())) + (if (eof-object? (peek-char)) + (reverse! result) + (loop (cons (read) result))))))) + +(with-test-prefix "wisp-read-simple" + (pass-if-equal '((<= n 5)) + (wisp->list "<= n 5")) + (pass-if-equal '(5) + (wisp->list ". 5")) + (pass-if-equal '((+ 1 (* 2 3))) + (wisp->list "+ 1 : * 2 3"))) +(with-test-prefix "wisp-read-complex" + (pass-if-equal '( + (a b c d e + f g h + i j k) + + (concat "I want " + (getwish from me) + " - " username)) (wisp->list " +a b c d e + . f g h + . i j k + +concat \"I want \" + getwish from me + . \" - \" username +")) + + (pass-if-equal + '( + (define (a b c) + (d e + (f) + (g h) + i)) + + (define (_) + (display "hello\n")) + + (_)) (wisp->list " +define : a b c +_ d e +___ f +___ g h +__ . i + +define : _ +_ display \"hello\n\" + +\\_")) + + ;; nesting with pairs + (pass-if-equal '((1 . 2)(3 4 (5 . 6))) + (wisp->list "1 . 2\n3 4\n 5 . 6"))) + +(with-test-prefix "wisp-source-properties" + ;; has properties + (pass-if (every pair? (map source-properties (wisp->list "1 . 2\n3 4\n 5 . 6")))) + (pass-if (every pair? (map source-properties (wisp->list "1 2\n3 4\n 5 6")))) + ;; has the same properties + (pass-if-equal + (map source-properties (scheme->list "(1 . 2)\n(3 4\n (5 . 6))\n(1 4)\n\n(7 8)")) + (map (cut cons '(filename . #f) <>) + (map source-properties (wisp->list "1 . 2\n3 4\n 5 . 6\n1 4\n\n7 8"))))) + +(with-test-prefix "btest" + (pass-if-equal '((display "b") +(newline) + + +) (wisp->list " +display \"b\" +newline +"))) + +(with-test-prefix "continuation" + (pass-if-equal '((a b c d e + f g h + i j k) + +(concat "I want " + (getwish from me) + " - " username) + + + +) (wisp->list " +a b c d e + . f g h + . i j k + +concat \"I want \" + getwish from me + . \" - \" username + +"))) + +(with-test-prefix "dotted-pair" + (pass-if-equal '((use-modules ((ice-9 popen) #:select ((open-input-pipe . oip)))) + + + ) (wisp->list " +use-modules : (ice-9 popen) #:select ((open-input-pipe . oip)) +"))) + +(with-test-prefix "example" + (pass-if-equal '((defun a (b c) + (let + ( + (d "i am a string +do not break me!") + ( + ; comment: 0 + (f) +; comment : 1 + `(g )); comment " : " 2 + ( + (h (I am in brackets: + do not : change "me")) + i))) + ,('j k) + + l + +; comment + + (a c)) + +(defun b (:n o) + "second defun : with a docstring!" + (message "I am here") + t) + +(defun c (e f) + ((g)) + ( + (h + (i)) + (j)) + '(()) + (k) + l + (m)) + +(defun _ (:) + + :) + +(_ b) + +(defun d () + (let + ((a b) + (c d)))) + +(a (((c)))) + +(let + ((a b) + (c))) + +(let ((a b))) + +a + + + +) (wisp->list " +defun a (b c) + let + : + d \"i am a string +do not break me!\" + : + ; comment: 0 + f +; comment : 1 + ` g ; comment \" : \" 2 + : + h (I am in brackets: + do not : change \"me\") + . i + , 'j k + + . l + +; comment + + a c + +defun b : :n o + . \"second defun : with a docstring!\" + message \"I am here\" + . t + +defun c : e f + : g + : + h + i + j + ' : + k + . l + . : m + +defun _ : \\: +__ +__ . \\: + +\\_ b + +defun d : + let + : a b + c d + +a : : : c + +let + : a b + c + +let : : a b + +. a + +"))) + +(with-test-prefix "factorial" + (pass-if-equal '(;; short version +; note: once you use one inline colon, all the following forms on that +; line will get closed at the end of the line + +(define (factorial n) + (if (zero? n) + 1 + (* n (factorial (- n 1))))) + +(display (factorial 5 )) + + +;; more vertical space, less colons +(define (factorial n) + (if (zero? n) + 1 + (* n + (factorial + (- n 1))))) + +(display (factorial 5 )) + + + +) (wisp->list " +;; short version +; note: once you use one inline colon, all the following forms on that +; line will get closed at the end of the line + +define : factorial n + if : zero? n + . 1 + * n : factorial : - n 1 + +display : factorial 5 + + +;; more vertical space, less colons +define : factorial n + if : zero? n + . 1 + * n + factorial + - n 1 + +display : factorial 5 + +"))) + +(with-test-prefix "fast-sum" + (pass-if-equal '((use-modules (srfi srfi-1)) + +; only for the nice test +#!curly-infix + +(define-syntax fast-sum + (syntax-rules (iota) + ((fast-sum (iota count start)) + (+ 1 + (apply - + (map (lambda (x) (/ {x * {x + 1} } 2)) + (list {count + {start - 1}} start))))) + ((fast-sum e) + (apply + e)))) + + +) (wisp->list " +use-modules : srfi srfi-1 + +; only for the nice test +. #!curly-infix + +define-syntax fast-sum + syntax-rules : iota + : fast-sum : iota count start + + 1 + apply - + map : lambda (x) : / {x * {x + 1} } 2 + list {count + {start - 1}} start + : fast-sum e + apply + e +"))) + +(with-test-prefix "flexible-parameter-list" + (pass-if-equal '(; Test using a . as first parameter on a line by prefixing it with a second . +(define + (a i + . b) + (unless (>= i (length b)) + (display (number->string (length b ))) + (display (list-ref b i)) + (newline) + (apply a ( + i 1 ) b))) + + +(a 0 "123" "345" "567") + + +) (wisp->list " +; Test using a . as first parameter on a line by prefixing it with a second . +define + a i + . . b + unless : >= i : length b + display : number->string : length b + display : list-ref b i + newline + apply a ( + i 1 ) b + + +a 0 \"123\" \"345\" \"567\" +"))) + +(with-test-prefix "hello" + (pass-if-equal '((define (hello who) + ;; include the newline + (format #t "~A ~A!\n" + "Hello" who)) +(hello "Wisp") + +) (wisp->list " +define : hello who + ;; include the newline + format #t \"~A ~A!\\n\" + . \"Hello\" who +hello \"Wisp\" +"))) + +(with-test-prefix "mtest" + (pass-if-equal '(#!/home/arne/wisp/wisp-multiline.sh !# + +(display 1) + + +) (wisp->list " +#!/home/arne/wisp/wisp-multiline.sh !# + +display 1 +"))) + +(with-test-prefix "multiline-string" + (pass-if-equal '((display " + This is a + \"multi-line\" + string. + ") + + ) (wisp->list " +display \" + This is a + \\\"multi-line\\\" + string. + \" +"))) + +(with-test-prefix "namedlet" + (pass-if-equal '(#!/home/arne/wisp/wisp-multiline.sh +; !# +(define (hello who) + (display who)) + +(let hello + ((who 0)) + (if (= who 5) + (display who) + (hello (+ 1 who)))) + + +) (wisp->list " +#!/home/arne/wisp/wisp-multiline.sh +; !# +define : hello who + display who + +let hello + : who 0 + if : = who 5 + display who + hello : + 1 who +"))) + +;; the following is no error, but produces a warning because indentation is inconsistent. +(with-test-prefix "partial-indent" + (pass-if-equal '((write + (list + (+ 1 2) + (+ 2 3))) +(newline) + +(write + (list + (+ 1 2 + (+ 3 4)) + (+ 2 3))) +(newline) + + +) (wisp->list " +write + list + + 1 2 + + 2 3 +newline + +write + list + + 1 2 + + 3 4 + + 2 3 +newline +"))) + +(with-test-prefix "quotecolon" + (pass-if-equal '(#!/home/arne/wisp/wisp-multiline.sh +; !# +(define a 1 ); test whether ' : correctly gets turned into '( +; and whether brackets in commments are treated correctly. + +(define a '(1 2 3)) + +(define + (a b) + (c)) + +(define a (quasiquote ,(+ 2 2))) +) (wisp->list " +#!/home/arne/wisp/wisp-multiline.sh +; !# +define a 1 ; test whether ' : correctly gets turned into '( +; and whether brackets in commments are treated correctly. + +define a ' : 1 2 3 + +define + a b + c + +define a : quasiquote , : + 2 2 +"))) + +(with-test-prefix "range" + (pass-if-equal '((import (rnrs)) + +(define range + (case-lambda + ((n ); one-argument syntax + (range 0 n 1)) + ((n0 n ); two-argument syntax + (range n0 n 1)) + ((n0 n s ); three-argument syntax + (assert + (and + (for-all number? (list n0 n s)) + (not (zero? s)))) + (let ((cmp (if (positive? s) >= <= ))) + (let loop + ((i n0 ) + (acc '())) + (if + (cmp i n ) + (reverse acc) + (loop (+ i s) (cons i acc)))))))) + +(display (apply string-append "" (map number->string (range 5)))) +(newline) + +) (wisp->list " +import : rnrs + +define range + case-lambda + : n ; one-argument syntax + range 0 n 1 + : n0 n ; two-argument syntax + range n0 n 1 + : n0 n s ; three-argument syntax + assert + and + for-all number? : list n0 n s + not : zero? s + let : : cmp : if (positive? s) >= <= + let loop + : i n0 + acc '() + if + cmp i n + reverse acc + loop (+ i s) (cons i acc) + +display : apply string-append \"\" : map number->string : range 5 +newline"))) + +(with-test-prefix "readable-tests" + (pass-if-equal '((define (fibfast n) + (if (< n 2)) + n + (fibup n 2 1 0 )) + +(define (fibup maxnum count n-1 n-2) + (if (= maxnum count) + (+ n-1 n-2) + (fibup maxnum + (+ count 1 ) + (+ n-1 n-2 ) + n-1))) + +(define (factorial n) + (if (<= n 1) + 1 + (* n + (factorial (- n 1))))) + +(define (gcd x y) + (if (= y 0)) + x + (gcd y + (rem x y))) + +(define (add-if-all-numbers lst) + (call/cc + (lambda (exit) + (let loop + ( + (lst lst ) + (sum 0)) + (if (null? lst) + sum + (if (not (number? (car lst))) + (exit #f) + (+ (car lst) + (loop (cdr lst))))))))) + +) (wisp->list " +define : fibfast n + if : < n 2 + . n + fibup n 2 1 0 + +define : fibup maxnum count n-1 n-2 + if : = maxnum count + + n-1 n-2 + fibup maxnum + + count 1 + + n-1 n-2 + . n-1 + +define : factorial n + if : <= n 1 + . 1 + * n + factorial : - n 1 + +define (gcd x y) + if (= y 0) + . x + gcd y + rem x y + +define : add-if-all-numbers lst + call/cc + lambda : exit + let loop + : + lst lst + sum 0 + if : null? lst + . sum + if : not : number? : car lst + exit #f + + : car lst + loop : cdr lst"))) + +(with-test-prefix "receive" + (pass-if-equal '((import (ice-9 receive) (srfi srfi-1)) +(write + (receive (car cdr) + (car+cdr '(car . cdr)) + car)) +) (wisp->list " +import (ice-9 receive) (srfi srfi-1) +write + receive : car cdr + car+cdr '(car . cdr) + . car +"))) + +(with-test-prefix "self-referencial" + (pass-if-equal '(; http://stackoverflow.com/questions/23167464/scheme-self-reference-lambda-macro +; because this is as cool as things get +(define-syntax slambda + (lambda (x) + (syntax-case x () + ((slambda formals body0 body1 ...) + (with-syntax + ((self (datum->syntax #'slambda 'self))) + #'(letrec ((self (lambda formals body0 body1 ...))) + self)))))) + + + +( + (slambda (x) (+ x 1)) + 10) + +((slambda () self)) + + + +) (wisp->list " +; http://stackoverflow.com/questions/23167464/scheme-self-reference-lambda-macro +; because this is as cool as things get +define-syntax slambda + lambda : x + syntax-case x : + : slambda formals body0 body1 ... + with-syntax + : self : datum->syntax #'slambda 'self + #' letrec : : self : lambda formals body0 body1 ... + . self + + + +: + slambda (x) : + x 1 + . 10 + +: slambda () self + +"))) + +(with-test-prefix "shebang" + (pass-if-equal '(#!/usr/bin/wisp.py # !# +; This tests shebang lines + + + ) (wisp->list " +#!/usr/bin/wisp.py # !# +; This tests shebang lines +"))) + +(with-test-prefix "strangecomments" + (pass-if-equal '((use-modules (wisp-scheme)) +; works +(display + (call-with-input-string "foo ; bar\n ; nop \n\n; nup\n; nup \n \n\n\n foo : moo \"\n\" \n___ . goo . hoo" wisp-scheme-read-chunk)) +(newline) +(display + (call-with-input-string "foo \n___ . goo . hoo" wisp-scheme-read-chunk)) +(newline) + +) (wisp->list " +use-modules : wisp-scheme +; works +display + call-with-input-string \"foo ; bar\\n ; nop \\n\\n; nup\\n; nup \\n \\n\\n\\n foo : moo \\\"\\n\\\" \\n___ . goo . hoo\" wisp-scheme-read-chunk +newline +display + call-with-input-string \"foo \\n___ . goo . hoo\" wisp-scheme-read-chunk +newline +"))) + +(with-test-prefix "sublist" +(pass-if-equal '(; sublists allow to start single line function calls with a colon ( : ). + +(defun a (b c) + (let ((e . f)) + g)) + + +) (wisp->list " +; sublists allow to start single line function calls with a colon ( : ). +; +defun a : b c + let : : e . f + . g + "))) + +(with-test-prefix "sxml" +(pass-if-equal '((use-modules (sxml simple)) +(use-modules (ice-9 match)) + +; define a template +(define template + (quote + (html + (head (title "test")) + (body + (h1 "test") + (message "the header") + (p "it " (em "works!") + (br) + (" it actually works!")))))) + +; transform it +(define template2 + (let loop + ((l template)) + (match l + (('message a ...) + `(p (@ (style "margin-left: 2em")) + (strong ,(map loop a)))) + ((a ...) + (map loop a )) + (a + a)))) + +; write xml to the output port +(sxml->xml template2) + +(newline) + + +) (wisp->list " + use-modules : sxml simple +use-modules : ice-9 match + +; define a template +define template + quote + html + head : title \"test\" + body + h1 \"test\" + message \"the header\" + p \"it \" : em \"works!\" + br + \" it actually works!\" + +; transform it +define template2 + let loop + : l template + match l + : 'message a ... + ` p : @ : style \"margin-left: 2em\" + strong ,(map loop a) + : a ... + map loop a + a + . a + +; write xml to the output port +sxml->xml template2 + +newline +"))) + +(with-test-prefix "syntax-colon" +(pass-if-equal '((let + ( + (a 1) + (b 2)) + (let + ( + ( + c 3)) + (format #t "a: ~A, b: ~A, c: ~A" + a b c))) + +((a)) + +(define (hello) + (display "hello\n")) + +(let + ((a 1) + (b 2)) + (format #t "a: ~A, b: ~A" + a b)) + +(let ((a '()))) + +(let + ( ; foo + (a + '()))) + +( + (a)) + +(define (:) + (hello)) + +(:) + + +) (wisp->list " +let + : + a 1 + b 2 + let + : + : + . c 3 + format #t \"a: ~A, b: ~A, c: ~A\" + . a b c + +: a + +define : hello + display \"hello\\n\" + +let + : a 1 + b 2 + format #t \"a: ~A, b: ~A\" + . a b + +let : : a ' : + +let + : ; foo + a + ' + +: + a + +define : \\: + hello + +\\: +"))) + +(with-test-prefix "syntax-dot" +(pass-if-equal '((define (foo) + "bar") + +(define (bar) + '(1 + . 2 )); pair + +(display (foo)) +(newline) +(display (bar)) +(newline) + + +) (wisp->list " +define : foo + . \"bar\" + +define : bar + ' 1 + . . 2 ; pair + +display : foo +newline +display : bar +newline +"))) + +(with-test-prefix "syntax-empty" +(pass-if-equal '() (wisp->list " +"))) + +(with-test-prefix "syntax-indent" +(pass-if-equal '((define + (hello who) + (format #t "Hello ~A\n" who)) + +(define + (let + ( + (a 1) + (b 2) + (c 3)) + (format #t "a: ~A, b: ~A, c: ~A" + (+ a 2) + b c))) + + + +) (wisp->list "define + hello who + format #t \"Hello ~A\\n\" who + +define + let + : + a 1 + b 2 + c 3 + format #t \"a: ~A, b: ~A, c: ~A\" + + a 2 + . b c + + "))) + +(with-test-prefix "syntax-strings-parens" +(pass-if-equal '(; Test linebreaks in strings and brackets + +"flubbub + +flabbab" + +(hrug (nadda +madda gadda "shoktom + mee" " sep +ka" + hadda) + (gom)) + +(flu) + +(sum [foo +bar] barz {1 + [* 2 2]}) + +(mara { +li ++ +lo - (mabba) +}) +) (wisp->list " +; Test linebreaks in strings and brackets + +. \"flubbub + +flabbab\" + +hrug (nadda +madda gadda \"shoktom + mee\" \" sep +ka\" + hadda) + gom + +flu + +sum [foo +bar] barz {1 + [* 2 2]} + +mara { +li ++ +lo - (mabba) +} +"))) + +(with-test-prefix "syntax-underscore" +(pass-if-equal '((define (a b c) + (d e + (f) + (g h) + i)) + +(define (_) + (display "hello\n")) + +(_) + + +) (wisp->list " +define : a b c +_ d e +___ f +___ g h +__ . i + +define : _ +_ display \"hello\\n\" + +\\_ +"))) + -- 2.41.0