Commit | Line | Data |
---|---|---|
f2e4805b | 1 | ;;; GNU Guix --- Functional package management for GNU |
3b4d7cdc | 2 | ;;; Copyright © 2016, 2017, 2020 Ludovic Courtès <ludo@gnu.org> |
bae06364 | 3 | ;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il> |
0db2ff65 | 4 | ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> |
f2e4805b LC |
5 | ;;; |
6 | ;;; This file is part of GNU Guix. | |
7 | ;;; | |
8 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
9 | ;;; under the terms of the GNU General Public License as published by | |
10 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
11 | ;;; your option) any later version. | |
12 | ;;; | |
13 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
14 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
15 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
16 | ;;; GNU General Public License for more details. | |
17 | ;;; | |
18 | ;;; You should have received a copy of the GNU General Public License | |
19 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
20 | ||
21 | (define-module (guix build bournish) | |
22 | #:use-module (system base language) | |
23 | #:use-module (system base compile) | |
24 | #:use-module (system repl command) | |
25 | #:use-module (system repl common) | |
26 | #:use-module (ice-9 rdelim) | |
27 | #:use-module (ice-9 match) | |
28 | #:use-module (ice-9 ftw) | |
29 | #:use-module (srfi srfi-1) | |
bae06364 | 30 | #:use-module (srfi srfi-11) |
f2e4805b LC |
31 | #:use-module (srfi srfi-26) |
32 | #:export (%bournish-language)) | |
33 | ||
34 | ;;; Commentary: | |
35 | ;;; | |
36 | ;;; This is a super minimal Bourne-like shell language for Guile. It is meant | |
37 | ;;; to be used at the REPL as a rescue shell. In a way, this is to Guile what | |
38 | ;;; eshell is to Emacs. | |
39 | ;;; | |
40 | ;;; Code: | |
41 | ||
42 | (define (expand-variable str) | |
43 | "Return STR or code to obtain the value of the environment variable STR | |
44 | refers to." | |
45 | ;; XXX: No support for "${VAR}". | |
46 | (if (string-prefix? "$" str) | |
47 | `(or (getenv ,(string-drop str 1)) "") | |
48 | str)) | |
49 | ||
50 | (define* (display-tabulated lst | |
1812205c LC |
51 | #:key |
52 | (terminal-width 80) | |
53 | (column-gap 2)) | |
54 | "Display the list of string LST in as many columns as needed given | |
55 | TERMINAL-WIDTH. Use COLUMN-GAP spaces between two subsequent columns." | |
f2e4805b | 56 | (define len (length lst)) |
1812205c LC |
57 | (define column-width |
58 | ;; The width of a column. Assume all the columns have the same width | |
59 | ;; (GNU ls is smarter than that.) | |
60 | (+ column-gap (reduce max 0 (map string-length lst)))) | |
61 | (define columns | |
62 | (max 1 | |
63 | (quotient terminal-width column-width))) | |
f2e4805b LC |
64 | (define pad |
65 | (if (zero? (modulo len columns)) | |
66 | 0 | |
67 | columns)) | |
68 | (define items-per-column | |
69 | (quotient (+ len pad) columns)) | |
70 | (define items (list->vector lst)) | |
71 | ||
72 | (let loop ((indexes (unfold (cut >= <> columns) | |
73 | (cut * <> items-per-column) | |
74 | 1+ | |
75 | 0))) | |
76 | (unless (>= (first indexes) items-per-column) | |
77 | (for-each (lambda (index) | |
78 | (let ((item (if (< index len) | |
79 | (vector-ref items index) | |
80 | ""))) | |
81 | (display (string-pad-right item column-width)))) | |
82 | indexes) | |
83 | (newline) | |
84 | (loop (map 1+ indexes))))) | |
85 | ||
3b4d7cdc LC |
86 | (define-syntax define-command-runtime |
87 | (syntax-rules () | |
88 | "Define run-time support of a Bournish command. This macro ensures that | |
89 | the implementation is not subject to inlining, which would prevent compiled | |
90 | code from referring to it via '@@'." | |
91 | ((_ (command . args) body ...) | |
92 | (define-command-runtime command (lambda args body ...))) | |
93 | ((_ command exp) | |
94 | (begin | |
95 | (define command exp) | |
96 | ||
97 | ;; Prevent inlining of COMMAND. | |
98 | (set! command command))))) | |
99 | ||
100 | (define-command-runtime ls-command-implementation | |
f2e4805b LC |
101 | ;; Run-time support procedure. |
102 | (case-lambda | |
103 | (() | |
104 | (display-tabulated (scandir "."))) | |
105 | (files | |
c7d1b061 LC |
106 | (let ((files (append-map (lambda (file) |
107 | (catch 'system-error | |
108 | (lambda () | |
109 | (match (stat:type (lstat file)) | |
110 | ('directory | |
111 | ;; Like GNU ls, list the contents of | |
112 | ;; FILE rather than FILE itself. | |
113 | (match (scandir file | |
114 | (match-lambda | |
115 | ((or "." "..") #f) | |
116 | (_ #t))) | |
117 | (#f | |
118 | (list file)) | |
119 | ((files ...) | |
120 | (map (cut string-append file "/" <>) | |
121 | files)))) | |
122 | (_ | |
123 | (list file)))) | |
124 | (lambda args | |
125 | (let ((errno (system-error-errno args))) | |
126 | (format (current-error-port) "~a: ~a~%" | |
127 | file (strerror errno)) | |
128 | '())))) | |
129 | files))) | |
f2e4805b LC |
130 | (display-tabulated files))))) |
131 | ||
132 | (define (ls-command . files) | |
133 | `((@@ (guix build bournish) ls-command-implementation) ,@files)) | |
134 | ||
135 | (define (which-command program) | |
136 | `(search-path ((@@ (guix build bournish) executable-path)) | |
137 | ,program)) | |
138 | ||
139 | (define (cat-command file) | |
140 | `(call-with-input-file ,file | |
141 | (lambda (port) | |
142 | ((@ (guix build utils) dump-port) port (current-output-port)) | |
143 | *unspecified*))) | |
144 | ||
0db2ff65 RW |
145 | (define (rm-command . args) |
146 | "Emit code for the 'rm' command." | |
147 | (cond ((member "-r" args) | |
148 | `(for-each (@ (guix build utils) delete-file-recursively) | |
149 | (list ,@(delete "-r" args)))) | |
150 | (else | |
151 | `(for-each delete-file (list ,@args))))) | |
152 | ||
bae06364 EF |
153 | (define (lines+chars port) |
154 | "Return the number of lines and number of chars read from PORT." | |
155 | (let loop ((lines 0) (chars 0)) | |
156 | (match (read-char port) | |
157 | ((? eof-object?) ;done! | |
158 | (values lines chars)) | |
159 | (#\newline ;recurse | |
160 | (loop (1+ lines) (1+ chars))) | |
161 | (_ ;recurse | |
162 | (loop lines (1+ chars)))))) | |
163 | ||
164 | (define (file-exists?* file) | |
165 | "Like 'file-exists?' but emits a warning if FILE is not accessible." | |
166 | (catch 'system-error | |
167 | (lambda () | |
168 | (stat file)) | |
169 | (lambda args | |
170 | (let ((errno (system-error-errno args))) | |
171 | (format (current-error-port) "~a: ~a~%" | |
172 | file (strerror errno)) | |
173 | #f)))) | |
174 | ||
175 | (define (wc-print file) | |
176 | (let-values (((lines chars) | |
177 | (call-with-input-file file lines+chars))) | |
178 | (format #t "~a ~a ~a~%" lines chars file))) | |
179 | ||
180 | (define (wc-l-print file) | |
181 | (let-values (((lines chars) | |
182 | (call-with-input-file file lines+chars))) | |
183 | (format #t "~a ~a~%" lines file))) | |
184 | ||
185 | (define (wc-c-print file) | |
186 | (let-values (((lines chars) | |
187 | (call-with-input-file file lines+chars))) | |
188 | (format #t "~a ~a~%" chars file))) | |
189 | ||
3b4d7cdc | 190 | (define-command-runtime (wc-command-implementation . files) |
bae06364 EF |
191 | (for-each wc-print (filter file-exists?* files))) |
192 | ||
3b4d7cdc | 193 | (define-command-runtime (wc-l-command-implementation . files) |
bae06364 EF |
194 | (for-each wc-l-print (filter file-exists?* files))) |
195 | ||
3b4d7cdc | 196 | (define-command-runtime (wc-c-command-implementation . files) |
bae06364 EF |
197 | (for-each wc-c-print (filter file-exists?* files))) |
198 | ||
199 | (define (wc-command . args) | |
200 | "Emit code for the 'wc' command." | |
201 | (cond ((member "-l" args) | |
202 | `((@@ (guix build bournish) wc-l-command-implementation) | |
203 | ,@(delete "-l" args))) | |
204 | ((member "-c" args) | |
205 | `((@@ (guix build bournish) wc-c-command-implementation) | |
206 | ,@(delete "-c" args))) | |
207 | (else | |
208 | `((@@ (guix build bournish) wc-command-implementation) ,@args)))) | |
209 | ||
813bcbc4 LC |
210 | (define (reboot-command . args) |
211 | "Emit code for 'reboot'." | |
212 | ;; Normally Bournish is used in the initrd, where 'reboot' is provided | |
213 | ;; directly by (guile-user). In other cases, just bail out. | |
214 | `(if (defined? 'reboot) | |
215 | (reboot) | |
216 | (begin | |
217 | (format (current-error-port) | |
218 | "I don't know how to reboot, sorry about that!~%") | |
219 | #f))) | |
220 | ||
f2e4805b LC |
221 | (define (help-command . _) |
222 | (display "\ | |
223 | Hello, this is Bournish, a minimal Bourne-like shell in Guile! | |
224 | ||
225 | The shell is good enough to navigate the file system and run commands but not | |
226 | much beyond that. It is meant to be used as a rescue shell in the initial RAM | |
227 | disk and is probably not very useful apart from that. It has a few built-in | |
228 | commands such as 'ls' and 'cd'; it lacks globbing, pipes---everything.\n")) | |
229 | ||
230 | (define %not-colon (char-set-complement (char-set #\:))) | |
231 | (define (executable-path) | |
232 | "Return the search path for programs as a list." | |
233 | (match (getenv "PATH") | |
234 | (#f '()) | |
235 | (str (string-tokenize str %not-colon)))) | |
236 | ||
237 | (define %commands | |
238 | ;; Built-in commands. | |
239 | `(("echo" ,(lambda strings `(list ,@strings))) | |
240 | ("cd" ,(lambda (dir) `(chdir ,dir))) | |
241 | ("pwd" ,(lambda () `(getcwd))) | |
0db2ff65 | 242 | ("rm" ,rm-command) |
f2e4805b LC |
243 | ("cp" ,(lambda (source dest) `(copy-file ,source ,dest))) |
244 | ("help" ,help-command) | |
245 | ("ls" ,ls-command) | |
246 | ("which" ,which-command) | |
bae06364 | 247 | ("cat" ,cat-command) |
813bcbc4 LC |
248 | ("wc" ,wc-command) |
249 | ("reboot" ,reboot-command))) | |
f2e4805b LC |
250 | |
251 | (define (read-bournish port env) | |
252 | "Read a Bournish expression from PORT, and return the corresponding Scheme | |
253 | code as an sexp." | |
8bebe00a LC |
254 | (match (read-line port) |
255 | ((? eof-object? eof) | |
256 | eof) | |
257 | ((= string-tokenize (command args ...)) | |
f2e4805b LC |
258 | (match (assoc command %commands) |
259 | ((command proc) ;built-in command | |
260 | (apply proc (map expand-variable args))) | |
261 | (#f | |
262 | (let ((command (if (string-prefix? "\\" command) | |
263 | (string-drop command 1) | |
264 | command))) | |
265 | `(system* ,command ,@(map expand-variable args)))))))) | |
266 | ||
267 | (define %bournish-language | |
268 | (let ((scheme (lookup-language 'scheme))) | |
f82c5853 LC |
269 | ;; XXX: The 'scheme' language lacks a "joiner", so we add one here. This |
270 | ;; allows us to have 'read-bournish' read one shell statement at a time | |
271 | ;; instead of having to read until EOF. | |
272 | (set! (language-joiner scheme) | |
273 | (lambda (exps env) | |
274 | (match exps | |
275 | (() '(begin)) | |
276 | ((exp) exp) | |
277 | (_ `(begin ,@exps))))) | |
278 | ||
f2e4805b LC |
279 | (make-language #:name 'bournish |
280 | #:title "Bournish" | |
f82c5853 LC |
281 | |
282 | ;; The reader does all the heavy lifting. | |
f2e4805b | 283 | #:reader read-bournish |
f82c5853 LC |
284 | #:compilers `((scheme . ,(lambda (exp env options) |
285 | (values exp env env)))) | |
286 | #:decompilers '() | |
f2e4805b LC |
287 | #:evaluator (language-evaluator scheme) |
288 | #:printer (language-printer scheme) | |
289 | #:make-default-environment | |
290 | (language-make-default-environment scheme)))) | |
291 | ||
292 | ;; XXX: ",L bournish" won't work unless we call our module (language bournish | |
293 | ;; spec), which is kinda annoying, so provide another meta-command. | |
294 | (define-meta-command ((bournish guix) repl) | |
295 | "bournish | |
296 | Switch to the Bournish language." | |
297 | (let ((current (repl-language repl))) | |
298 | (format #t "Welcome to ~a, a minimal Bourne-like shell!~%To switch back, type `,L ~a'.\n" | |
299 | (language-title %bournish-language) | |
300 | (language-name current)) | |
301 | (current-language %bournish-language) | |
302 | (set! (repl-language repl) %bournish-language))) | |
303 | ||
304 | ;;; bournish.scm ends here |