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