wisp.scm 30 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786
  1. ;;; Wisp
  2. ;; Copyright (C) 2013, 2017, 2018, 2020, 2024 Free Software Foundation, Inc.
  3. ;; Copyright (C) 2014--2023 Arne Babenhauserheide.
  4. ;; Copyright (C) 2023 Maxime Devos <maximedevos@telenet.be>
  5. ;;;; This library is free software; you can redistribute it and/or
  6. ;;;; modify it under the terms of the GNU Lesser General Public
  7. ;;;; License as published by the Free Software Foundation; either
  8. ;;;; version 3 of the License, or (at your option) any later version.
  9. ;;;;
  10. ;;;; This library is distributed in the hope that it will be useful,
  11. ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12. ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  13. ;;;; Lesser General Public License for more details.
  14. ;;;;
  15. ;;;; You should have received a copy of the GNU Lesser General Public
  16. ;;;; License along with this library; if not, write to the Free Software
  17. ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18. ;;; Commentary:
  19. ;; Scheme-only implementation of a wisp-preprocessor which output a
  20. ;; Scheme code tree to feed to a Scheme interpreter instead of a
  21. ;; preprocessed file.
  22. ;; Limitations:
  23. ;; - in some cases the source line information is missing in backtraces.
  24. ;; check for set-source-property!
  25. ;;; Code:
  26. (define-module (language wisp)
  27. #:export (wisp-scheme-read-chunk wisp-scheme-read-all
  28. wisp-scheme-read-file-chunk wisp-scheme-read-file
  29. wisp-scheme-read-string)
  30. #:use-module (srfi srfi-1)
  31. #:use-module (srfi srfi-11); for let-values
  32. #:use-module (srfi srfi-9); for records
  33. #:use-module (ice-9 rw); for write-string/partial
  34. #:use-module (ice-9 match))
  35. ;; use curly-infix by default
  36. (eval-when (expand load eval)
  37. (read-enable 'curly-infix))
  38. ;; Helpers to preserver source properties
  39. (define (wisp-add-source-properties-from source target)
  40. "Copy the source properties from source into the target and return the target."
  41. (catch #t
  42. (lambda ()
  43. (set-source-properties! target (source-properties source)))
  44. (lambda (key . arguments)
  45. #f))
  46. target)
  47. (define (wisp-add-source-properties-from/when-required source target)
  48. "Copy the source properties if target has none."
  49. (if (null? (source-properties target))
  50. (wisp-add-source-properties-from source target)
  51. target))
  52. ;; Helper functions for the indent-and-symbols data structure: '((indent token token ...) ...)
  53. (define make-line list)
  54. (define (line-indent line)
  55. (car line))
  56. (define (line-real-indent line)
  57. "Get the indentation without the comment-marker for unindented lines (-1 is treated as 0)."
  58. (let ((indent (line-indent line)))
  59. (if (= -1 indent)
  60. 0
  61. indent)))
  62. (define (line-code line)
  63. "Strip the indentation markers from the beginning of the line and preserve source-properties"
  64. (let ((code (cdr line)))
  65. ;; propagate source properties
  66. (when (not (null? code))
  67. (wisp-add-source-properties-from/when-required line code))
  68. code))
  69. ;; literal values I need
  70. (define readcolon
  71. (string->symbol ":"))
  72. ;; define an intermediate dot replacement with UUID to avoid clashes.
  73. (define repr-dot ; .
  74. (make-symbol "wisp-dot"))
  75. ;; allow using reader additions as the first element on a line to prefix the list
  76. (define repr-quote ; '
  77. (make-symbol "wisp-quote"))
  78. (define repr-unquote ; ,
  79. (make-symbol "wisp-unquote"))
  80. (define repr-quasiquote ; `
  81. (make-symbol "wisp-quasiquote"))
  82. (define repr-unquote-splicing ; ,@
  83. (make-symbol "wisp-unquote-splicing"))
  84. (define repr-syntax ; #'
  85. (make-symbol "wisp-syntax"))
  86. (define repr-unsyntax ; #,
  87. (make-symbol "wisp-unsyntax"))
  88. (define repr-quasisyntax ; #`
  89. (make-symbol "wisp-quasisyntax"))
  90. (define repr-unsyntax-splicing ; #,@
  91. (make-symbol "wisp-unsyntax-splicing"))
  92. ;; TODO: wrap the reader to return the repr of the syntax reader
  93. ;; additions
  94. (define (equal-rest? chars . args)
  95. (equal? chars args))
  96. (define (match-charlist-to-repr char-list)
  97. (let ((chars (reverse char-list)))
  98. (cond
  99. ((equal-rest? chars #\.) repr-dot)
  100. ((equal-rest? chars #\') repr-quote)
  101. ((equal-rest? chars #\,) repr-unquote)
  102. ((equal-rest? chars #\`) repr-quasiquote)
  103. ((equal-rest? chars #\, #\@) repr-unquote-splicing)
  104. ((equal-rest? chars #\# #\') repr-syntax)
  105. ((equal-rest? chars #\# #\,) repr-unsyntax)
  106. ((equal-rest? chars #\# #\`) repr-quasisyntax)
  107. ((equal-rest? chars #\# #\, #\@) repr-unsyntax-splicing)
  108. (else #f))))
  109. (define (wisp-read port)
  110. "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."
  111. (let ((prefix-maxlen 4))
  112. (let longpeek ((peeked '()) (repr-symbol #f))
  113. (cond
  114. ((or (< prefix-maxlen (length peeked))
  115. (eof-object? (peek-char port))
  116. (equal? #\space (peek-char port))
  117. (equal? #\newline (peek-char port)))
  118. (if repr-symbol ; found a special symbol, return it.
  119. repr-symbol
  120. (let unpeek ((remaining peeked))
  121. (cond
  122. ((equal? '() remaining)
  123. (read port)); let read to the work
  124. (else
  125. (unread-char (car remaining) port)
  126. (unpeek (cdr remaining)))))))
  127. (else
  128. (let* ((next-char (read-char port))
  129. (peeked (cons next-char peeked)))
  130. (longpeek
  131. peeked
  132. (match-charlist-to-repr peeked))))))))
  133. (define (line-continues? line)
  134. (eq? repr-dot (car (line-code line))))
  135. (define (line-only-colon? line)
  136. (and
  137. (equal? ":" (car (line-code line)))
  138. (null? (cdr (line-code line)))))
  139. (define (line-empty-code? line)
  140. (null? (line-code line)))
  141. (define (line-empty? line)
  142. (and
  143. ;; if indent is -1, we stripped a comment, so the line was not really empty.
  144. (= 0 (line-indent line))
  145. (line-empty-code? line)))
  146. (define (line-strip-continuation line)
  147. (if (line-continues? line)
  148. (apply make-line
  149. (line-indent line)
  150. (cdr (line-code line)))
  151. line))
  152. (define (line-strip-indentation-marker line)
  153. "Strip the indentation markers from the beginning of the line for line-finalize without propagating source-properties (those are propagated in a second step)"
  154. (cdr line))
  155. (define (indent-level-reduction indentation-levels level select-fun)
  156. "Reduce the INDENTATION-LEVELS to the given LEVEL and return the value selected by SELECT-FUN"
  157. (let loop ((newlevels indentation-levels)
  158. (diff 0))
  159. (cond
  160. ((= level (car newlevels))
  161. (select-fun (list diff indentation-levels)))
  162. ((< level (car newlevels))
  163. (loop
  164. (cdr newlevels)
  165. (1+ diff)))
  166. (else
  167. (raise-exception (make-exception-from-throw 'wisp-syntax-error (list (format #f "Level ~A not found in the indentation-levels ~A." level indentation-levels))))))))
  168. (define (indent-level-difference indentation-levels level)
  169. "Find how many indentation levels need to be popped off to find the given level."
  170. (indent-level-reduction indentation-levels level
  171. (lambda (x); get the count
  172. (car x))))
  173. (define (indent-reduce-to-level indentation-levels level)
  174. "Find how many indentation levels need to be popped off to find the given level."
  175. (indent-level-reduction indentation-levels level
  176. (lambda (x); get the levels
  177. (car (cdr x)))))
  178. (define (chunk-ends-with-period currentsymbols next-char)
  179. "Check whether indent-and-symbols ends with a period, indicating the end of a chunk."
  180. (and (not (null? currentsymbols))
  181. (equal? #\newline next-char)
  182. (eq? repr-dot
  183. (list-ref currentsymbols (- (length currentsymbols) 1)))))
  184. (define (wisp-scheme-read-chunk-lines port)
  185. ;; the line number for this chunk is the line number when starting to read it
  186. ;; a top-level form stops processing, so we only need to retrieve this here.
  187. (define line-number (port-line port))
  188. (let loop ((indent-and-symbols (list)); '((5 "(foobar)" "\"yobble\"")(3 "#t"))
  189. (in-indent? #t)
  190. (in-underscoreindent? (equal? #\_ (peek-char port)))
  191. (in-comment? #f)
  192. (currentindent 0)
  193. (currentsymbols '())
  194. (emptylines 0))
  195. (cond
  196. ((>= emptylines 2)
  197. ;; the chunk end has to be checked
  198. ;; before we look for new chars in the
  199. ;; port to make execution in the REPL
  200. ;; after two empty lines work
  201. ;; (otherwise it shows one more line).
  202. indent-and-symbols)
  203. (else
  204. (let ((next-char (peek-char port)))
  205. (cond
  206. ((eof-object? next-char)
  207. (let ((line (apply make-line currentindent currentsymbols)))
  208. (set-source-property! line 'filename (port-filename port))
  209. (set-source-property! line 'line line-number)
  210. (append indent-and-symbols (list line))))
  211. ((and in-indent?
  212. (zero? currentindent)
  213. (not in-comment?)
  214. (not (null? indent-and-symbols))
  215. (not in-underscoreindent?)
  216. (not (or (equal? #\space next-char)
  217. (equal? #\newline next-char)
  218. (equal? (string-ref ";" 0) next-char))))
  219. (append indent-and-symbols)); top-level form ends chunk
  220. ((chunk-ends-with-period currentsymbols next-char)
  221. ;; the line ends with a period. This is forbidden in
  222. ;; SRFI-119. Use it to end the line in the REPL without
  223. ;; showing continuation dots (...).
  224. (append indent-and-symbols (list (apply make-line currentindent (drop-right currentsymbols 1)))))
  225. ((and in-indent? (equal? #\space next-char))
  226. (read-char port); remove char
  227. (loop
  228. indent-and-symbols
  229. #t ; in-indent?
  230. #f ; in-underscoreindent?
  231. #f ; in-comment?
  232. (1+ currentindent)
  233. currentsymbols
  234. emptylines))
  235. ((and in-underscoreindent? (equal? #\_ next-char))
  236. (read-char port); remove char
  237. (loop
  238. indent-and-symbols
  239. #t ; in-indent?
  240. #t ; in-underscoreindent?
  241. #f ; in-comment?
  242. (1+ currentindent)
  243. currentsymbols
  244. emptylines))
  245. ;; any char but whitespace *after* underscoreindent is
  246. ;; an error. This is stricter than the current wisp
  247. ;; syntax definition.
  248. ;; TODO: Fix the definition. Better start too strict.
  249. ;; FIXME: breaks on lines with only underscores which should be
  250. ;; empty lines.
  251. ((and in-underscoreindent? (and (not (equal? #\space next-char)) (not (equal? #\newline next-char))))
  252. (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)))))
  253. ((equal? #\newline next-char)
  254. (read-char port); remove the newline
  255. (let*
  256. ;; distinguish pure whitespace lines and lines
  257. ;; with comment by giving the former zero
  258. ;; indent. Lines with a comment at zero indent
  259. ;; get indent -1 for the same reason - meaning
  260. ;; not actually empty.
  261. ((indent
  262. (cond
  263. (in-comment?
  264. (if (= 0 currentindent); specialcase
  265. -1
  266. currentindent))
  267. ((not (null? currentsymbols)); pure whitespace
  268. currentindent)
  269. (else
  270. 0)))
  271. (parsedline (apply make-line indent currentsymbols))
  272. (emptylines
  273. (if (not (line-empty? parsedline))
  274. 0
  275. (1+ emptylines))))
  276. (when (not (= 0 (length (line-code parsedline))))
  277. ;; set the source properties to parsedline so we can try to add them later.
  278. (set-source-property! parsedline 'filename (port-filename port))
  279. (set-source-property! parsedline 'line line-number))
  280. ;; TODO: If the line is empty. Either do it here and do not add it, just
  281. ;; increment the empty line counter, or strip it later. Replace indent
  282. ;; -1 by indent 0 afterwards.
  283. (loop
  284. (append indent-and-symbols (list parsedline))
  285. #t ; in-indent?
  286. (if (<= 2 emptylines)
  287. #f ; chunk ends here
  288. (equal? #\_ (peek-char port))); are we in underscore indent?
  289. #f ; in-comment?
  290. 0
  291. '()
  292. emptylines)))
  293. ((equal? #t in-comment?)
  294. (read-char port); remove one comment character
  295. (loop
  296. indent-and-symbols
  297. #f ; in-indent?
  298. #f ; in-underscoreindent?
  299. #t ; in-comment?
  300. currentindent
  301. currentsymbols
  302. emptylines))
  303. ((or (equal? #\space next-char) (equal? #\tab next-char) (equal? #\return next-char)); remove whitespace when not in indent
  304. (read-char port); remove char
  305. (loop
  306. indent-and-symbols
  307. #f ; in-indent?
  308. #f ; in-underscoreindent?
  309. #f ; in-comment?
  310. currentindent
  311. currentsymbols
  312. emptylines))
  313. ;; | cludge to appease the former wisp parser
  314. ;; | used for bootstrapping which has a
  315. ;; v problem with the literal comment char
  316. ((equal? (string-ref ";" 0) next-char)
  317. (loop
  318. indent-and-symbols
  319. #f ; in-indent?
  320. #f ; in-underscoreindent?
  321. #t ; in-comment?
  322. currentindent
  323. currentsymbols
  324. emptylines))
  325. (else ; use the reader
  326. (loop
  327. indent-and-symbols
  328. #f ; in-indent?
  329. #f ; in-underscoreindent?
  330. #f ; in-comment?
  331. currentindent
  332. ;; this also takes care of the hashbang and leading comments.
  333. (append currentsymbols (list (wisp-read port)))
  334. emptylines))))))))
  335. (define (line-code-replace-inline-colons line)
  336. "Replace inline colons by opening parens which close at the end of the line"
  337. ;; format #t "replace inline colons for line ~A\n" line
  338. (let loop ((processed '())
  339. (unprocessed line))
  340. (cond
  341. ((null? unprocessed)
  342. ;; format #t "inline-colons processed line: ~A\n" processed
  343. processed)
  344. ;; replace : . with nothing
  345. ((and (<= 2 (length unprocessed))
  346. (equal? readcolon (car unprocessed))
  347. (eq? repr-dot (car (cdr unprocessed))))
  348. (loop
  349. (append processed
  350. (loop '() (cdr (cdr unprocessed))))
  351. '()))
  352. ((equal? readcolon (car unprocessed))
  353. (loop
  354. (append processed
  355. (list (loop '() (cdr unprocessed))))
  356. '()))
  357. (else
  358. (loop
  359. (append processed
  360. (list (car unprocessed)))
  361. (cdr unprocessed))))))
  362. (define (line-replace-inline-colons line)
  363. (cons
  364. (line-indent line)
  365. (line-code-replace-inline-colons (line-code line))))
  366. (define (line-strip-lone-colon line)
  367. "A line consisting only of a colon is just a marked indentation level. We need to kill the colon before replacing inline colons."
  368. (if (equal? (line-code line) (list readcolon))
  369. (make-line (line-indent line))
  370. line))
  371. (define (line-finalize line)
  372. "Process all wisp-specific information in a line and strip it"
  373. (let ((l (line-code-replace-inline-colons
  374. (line-strip-indentation-marker
  375. (line-strip-lone-colon
  376. (line-strip-continuation line))))))
  377. (when (not (null? (source-properties line)))
  378. (catch #t
  379. (lambda ()
  380. (set-source-properties! l (source-properties line)))
  381. (lambda (key . arguments)
  382. #f)))
  383. l))
  384. (define (wisp-propagate-source-properties code)
  385. "Propagate the source properties from the sourrounding list into every part of the code."
  386. (let loop ((processed '())
  387. (unprocessed code))
  388. (cond
  389. ((and (null? processed) (not (pair? unprocessed)) (not (list? unprocessed)))
  390. unprocessed)
  391. ((and (pair? unprocessed) (not (list? unprocessed)))
  392. (cons
  393. (wisp-propagate-source-properties (car unprocessed))
  394. (wisp-propagate-source-properties (cdr unprocessed))))
  395. ((null? unprocessed)
  396. processed)
  397. (else
  398. (let ((line (car unprocessed)))
  399. (wisp-add-source-properties-from/when-required line unprocessed)
  400. (wisp-add-source-properties-from/when-required code unprocessed)
  401. (wisp-add-source-properties-from/when-required unprocessed line)
  402. (wisp-add-source-properties-from/when-required unprocessed code)
  403. (let ((processed (append processed (list (wisp-propagate-source-properties line)))))
  404. ;; must propagate from line, because unprocessed and code can be null, then they cannot keep source-properties.
  405. (wisp-add-source-properties-from/when-required line processed)
  406. (loop processed
  407. (cdr unprocessed))))))))
  408. (define* (wisp-scheme-indentation-to-parens lines)
  409. "Add parentheses to lines and remove the indentation markers"
  410. (when
  411. (and
  412. (not (null? lines))
  413. (not (line-empty-code? (car lines)))
  414. (not (= 0 (line-real-indent (car lines))))); -1 is a line with a comment
  415. (if (= 1 (line-real-indent (car lines)))
  416. ;; accept a single space as indentation of the first line (and ignore the indentation) to support meta commands
  417. (set! lines
  418. (cons
  419. (cons 0 (cdr (car lines)))
  420. (cdr lines)))
  421. (raise-exception
  422. (make-exception-from-throw
  423. 'wisp-syntax-error
  424. (list
  425. (format #f "The first symbol in a chunk must start at zero indentation. Indentation and line: ~A"
  426. (car lines)))))))
  427. (let loop ((processed '())
  428. (unprocessed lines)
  429. (indentation-levels '(0)))
  430. (let* ((current-line
  431. (if (<= 1 (length unprocessed))
  432. (car unprocessed)
  433. (make-line 0))); empty code
  434. (next-line
  435. (if (<= 2 (length unprocessed))
  436. (car (cdr unprocessed))
  437. (make-line 0))); empty code
  438. (current-indentation
  439. (car indentation-levels))
  440. (current-line-indentation (line-real-indent current-line)))
  441. ;; format #t "processed: ~A\ncurrent-line: ~A\nnext-line: ~A\nunprocessed: ~A\nindentation-levels: ~A\ncurrent-indentation: ~A\n\n"
  442. ;; . processed current-line next-line unprocessed indentation-levels current-indentation
  443. (cond
  444. ;; the real end: this is reported to the outside world.
  445. ((and (null? unprocessed) (not (null? indentation-levels)) (null? (cdr indentation-levels)))
  446. ;; reverse the processed lines, because I use cons.
  447. processed)
  448. ;; the recursion end-condition
  449. ((and (null? unprocessed))
  450. ;; this is the last step. Nothing more to do except
  451. ;; for rolling up the indentation levels. return the
  452. ;; new processed and unprocessed lists: this is a
  453. ;; side-recursion
  454. (values processed unprocessed))
  455. ((null? indentation-levels)
  456. (raise-exception
  457. (make-exception-from-throw
  458. 'wisp-programming-error
  459. (list
  460. "The indentation-levels are null but the current-line is null: Something killed the indentation-levels."))))
  461. (else ; now we come to the line-comparisons and indentation-counting.
  462. (cond
  463. ((line-empty-code? current-line)
  464. ;; We cannot process indentation without
  465. ;; code. Just switch to the next line. This should
  466. ;; only happen at the start of the recursion.
  467. (loop
  468. processed
  469. (cdr unprocessed)
  470. indentation-levels))
  471. ((and (line-empty-code? next-line) (<= 2 (length unprocessed)))
  472. ;; take out the next-line from unprocessed.
  473. (loop
  474. processed
  475. (cons current-line
  476. (cdr (cdr unprocessed)))
  477. indentation-levels))
  478. ((> current-indentation current-line-indentation)
  479. ;; this just steps back one level via the side-recursion.
  480. (let ((previous-indentation (car (cdr indentation-levels))))
  481. (if (<= current-line-indentation previous-indentation)
  482. (values processed unprocessed)
  483. (begin ;; not yet used level! TODO: maybe throw an error here instead of a warning.
  484. (let ((linenumber (- (length lines) (length unprocessed))))
  485. (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)))
  486. (loop
  487. processed
  488. unprocessed
  489. (cons ; recursion via the indentation-levels
  490. current-line-indentation
  491. (cdr indentation-levels)))))))
  492. ((= current-indentation current-line-indentation)
  493. (let ((line (line-finalize current-line))
  494. (next-line-indentation (line-real-indent next-line)))
  495. (cond
  496. ((>= current-line-indentation next-line-indentation)
  497. ;; simple recursiive step to the next line
  498. (loop
  499. (append processed
  500. (if (line-continues? current-line)
  501. line
  502. (wisp-add-source-properties-from line (list line))))
  503. (cdr unprocessed); recursion here
  504. indentation-levels))
  505. ((< current-line-indentation next-line-indentation)
  506. ;; side-recursion via a sublist
  507. (let-values
  508. (((sub-processed sub-unprocessed)
  509. (loop
  510. line
  511. (cdr unprocessed); recursion here
  512. indentation-levels)))
  513. (loop
  514. (append processed (list sub-processed))
  515. sub-unprocessed ; simply use the recursion from the sub-recursion
  516. indentation-levels))))))
  517. ((< current-indentation current-line-indentation)
  518. (loop
  519. processed
  520. unprocessed
  521. (cons ; recursion via the indentation-levels
  522. current-line-indentation
  523. indentation-levels)))
  524. (else
  525. (raise-exception
  526. (make-exception-from-throw
  527. 'wisp-not-implemented
  528. (list
  529. (format #f "Need to implement further line comparison: current: ~A, next: ~A, processed: ~A."
  530. current-line next-line processed)))))))))))
  531. (define (wisp-scheme-replace-inline-colons lines)
  532. "Replace inline colons by opening parens which close at the end of the line"
  533. (let loop ((processed '())
  534. (unprocessed lines))
  535. (if (null? unprocessed)
  536. processed
  537. (loop
  538. (append processed (list (line-replace-inline-colons (car unprocessed))))
  539. (cdr unprocessed)))))
  540. (define (wisp-scheme-strip-indentation-markers lines)
  541. "Strip the indentation markers from the beginning of the lines"
  542. (let loop ((processed '())
  543. (unprocessed lines))
  544. (if (null? unprocessed)
  545. processed
  546. (loop
  547. (append processed (cdr (car unprocessed)))
  548. (cdr unprocessed)))))
  549. (define (wisp-unescape-underscore-and-colon code)
  550. "replace \\_ and \\: by _ and :"
  551. (wisp-add-source-properties-from/when-required
  552. code
  553. (cond ((list? code) (map wisp-unescape-underscore-and-colon code))
  554. ((eq? code '\:) ':)
  555. ;; Look for symbols like \____ and remove the \.
  556. ((symbol? code)
  557. (let ((as-string (symbol->string code)))
  558. (if (and (>= (string-length as-string) 2) ; at least a single underscore
  559. (char=? (string-ref as-string 0) #\\)
  560. (string-every #\_ (substring as-string 1)))
  561. (string->symbol (substring as-string 1))
  562. code)))
  563. (#t code))))
  564. (define (wisp-replace-empty-eof code)
  565. "replace ((#<eof>)) by ()"
  566. ;; This is a hack which fixes a bug when the
  567. ;; parser hits files with only hashbang and comments.
  568. (if (and (not (null? code)) (pair? (car code)) (eof-object? (car (car code))) (null? (cdr code)) (null? (cdr (car code))))
  569. (wisp-add-source-properties-from code (list))
  570. code))
  571. (define (wisp-replace-paren-quotation-repr code)
  572. "Replace lists starting with a quotation symbol by quoted lists."
  573. (define (pred value)
  574. (lambda (x)
  575. (eq? x value)))
  576. (wisp-add-source-properties-from/when-required
  577. code
  578. (match code
  579. (((? (pred repr-quote)) a ...)
  580. (list 'quote (map wisp-replace-paren-quotation-repr a)))
  581. ((a ... (? (pred repr-quote)) b); this is the quoted empty list
  582. (append
  583. (map wisp-replace-paren-quotation-repr a)
  584. (list (list 'quote (map wisp-replace-paren-quotation-repr b)))))
  585. (((? (pred repr-quasiquote)) (? (pred repr-unquote)) a ...)
  586. (list 'quasiquote (list 'unquote (map wisp-replace-paren-quotation-repr a))))
  587. (((? (pred repr-unquote)) a ...)
  588. (list 'unquote (map wisp-replace-paren-quotation-repr a)))
  589. ((a ... (? (pred repr-unquote)) b)
  590. (append
  591. (map wisp-replace-paren-quotation-repr a)
  592. (list (list 'unquote (map wisp-replace-paren-quotation-repr b)))))
  593. (((? (pred repr-quasiquote)) a ...)
  594. (list 'quasiquote (map wisp-replace-paren-quotation-repr a)))
  595. ((a ... (? (pred repr-quasiquote)) b) ;this is the quoted empty list
  596. (append
  597. (map wisp-replace-paren-quotation-repr a)
  598. (list (list 'quasiquote (map wisp-replace-paren-quotation-repr b)))))
  599. (((? (pred repr-unquote-splicing)) a ...)
  600. (list 'unquote-splicing (map wisp-replace-paren-quotation-repr a)))
  601. (((? (pred repr-syntax)) a ...)
  602. (list 'syntax (map wisp-replace-paren-quotation-repr a)))
  603. (((? (pred repr-unsyntax)) a ...)
  604. (list 'unsyntax (map wisp-replace-paren-quotation-repr a)))
  605. (((? (pred repr-quasisyntax)) a ...)
  606. (list 'quasisyntax (map wisp-replace-paren-quotation-repr a)))
  607. (((? (pred repr-unsyntax-splicing)) a ...)
  608. (list 'unsyntax-splicing (map wisp-replace-paren-quotation-repr a)))
  609. ;; literal array as start of a line: # (a b) c -> (#(a b) c)
  610. ((#\# a ...)
  611. (with-input-from-string ;; hack to defer to read
  612. (string-append "#"
  613. (with-output-to-string
  614. (λ ()
  615. (write (map wisp-replace-paren-quotation-repr a)
  616. (current-output-port)))))
  617. read))
  618. ((a ...)
  619. (map wisp-replace-paren-quotation-repr a))
  620. (a
  621. a))))
  622. (define (wisp-make-improper code)
  623. "Turn (a #{.}# b) into the correct (a . b).
  624. read called on a single dot creates a variable named #{.}# (|.|
  625. in r7rs). Due to parsing the indentation before the list
  626. structure is known, the reader cannot create improper lists
  627. when it reads a dot. So we have to take another pass over the
  628. code to recreate the improper lists.
  629. Match is awesome!"
  630. (define (dot? x)
  631. (eq? repr-dot x))
  632. (define is-proper? #t)
  633. ;; local alias
  634. (define (add-prop/req form)
  635. (wisp-add-source-properties-from/when-required code form))
  636. (wisp-add-source-properties-from/when-required
  637. code
  638. (let ((improper
  639. (match code
  640. ((a ... b (? dot?) c)
  641. (set! is-proper? #f)
  642. (wisp-add-source-properties-from/when-required
  643. code
  644. (append (map wisp-make-improper (map add-prop/req a))
  645. (cons (wisp-make-improper (add-prop/req b))
  646. (wisp-make-improper (add-prop/req c))))))
  647. ((a ...)
  648. (add-prop/req
  649. (map wisp-make-improper (map add-prop/req a))))
  650. (a
  651. a))))
  652. (define (syntax-error li msg)
  653. (raise-exception
  654. (make-exception-from-throw
  655. 'wisp-syntax-error
  656. (list (format #f "incorrect dot-syntax #{.}# in code: ~A: ~A" msg li)))))
  657. (if is-proper?
  658. improper
  659. (let check ((tocheck improper))
  660. (match tocheck
  661. ;; lists with only one member
  662. (((? dot?))
  663. (syntax-error tocheck "list with the period as only member"))
  664. ;; list with remaining dot.
  665. ((a ...)
  666. (if (and (member repr-dot a))
  667. (syntax-error tocheck "leftover period in list")
  668. (map check a)))
  669. ;; simple pair - this and the next do not work when parsed from wisp-scheme itself. Why?
  670. (((? dot?) . c)
  671. (syntax-error tocheck "dot as first element in already improper pair"))
  672. ;; simple pair, other way round
  673. ((a . (? dot?))
  674. (syntax-error tocheck "dot as last element in already improper pair"))
  675. ;; more complex pairs
  676. ((? pair? a)
  677. (let ((head (drop-right a 1))
  678. (tail (last-pair a)))
  679. (cond
  680. ((eq? repr-dot (car tail))
  681. (syntax-error tocheck "equal? repr-dot : car tail"))
  682. ((eq? repr-dot (cdr tail))
  683. (syntax-error tocheck "equal? repr-dot : cdr tail"))
  684. ((memq repr-dot head)
  685. (syntax-error tocheck "member repr-dot head"))
  686. (else
  687. a))))
  688. (a
  689. a)))))))
  690. (define (wisp-scheme-read-chunk port)
  691. "Read and parse one chunk of wisp-code"
  692. (with-fluids ((%read-hash-procedures (fluid-ref %read-hash-procedures)))
  693. (read-hash-extend #\# (lambda args #\#))
  694. (let ((lines (wisp-scheme-read-chunk-lines port)))
  695. (wisp-make-improper
  696. (wisp-replace-empty-eof
  697. (wisp-unescape-underscore-and-colon
  698. (wisp-replace-paren-quotation-repr
  699. (wisp-propagate-source-properties
  700. (wisp-scheme-indentation-to-parens lines)))))))))
  701. (define (wisp-scheme-read-all port)
  702. "Read all chunks from the given port"
  703. (let loop ((tokens '()))
  704. (cond
  705. ((eof-object? (peek-char port))
  706. tokens)
  707. (else
  708. (loop
  709. (append tokens (wisp-scheme-read-chunk port)))))))
  710. (define (wisp-scheme-read-file path)
  711. (call-with-input-file path wisp-scheme-read-all))
  712. (define (wisp-scheme-read-file-chunk path)
  713. (call-with-input-file path wisp-scheme-read-chunk))
  714. (define (wisp-scheme-read-string str)
  715. (call-with-input-string str wisp-scheme-read-all))
  716. (define (wisp-scheme-read-string-chunk str)
  717. (call-with-input-string str wisp-scheme-read-chunk))