-
Notifications
You must be signed in to change notification settings - Fork 3
/
hash-lang-syntax.lisp
104 lines (89 loc) · 3.4 KB
/
hash-lang-syntax.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
(defpackage :vernacular/hash-lang-syntax
(:use :cl :alexandria :serapeum :vernacular/types)
(:documentation "Parse the #lang line in a module file.")
(:import-from :vernacular/types :vernacular-error)
(:import-from :uiop :file-exists-p)
(:export
:file-hash-lang
:stream-hash-lang
:skip-hash-lang
:read-lang-name
:valid-lang-name?))
(in-package :vernacular/hash-lang-syntax)
(defcondition invalid-lang-name (vernacular-error)
((token :initarg :token))
(:report (lambda (c s)
(with-slots (token) c
(format s "Invalid language name: ~a" token)))))
(defun file-hash-lang (file &key (external-format :utf-8))
"Return two values: the name of the lang (as a string) and the position to start reading from."
(if (not (file-exists-p file))
(values nil 0)
(with-input-from-file (stream file :element-type 'character
:external-format external-format)
(stream-hash-lang stream))))
(-> stream-hash-lang (stream)
(values (or null string) (integer 0 *)))
(defun stream-hash-lang (stream)
(skip-comments-and-whitespace stream)
(flet ((fail () (values nil 0)))
(if (loop for c across "#lang"
always (eql c (peek-char nil stream))
do (read-char stream nil))
(if-let ((lang-form (read-lang-name stream)))
(values lang-form (file-position stream))
(fail))
(fail))))
(defun skip-hash-lang (stream)
(assure (integer 0 *)
(nth-value 1 (stream-hash-lang stream))))
(defun read-lang-name (stream &key errorp)
(skip-whitespace stream)
(assure (or string null)
(let ((token (stream-take-while (complement #'whitespacep) stream)))
(cond ((valid-lang-name? token)
token)
(errorp
(error 'invalid-lang-name :token token))
(t nil)))))
(defun stream-take-while (pred stream)
(with-output-to-string (out)
(loop for char = (read-char stream nil)
for len from 0
do (cond ((null char) (loop-finish))
((funcall pred char) (write-char char out))
(t (unread-char char stream)
(loop-finish))))))
(defun lang-char? (char)
(let ((code (char-code char)))
(or (<= (char-code #\a) code (char-code #\z))
(<= (char-code #\A) code (char-code #\Z))
(<= (char-code #\0) code (char-code #\9))
;; NB #\. is not allowed in Racket.
(in char #\/ #\_ #\- #\+ #\.))))
(defun valid-lang-name? (string)
(and (stringp string)
(every #'lang-char? string)))
(defun skip-comments-and-whitespace (stream)
(loop while (or (skip-whitespace stream) (skip-comment stream))))
(defun skip-whitespace (stream)
(let ((start (file-position stream)))
(peek-char t stream)
(> (file-position stream) start)))
(defun next-char (stream)
(peek-char nil stream))
(defun skip-comment (stream)
(let ((char (next-char stream)))
(cond ((eql char #\;)
(skip-to-end-of-line stream))
((eql char #\#)
(advance-stream 1 stream)
(cond ((eql (next-char stream) #\!)
(skip-to-end-of-line stream))
;; TODO #|, #;.
(t (unread-char #\# stream))))
(t nil))))
(defun skip-to-end-of-line (stream)
(loop until (eql (read-char stream) #\Newline)))
(defun advance-stream (n stream)
(file-position stream (+ n (file-position stream))))