aboutsummaryrefslogtreecommitdiff
path: root/doc/skribilo.scm
blob: 972b626fc1944b7d119d68591f5d31add54cef57 (plain)
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
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
;;; guix-forge --- Guix software forge meta-service
;;; Copyright © 2022–2023 Arun Isaac <arunisaac@systemreboot.net>
;;;
;;; This file is part of guix-forge.
;;;
;;; guix-forge is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published
;;; by the Free Software Foundation, either version 3 of the License,
;;; or (at your option) any later version.
;;;
;;; guix-forge 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
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with guix-forge.  If not, see
;;; <https://www.gnu.org/licenses/>.

(define-module (doc skribilo)
  #:use-module (rnrs conditions)
  #:use-module (rnrs io ports)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-28)
  #:use-module (srfi srfi-171)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (texinfo)
  #:use-module (skribilo ast)
  #:use-module (skribilo engine)
  #:use-module (skribilo lib)
  #:use-module (skribilo output)
  #:use-module (skribilo writer)
  #:use-module (skribilo package base)
  #:use-module (skribilo parameters)
  #:use-module (skribilo source lisp)
  #:use-module (skribilo utils keywords)
  #:export (file
            command
            scheme-source
            scheme-source-form
            source-ref
            record-documentation
            record-field
            record-ref
            docstring-function-documentation))

;; Constants
(define %source-uri-base
  "https://git.systemreboot.net/guix-forge/tree/")

;; Aliases
(define file samp)
(define command code)

