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

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

@ -276,7 +276,9 @@
(equal? base (take dep (length base)))
;; TODO: find-library(-relative)
(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))))
(define (package-docs cfg spec libs)
@ -295,6 +297,27 @@
libs))
(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)
(conf-get cfg '(command package test)))
@ -315,19 +338,21 @@
(package-output-version cfg))))
(define (package-spec+files cfg spec libs)
(let ((recursive? (conf-get cfg '(command package recursive?)))
(docs (package-docs cfg spec libs))
(test (package-test cfg))
(version (package-output-version cfg)))
(let* ((recursive? (conf-get cfg '(command package recursive?)))
(docs (package-docs cfg spec libs))
(desc (package-description cfg spec libs docs))
(test (package-test cfg))
(version (package-output-version cfg)))
(let lp ((ls (map (lambda (x) (cons x #f)) libs))
(res
`(,@(if (pair? docs)
`((doc ,@(map
(lambda (x)
(path-strip-leading-parents
(if (pair? x) (cadr x) x)))
docs)))
`((manual ,@(map
(lambda (x)
(path-strip-leading-parents
(if (pair? x) (cadr x) x)))
docs)))
'())
,@(if desc `((description ,desc)) '())
,@(if test `((test ,(path-strip-leading-parents test))) '())
,@(if version `((version ,version)) '())))
(files