Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-11 06:57:33 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Adding description to packages, inferred from docs where possible.

Browse source
This commit is contained in:
Alex Shinn 2014-06-23 23:12:39 +09:00
parent 7668d5ebad
commit c008dc6dd1
1 changed files with 35 additions and 10 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

31
lib/chibi/snow/commands.scm
View file

@ -276,7 +276,9 @@
(equal? base (take dep (length base))) (equal? base (take dep (length base)))
;; TODO: find-library(-relative) ;; TODO: find-library(-relative)
(let* ((dir (library-path-base file lib)) (let* ((dir (library-path-base file lib))
(dep-file (make-path dir (library-name->path dep)))) (dep-file (make-path dir (string-append
(library-name->path dep)
".sld"))))
(and (file-exists? dep-file) dep-file)))) (and (file-exists? dep-file) dep-file))))
(define (package-docs cfg spec libs) (define (package-docs cfg spec libs)
@ -295,6 +297,27 @@
libs)) libs))
(else '()))) (else '())))
(define (package-description cfg spec libs docs)
(cond
((conf-get cfg '(command package description)))
;; Crazy hack, make this more robust, probably opt-in.
((and (pair? docs) (pair? (car docs)) (eq? 'inline (caar docs))
(regexp-search
'(: "<p>" (* "\n") (* space) ($ (* (~ ("."))) "."))
(third (car docs))))
=> (lambda (m)
(let ((s (regexp-match-submatch m 1)))
(and s
(regexp-replace-all
'(>= 2 space)
(regexp-replace-all
"\n"
(regexp-replace-all '(: "<" (? "/") (* (~ ("<>"))) ">")
s "")
" ")
" ")))))
(else #f)))
(define (package-test cfg) (define (package-test cfg)
(conf-get cfg '(command package test))) (conf-get cfg '(command package test)))
@ -315,19 +338,21 @@
(package-output-version cfg)))) (package-output-version cfg))))
(define (package-spec+files cfg spec libs) (define (package-spec+files cfg spec libs)
(let ((recursive? (conf-get cfg '(command package recursive?))) (let* ((recursive? (conf-get cfg '(command package recursive?)))
(docs (package-docs cfg spec libs)) (docs (package-docs cfg spec libs))
(desc (package-description cfg spec libs docs))
(test (package-test cfg)) (test (package-test cfg))
(version (package-output-version cfg))) (version (package-output-version cfg)))
(let lp ((ls (map (lambda (x) (cons x #f)) libs)) (let lp ((ls (map (lambda (x) (cons x #f)) libs))
(res (res
`(,@(if (pair? docs) `(,@(if (pair? docs)
`((doc ,@(map `((manual ,@(map
(lambda (x) (lambda (x)
(path-strip-leading-parents (path-strip-leading-parents
(if (pair? x) (cadr x) x))) (if (pair? x) (cadr x) x)))
docs))) docs)))
'()) '())
,@(if desc `((description ,desc)) '())
,@(if test `((test ,(path-strip-leading-parents test))) '()) ,@(if test `((test ,(path-strip-leading-parents test))) '())
,@(if version `((version ,version)) '()))) ,@(if version `((version ,version)) '())))
(files (files