;; Abbreviations
(define-markup (abbr #:rest opts
		     #:key (ident #f) (class "abbr") (short #f) (long #f))
  (new container
       (markup 'abbr)
       (ident (or ident (symbol->string (gensym "abbr"))))
       (class class)
       (loc &invocation-location)
       (required-options '(#:short #:long))
       (options `((#:short ,short)
		  (#:long ,long)
		  ,@(the-options opts #:ident #:class #:short #:long)))
       (body (the-body opts))))

;; Create a dummy G-expression reader to avoid reader errors when
;; reading source files for source-ref, record-documentation, etc.
(read-hash-extend #\~ (const #t))

;; S-exp source links
(define (source-uri file start-line end-line)
  "Return a URI referring to source FILE from START-LINE to END-LINE."
  (string-append %source-uri-base
                 file
                 "#n"
                 (number->string start-line)))

(define (sexp-position str regexp)
  "Return (START . END) where START is the start of the match to
REGEXP in STR and END is the end of the sexp beginning at START. START
and END are character positions indexed from 0. If multiple matches
are found, error out."
  (cond
   ((string-match regexp str)
    => (lambda (match-struct)
         (let ((start (match:start match-struct)))
           (if (string-match regexp (substring str (1+ start)))
               (raise-exception (condition (make-message-condition
                                            (format "source-ref: regexp ~s found on multiple lines"
                                                    regexp))
                                           (make-irritants-condition regexp)))
               (cons start
                     (1- (- (string-length str)
                            (string-length
                             (call-with-input-string (substring str start)
                               (lambda (port)
                                 (read port)
                                 (get-string-all port)))))))))))
   (else
    (raise-exception (condition (make-message-condition
                                 (format "source-ref: regexp ~s not found" regexp))
                                (make-irritants-condition regexp))))))

(define (position->line-number str position)
  "Return the line number in STR corresponding to POSITION."
  (string-fold (lambda (c result)
                 (if (char=? c #\newline)
                     (1+ result)
                     result))
               1
               (substring str 0 position)))

(define (sexp-file-lines file regexp)
  "Return (START . END) where START is the start of the match to
REGEXP in STR and END is the end of the sexp beginning at START. START
and END are line numbers indexed from 1."
  (let ((str (call-with-input-file file get-string-all)))
    (match (sexp-position str regexp)
      ((start . end)
       (cons (position->line-number str start)
             (position->line-number str end))))))

(define (source-ref file regexp text)
  "Link to S-expression in FILE whose beginning matches REGEXP. TEXT
is the text of the link."
  (ref #:url (match (sexp-file-lines (search-path (*source-path*) file)
                                     regexp)
               ((start-line . end-line)
                (source-uri file start-line end-line)))
       #:text text))

;; Extract forms from scheme source
(define (scheme-source-form file regexp)
  "Extract form from scheme source FILE whose beginning matches
REGEXP. Return it enclosed in a prog form."
  (prog (match (sexp-file-lines (search-path (*source-path*) file)
                                regexp)
          ((start . stop)
           (source #:language scheme
                   #:file file
                   #:start (1- start)
                   #:stop (1- stop))))
        #:line #f))

(define-record-type <record>
  (record identifier fields)
  record?
  (identifier record-identifier)
  (fields record-fields))

(define-record-type <no-default>
  (no-default)
  no-default?)

(define-record-type <record-field>
  (make-record-field identifier getter default documentation)
  record-field?
  (identifier record-field-identifier)
  (getter record-field-getter)
  (default record-field-default)
  (documentation record-field-documentation))

(define (field-sexp->record-field sexp)
  "Return a <record-field> object describing the Guix record defined
by SEXP, an S-expression."
  (match sexp
    ((identifier getter other ...)
     (make-record-field identifier
                        getter
                        (fold (lambda (element result)
                                (match element
                                  (('default default) default)
                                  (_ result)))
                              (no-default)
                              other)
                        #f))))

(define (record-sexp->record sexp)
  "Convert SEXP defining a Guix record type to a <record> object
describing it."
  (match sexp
    (('define-record-type* identifier rest ...)
     (record identifier
             (map field-sexp->record-field
                  (drop-while symbol? rest))))))

(define (find-record-definition file identifier)
  "Find record identified by IDENTIFIER, a symbol, in FILE."
  (call-with-input-file file
    (cut port-transduce
         (tmap identity)
         (rany (lambda (sexp)
                 (match sexp
                   (('define-record-type* record-type _ ...)
                    (and (eq? record-type identifier)
                         (record-sexp->record sexp)))
                   (_ #f))))
         read
         <>)))

(define* (record-field identifier documentation #:key default)
  "Document record field identified by IDENTIFIER, a symbol, with the
DOCUMENTATION string. DEFAULT is an optional textual description of
the default value. DEFAULT, when specified, will override the default
value extracted from the source."
  (make-record-field identifier #f default documentation))

(define (quoted-write object port)
  "Write @var{object} to @var{port} printing quoted expressions using
the quote character."
  (match object
    (('quote child)
     (display "'" port)
     (quoted-write child port))
    ((parent children ...)
     (display "(" port)
     (display (string-join (map expression->string object))
              port)
     (display ")" port))
    (_ (write object port))))

(define (expression->string exp)
  "Return EXP as a human-readable string. In particular, quote forms
are printed using the quote symbol."
  (call-with-output-string
    (cut quoted-write exp <>)))

(define (record-documentation file identifier . fields)
  "Document record identified by IDENTIFIER, a symbol, in FILE. FIELDS
are a list of <record-field> objects."
  (let ((record (or (find-record-definition (search-path (*source-path*) file)
                                            identifier)
                    (raise-exception (condition (make-message-condition
                                                 (format "Unknown record ~a in ~a"
                                                         identifier file)))))))
    ;; Run sanity checks.
    (let* ((documented-fields (map (compose string->symbol record-field-identifier)
                                   fields))
           (fields-in-record (map record-field-identifier
                                  (record-fields record)))
           (undocumented-fields (lset-difference eq? fields-in-record documented-fields))
           (unknown-fields (lset-difference eq? documented-fields fields-in-record)))
      (unless (null? undocumented-fields)
        (raise-exception (condition (make-message-condition
                                     (format "Undocumented fields ~a in ~a record documentation"
                                             undocumented-fields
                                             identifier))
                                    (make-irritants-condition undocumented-fields))))
      (unless (null? unknown-fields)
        (raise-exception (condition (make-message-condition
                                     (format "Unknown fields ~a in ~a record documentation"
                                             unknown-fields
                                             identifier))
                                    (make-irritants-condition unknown-fields)))))
    ;; Generate markup.
    (let ((identifier (symbol->string identifier)))
      (item #:ident identifier
            #:key (list (list "Record Type: "
                              (index #:note "record type" identifier)
                              (source-ref file
                                          (string-append "\\(define-record-type\\* " identifier)
                                          (code identifier))))
            (apply description
                   (map (lambda (documented-field)
                          (let* ((identifier (record-field-identifier documented-field))
                                 (record-field (find (lambda (field)
                                                       (eq? (record-field-identifier field)
                                                            (string->symbol identifier)))
                                                     (record-fields record))))
                            (item #:key
                                  (cond
                                   ;; No default value
                                   ((no-default? (record-field-default record-field))
                                    (code identifier))
                                   ;; Default value in documentation
                                   ((record-field-default documented-field)
                                    => (lambda (default)
                                         (list (append (list (code identifier) " (Default: ")
                                                       default
                                                       (list ")")))))
                                   ;; Default value from the source
                                   (else (list (list (code identifier) " (Default: "
                                                     (code (expression->string
                                                            (record-field-default record-field)))
                                                     ")"))))
                                  (record-field-documentation documented-field))))
                        fields))))))

(define (record-ref identifier)
  "Link to record documentation of record identified by
@var{identifier}."
  (ref #:ident identifier
       #:text (code identifier)))

(define-record-type <function>
  (function name arguments docstring)
  function?
  (name function-name)
  (arguments function-arguments)
  (docstring function-docstring))

(define (find-function-definition file name)
  "Return a @code{<function>} object describing a function named
@var{name} in @var{file}."
  (call-with-input-file file
    (cut port-transduce
         (tmap identity)
         (rany (match-lambda
                 (((or 'define 'define* 'define-lazy)
                   ((? (cut eq? name <>)) arguments ...)
                    docstring
                    body ...)
                  (function name arguments docstring))
                 (_ #f)))
         read
         <>)))

(define (stexi->skribe stexi)
  "Convert @var{stexi}, a stexinfo tree, to a skribe tree."
  (match stexi
    (('*fragment* children ...)
     (map stexi->skribe children))
    (('para children ...)
     (cons 'paragraph children))))

(define (docstring-function-documentation file name)
  "Document function of @var{name} from @var{file} using its docstring."
  (let ((function (or (find-function-definition file name)
                      (error "Function not found in file:" name file))))
    (item #:key (code (list "("
                            (bold (symbol->string name))
                            (unless (null? (function-arguments function))
                              " ")
                            (string-join (map expression->string
                                              (function-arguments function)))
                            ")"))
          (map (cut eval <> (current-module))
               (stexi->skribe
                (texi-fragment->stexi
                 (function-docstring function)))))))

(define (node->html-tag tag node)
  "Output starting HTML @var{tag} of @var{node}."
  (display
   (format "<~a ~a>"
           tag
           (string-join (map (match-lambda
                               ((key . value)
                                (format "~a=\"~a\"" key value)))
                             (append (if (and (markup? node)
                                              (markup-ident node))
                                         (list (cons "id" (markup-ident node)))
                                         (list))
                                     (if (and (markup? node)
                                              (markup-class node))
                                         (list (cons "class" (markup-class node)))
                                         (list))))))))

;; HTML engine customizations
(let ((html-engine (find-engine 'html)))
  (engine-custom-set! html-engine 'css "/style.css")
  (engine-custom-set! html-engine 'charset "UTF-8")
  (markup-writer 'abbr html-engine
    #:options '(#:short #:long)
    #:action (lambda (markup engine)
               (display (format "<abbr title=\"~a\">~a</abbr> (~a)"
                                (markup-option markup #:long)
                                (markup-option markup #:short)
                                (markup-option markup #:long))
                        (current-output-port))))
  ;; The skribilo HTML engine description markup writer does not print
  ;; the id attribute. Override it so that it does. TODO: Push this
  ;; fix to skribilo upstream.
  (markup-writer 'description html-engine
    #:options '(#:symbol)
    #:before (lambda (node engine)
               (node->html-tag "dl" node))
    #:action (lambda (node engine)
	       (for-each (lambda (item)
			   (for-each (lambda (key)
                                       (node->html-tag "dt" item)
				       (output key engine)
				       (display "</dt>"))
                                     (match (markup-option item #:key)
                                       ((keys ...) keys)
                                       (key (list key))))
                           (node->html-tag "dd" item)
			   (output (markup-body item) engine)
			   (display "</dd>\n"))
			 (markup-body node)))
    #:after "</dl>"))