~evhan/beaker

ff2aa6197e1a2e681c4fb02ee53d18ad9e3fe86e — Evan Hanson 3 years ago d65b4f7 0.0.1
Import beaker sources
A LICENSE => LICENSE +25 -0
@@ 0,0 1,25 @@
Copyright (c) 2015-2018, Evan Hanson <evhan@foldling.org>
All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:

  * Redistributions of source code must retain the above copyright
    notice, this list of conditions and the following disclaimer.
  * Redistributions in binary form must reproduce the above copyright
    notice, this list of conditions and the following disclaimer in the
    documentation and/or other materials provided with the distribution.
  * The name of the author may not be used to endorse or promote products
    derived from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED
WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

A aux/generate-wiki-page.scm => aux/generate-wiki-page.scm +17 -0
@@ 0,0 1,17 @@
#!/bin/sh
#|
exec csi -s "$0" "$@"
|#

(import (beaker wiki))
(import (only (chicken port) make-concatenated-port))

(define template
  (make-concatenated-port
   (open-input-string "#<#EOF\n")
   (open-input-file "beaker.wiki.in")
   (open-input-string "EOF\n")))

(with-output-to-file "beaker.wiki"
 (lambda ()
   (print (eval (read template)))))

A beaker.egg => beaker.egg +38 -0
@@ 0,0 1,38 @@
((synopsis "Lab supplies for CHICKEN development")
 (license "BSD")
 (category tools)
 (author "Evan Hanson")
 (build-dependencies module-declarations)
 (dependencies
  ;; Disabled until patches are accepted upsteam:
  ; (compile-file "0.1")
  ; (markdown-svnwiki "0.2.2")
  ; (schematic "0.3.1")
  (srfi-1 "0.2")
  (srfi-13 "0.2")
  (srfi-14 "0.2")
  (srfi-69 "0.3")
  (vector-lib "2.0")
  (with-current-directory "1.0.0"))
 (component-options
  (csc-options "-d3" "-O0" "-X" "module-declarations"))
 (components
  (extension beaker
   (modules)
   (source "lib/beaker.scm"))
  (extension beaker.egg.info
   (source "lib/beaker/egg/info.scm"))
  (extension beaker.interactive
   (source "lib/beaker/interactive.scm"))
  (extension beaker.repository
   (source "lib/beaker/repository.scm"))
  (extension beaker.system
   (source "lib/beaker/system.scm")
   (component-dependencies beaker.egg.info beaker.repository))
  ;; See `dependencies` above.
  ; (extension beaker.wiki
  ;  (source "lib/beaker/wiki.scm")
  ;  (component-dependencies beaker.egg.info))
  (program chicken-clean
   (linkage static)
   (component-dependencies beaker.interactive))))

A beaker.wiki.in => beaker.wiki.in +44 -0
@@ 0,0 1,44 @@
== Beaker

Lab supplies for CHICKEN development.

[[toc:]]

== Description

Beaker is a collection of development tools.

It is currently fairly limited, including only a single program and a
small handful of libraries to make development easier. If you have an
idea for something that would be useful to include, don't hesitate to
contact the [[##author|author]].

== Dependencies

#(document-dependencies "beaker.egg")

== Programs

=== chicken-clean

#(document-program "chicken-clean.scm" "./chicken-clean -help")

== Extensions

=== Repository Management

#(document-extension "lib/beaker/repository.scm")

=== Systems

#(document-extension "lib/beaker/system.scm")

== Author

[[/users/evan-hanson|Evan Hanson]]

== License

#(document-license "LICENSE")

[[tags: egg]]

A chicken-clean.scm => chicken-clean.scm +105 -0
@@ 0,0 1,105 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Clean up build artifacts.
;;;
;;; Copyright (c) 2018, Evan Hanson
;;;
;;; See LICENSE for details.
;;;

;;
;; The `chicken-clean` program deletes egg build artifacts.
;;
;; A simple set of file patterns is used to determine what should be
;; deleted. This includes binary objects (`o`, `obj`, `so`, `dll`) and
;; files generated by the CHICKEN toolchain (`build.sh`, `install.sh`,
;; `import.scm`, `inline`, `profile`, `types`).
;;
;; When run with the `-interactive` flag, a confirmation prompt will be
;; displayed before any files are deleted.
;;
(declare
  (module (chicken-clean))
  (import (beaker interactive)
          (chicken condition)
          (chicken errno)
          (chicken file)
          (chicken irregex)
          (chicken pathname)
          (chicken process-context)
          (chicken sort)
          (chicken string)
          (srfi 1)))

(define (disposable-file? path)
  (and (not (directory-exists? path))
       (irregex-match
        `(or ,(glob->sre "*.o")
             ,(glob->sre "*.obj")
             ,(glob->sre "*.so")
             ,(glob->sre "*.dll")
             ,(glob->sre "*.build.sh")
             ,(glob->sre "*.install.sh")
             ,(glob->sre "*.import.scm")
             ,(glob->sre "*.inline")
             ,(glob->sre "*.link")
             ,(glob->sre "*.profile")
             ,(glob->sre "*.types"))
        (pathname-strip-directory path))))

(define (file-removal-summary paths)
  (conc "The following files will be removed:"
        #\newline
        #\newline
        (foldl (lambda (s p) (conc s "  " p #\newline)) "" paths)
        #\newline
        "Continue?"))

(define (disposable-directory? path)
  (and (directory-exists? path)
       ((flip every)
        (directory path)
        (lambda (p)
          (let ((p* (make-pathname path p)))
            (or (disposable-file? p*)
                (disposable-directory? p*)))))))

(define (remove-file path)
  (message 1 (conc "Removing " path))
  (delete-file* path))

(define (remove-directory path)
  (message 1 (conc "Removing " path))
  (condition-case (delete-directory path)
    (e (i/o file)
       (unless (or (= (errno) errno/noent)
                   (= (errno) errno/notempty))
         (signal e)))))

(define (clean-working-directory)
  (let* ((files       (find-files "." test: disposable-file?))
         (directories (find-files "." test: disposable-directory?))
         (sorted      (sort (append files directories) string<?)))
    (when (and (pair? sorted) (prompt (file-removal-summary sorted)))
      (for-each remove-file files)
      (for-each remove-directory directories))))

(define (usage status)
  (message 0 (conc "Usage: " (pathname-file (program-name)) " [-interactive | -quiet | -verbose]"))
  (exit status))

(define (main)
  ((flip for-each)
   (command-line-arguments)
   (lambda (flag)
     (case (string->symbol flag)
       ((-quiet) (verbosity (sub1 (verbosity))))
       ((-verbose) (verbosity (add1 (verbosity))))
       ((-interactive) (interactive #t))
       ((-h -help) (usage 0))
       (else (usage 1)))))
  (clean-working-directory))

(cond-expand
  (compiling (main))
  (else))

A lib/beaker.scm => lib/beaker.scm +94 -0
@@ 0,0 1,94 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Program analysis and linting.
;;;
;;; Copyright (c) 2018, Evan Hanson
;;;
;;; See LICENSE for details.
;;;

(declare
  (module (beaker)))

(define (configure-compiler-extension)
  (import (chicken sort)
          (chicken plist)
          (chicken compiler user-pass)
          (prefix (chicken internal) internal-)
          (except (srfi 69) hash-table-for-each)
          (srfi 1)
          (srfi 13))

  (define imported-modules (make-hash-table))
  (define referenced-modules (make-hash-table))

  (define (symbol<? x y)
    (string<? (symbol->string x) (symbol->string y)))

  (define (symbol-namespace sym)
    (and-let* ((str (symbol->string sym))
               (sep (string-index str #\#)))
      (string->symbol (substring str 0 sep))))

  (define (collect-referenced-modules! db)
    ((flip internal-hash-table-for-each)
     db
     (lambda (sym props)
       (and-let* ((n (symbol-namespace sym)))
         (hash-table-set! referenced-modules n 'value)))))

  (define (collect-preprocessor-information! x)
    (let loop ((x x))
      (cond ((symbol? x)
             ((flip for-each)
              (get x '##core#db '())
              (lambda (item)
                (when (eq? (car item) 'syntax)
                  (hash-table-set! referenced-modules (cadr item) 'syntax)))))
            ((atom? x))
            ((eq? (car x) 'import)
             ((flip for-each)
              (cdr x)
              (lambda (i)
                (receive (m . _) (##sys#decompose-import i values eq? 'import)
                  (hash-table-set! imported-modules
                                   m
                                   (or (get-line-number i)
                                       (get-line-number x)))))))
            (else
             (loop (car x))
             (loop (cdr x))))))

  (define (emit severity rule line-number-table items)
    (for-each (lambda (x)
                (write (cons* severity rule x))
                (newline))
              (sort (map (lambda (x)
                           (list (hash-table-ref line-number-table x) x))
                         items)
                    (lambda (x y)
                      (string<? (car x) (car y))))))

  (define (print-analysis-results)
    (let* ((imported   (hash-table-keys imported-modules))
           (referenced (hash-table-keys referenced-modules))
           (difference (lset-difference eq? imported referenced)))
      (parameterize ((current-output-port (current-error-port)))
        (emit 'notice 'import imported-modules imported)
        (emit 'warning 'unnecessary-import imported-modules difference))))

  (user-preprocessor-pass
   (lambda (x)
     (collect-preprocessor-information! x)
     (values x)))

  (user-post-analysis-pass
   (lambda (pass db node get set count continue)
     (when (= count 1)
       (collect-referenced-modules! db)
       (print-analysis-results)))))

(let ()
  (import (chicken platform))
  (when (feature? #:compiler-extension)
    (configure-compiler-extension)))

A lib/beaker/egg/info.scm => lib/beaker/egg/info.scm +48 -0
@@ 0,0 1,48 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Helper procedures for working with egg files.
;;;
;;; Copyright (c) 2018, Evan Hanson
;;;
;;; See LICENSE for details.
;;;

(declare
  (module (beaker egg info))
  (export egg-dependencies
          egg-extensions
          egg-name
          egg-programs)
  (import (chicken condition)
          (chicken pathname)
          (srfi 1)))

(define (egg-name egg-file)
  (string->symbol (pathname-file egg-file)))

(define (egg-info-slot egg-info name)
  (alist-ref name egg-info eq? '()))

(define (read-egg-info egg-file)
  (handle-exceptions _ '() (with-input-from-file egg-file read)))

(define (egg-dependencies egg-file)
  (map (lambda (d) (if (pair? d) (car d) d))
       (egg-info-slot (read-egg-info egg-file) 'dependencies)))

(define (egg-components egg-file #!optional type)
  (let ((egg-info (read-egg-info egg-file)))
    (if (not type)
        (egg-info-slot egg-info 'components)
        (filter-map (lambda (c)
                      (and (pair? c)
                           (pair? (cdr c))
                           (eq? (car c) type)
                           (cadr c)))
                    (egg-info-slot egg-info 'components)))))

(define (egg-extensions egg-file)
  (egg-components egg-file 'extension))

(define (egg-programs egg-file)
  (egg-components egg-file 'program))

A lib/beaker/interactive.scm => lib/beaker/interactive.scm +34 -0
@@ 0,0 1,34 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Helper procedures for command input/output.
;;;
;;; Copyright (c) 2018, Evan Hanson
;;;
;;; See LICENSE for details.
;;;

(declare
  (module (beaker interactive))
  (export interactive verbosity message prompt)
  (import (chicken io) (srfi 13)))

(define verbosity (make-parameter 1))
(define interactive (make-parameter #f))

(define (prompt message #!optional (in (current-input-port)) (out (current-output-port)))
  (or (not (interactive))
      (let loop ((response #f))
        (if (not response)
            (display (string-append message " (yes/no/abort): ") out)
            (display "Please enter one of (yes/no/abort): " out))
        (flush-output out)
        (let ((r (string-trim-both (read-line in))))
          (cond ((string=? r "yes") #t)
                ((string=? r "no") #f)
                ((string=? r "abort") (exit 1))
                (else (loop r)))))))

(define (message level text #!optional (out (current-output-port)))
  (unless (< (verbosity) level)
    (display text out)
    (newline out)))

A lib/beaker/repository.scm => lib/beaker/repository.scm +104 -0
@@ 0,0 1,104 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Procedures to help manage egg repositories.
;;;
;;; Copyright (c) 2018, Evan Hanson
;;;
;;; See LICENSE for details.
;;;

;;
;; The `(beaker repository)` library provides a handful of procedures
;; to help manage egg repositories.
;;
(declare
  (module (beaker repository))
  (export chicken-install create-repository egg-files)
  (import (chicken condition)
          (chicken file)
          (chicken foreign)
          (except (chicken pathname) make-absolute-pathname)
          (chicken platform)
          (chicken process)
          (chicken process-context)
          (srfi 1)))

(define (install-egg-home)
  (foreign-value "C_INSTALL_EGG_HOME" c-string))

;;
;; Returns the full pathname of the `chicken-install` command.
;;
(define (chicken-install)
  (make-pathname
   (foreign-value "C_TARGET_BIN_HOME" c-string)
   (foreign-value "C_CHICKEN_INSTALL_PROGRAM" c-string)))

(define (install-egg-home-files)
  (append (glob (make-pathname (install-egg-home) "/chicken.*.import.so"))
          (glob (make-pathname (install-egg-home) "/srfi-4.import.so"))
          (glob (make-pathname (install-egg-home) "/types.db"))))

;;
;; Returns a list of all egg-info files in the repository path.
;;
;; The `path` argument can be used to specify an alternative repository
;; path, which should be a thunk returning a list of pathname strings.
;;
(define (egg-files #!optional (path repository-path))
  ((flip append-map)
   (path)
   (lambda (repo)
     (filter-map
      (lambda (f)
        (and (equal? (pathname-extension f) "egg-info")
             (make-pathname repo f)))
      (handle-exceptions _ '() (directory repo))))))

(define (make-absolute-pathname path)
  (if (absolute-pathname? path)
      path
      (make-pathname (current-directory) path)))

(define (copy-directory-tree source destination)
  (let* ((source* (make-absolute-pathname source))
         (source-prefix-length (add1 (string-length source*))))
    (find-files
     source*
     action: (lambda (s _)
               (unless (directory-exists? s)
                 (let ((d (make-pathname
                           destination
                           (substring s source-prefix-length))))
                   (create-directory (pathname-directory d) #t)
                   (copy-file s d)))))))

;;
;; Initialises a new egg repository at the pathname `destination`.
;;
;; If the directory `destination` doesn't exist, it is created. The core
;; CHICKEN libraries are then installed into the repository and a new
;; modules database is generated
;;
;; If a `source` repository is given, its contents are also copied into
;; the new repository. This can be used to copy an existing repository
;; to another location.
;;
(define (create-repository destination #!optional source)
  (let ((destination* (make-absolute-pathname destination)))
    (create-directory destination* #t)
    (for-each (lambda (file)
                (copy-file file (pathname-replace-directory file destination*) #t))
              (install-egg-home-files))
    (when (and (string? source) (directory-exists? source))
      (copy-directory-tree source destination*))
    (receive (_ _ status) (process-wait
                           (process-fork
                            (lambda ()
                              (process-execute
                               (chicken-install)
                               (list "-update-db")
                               (list (cons "CHICKEN_REPOSITORY_PATH" destination*)
                                     (cons "CHICKEN_INSTALL_REPOSITORY" destination*))))))
      (unless (zero? status)
        (signal (condition '(exn message "failed to create module database")))))))

A lib/beaker/system.scm => lib/beaker/system.scm +127 -0
@@ 0,0 1,127 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; A system-style API for eggs.
;;;
;;; Copyright (c) 2018, Evan Hanson
;;;
;;; See LICENSE for details.
;;;

;;
;; The `(beaker system)` library provides an API for dynamically
;; building, loading, and reloading extension libraries. It's intended
;; to help enable rapid development in a manner similar to [asdf][] from
;; Common Lisp or the [system][] egg from CHICKEN 4.
;;
;; [asdf]: https://common-lisp.net/project/asdf/asdf/index.html
;; [system]: https://wiki.call-cc.org/eggref/4/system
;;
;; Rather than introduce a new way to define a system's components and
;; dependencies, this library reuses the [egg][] specification format.
;; In fact, you can generally think of a "system" and an "egg" as one
;; and the same.
;;
;; [egg]: http://wiki.call-cc.org/man/5/Egg%20specification%20format
;;
;; An example `csi` session that loads, edits, and reloads an example
;; system might look like the following:
;;
;;     #;> (import (beaker system))
;;     #;> (load-system "example.egg")
;;     building example
;;     ... output ...
;;     ; loading /tmp/temp4871.29489.example.so ...
;;     #;> (load-system "example.egg")
;;     building example
;;     #;> ,e example.scm
;;     #;> (load-system "example.egg")
;;     building example
;;     ... output ...
;;     ; loading /tmp/temp44a2.29609.example.so ...
;;
;; Note that import libraries are not currently considered, so changes
;; to a module's export list will not be reflected when the extension is
;; reloaded.
;;
(declare
  (module (beaker system))
  (export clean-system compile-system load-system)
  (import (beaker egg info)
          (beaker repository)
          (chicken condition)
          (chicken file)
          (chicken file posix)
          (chicken pathname)
          (chicken process)
          (srfi 69)
          (with-current-directory)))

(define *library-table*
  (make-hash-table))

(define (egg-path egg-file)
  (or (pathname-directory egg-file) "."))

(define (compiled-program-path egg-file program)
  (make-pathname (egg-path egg-file) (symbol->string program)))

(define (compiled-extension-path egg-file extension)
  (make-pathname (egg-path egg-file) (symbol->string extension) "so"))

(define (load-extension egg-file extension)
  (let* ((lib (compiled-extension-path egg-file extension))
         (lib-time (file-modification-time lib)))
    (when (< (hash-table-ref/default *library-table* extension 0) lib-time)
      (hash-table-set! *library-table* extension lib-time)
      (let ((tmp (create-temporary-file (pathname-strip-directory lib))))
        (handle-exceptions e
            (begin (delete-file* tmp) (when (condition? e) (signal e)))
          (copy-file lib tmp #t)
          (load tmp)
          (signal 'ok))))))

;;
;; Compiles all out-of-date components for the given egg.
;;
;; This is equivalent to running `chicken-install -no-install`.
;;
(define (compile-system egg-file)
  (with-current-directory
   (egg-path egg-file)
   (lambda ()
     (receive (_ _ status) (process-wait (process-run (chicken-install) (list "-no-install")))
       (unless (zero? status)
         (signal (condition '(exn message "failed to compile system"))))))))

;;
;; Deletes all compiled programs and extension libraries for the given egg.
;;
;; Auxiliary files such as import libraries are preserved.
;;
(define (clean-system egg-file)
  (with-current-directory
   (egg-path egg-file)
   (lambda ()
     (for-each (lambda (x)
                 (delete-file* (compiled-program-path egg-file x)))
               (egg-programs egg-file))
     (for-each (lambda (x)
                 (delete-file* (compiled-extension-path egg-file x)))
               (egg-extensions egg-file)))))

;;
;; Builds and loads the given egg.
;;
;; When called for the first time, all out-of-date components are
;; recompiled and the egg's extension libraries are loaded into the
;; calling program.
;;
;; Subsequent calls cause components to be recompiled to be reloaded as
;; necessary.
;;
(define (load-system egg-file #!key (skip '()))
  (compile-system egg-file)
  (for-each (lambda (x)
              (unless (memq x skip)
                (load-extension egg-file x)))
            (egg-extensions egg-file)))

A lib/beaker/wiki.scm => lib/beaker/wiki.scm +77 -0
@@ 0,0 1,77 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Generate wiki documentation.
;;;
;;; Copyright (c) 2018, Evan Hanson
;;;
;;; See LICENSE for details.
;;;

(declare
  (module (beaker wiki))
  (export document-dependencies
          document-extension
          document-license
          document-program)
  (import (beaker egg info)
          (chicken io)
          (chicken pathname)
          (chicken port)
          (chicken process)
          (chicken process-context)
          (chicken read-syntax)
          (chicken string)
          (markdown-svnwiki)
          (schematic extract)
          (srfi 13)))

;;
;; Reads Scheme source from `input` and writes wiki documentation
;; fragments to `output`.
;;
;; If no arguments are given, `input` and `output` default to
;; the `(current-input-port)` and `(current-output-port)`.
;;
(define (generate-documentation #!optional input output)
  (let* ((buffer  (open-output-string))
         (input*  (or input (current-input-port)))
         (output* (or output (current-output-port)))
         (_       (extract-definitions '(";;") #t input* buffer))
         (buffer* (open-input-string (get-output-string buffer))))
    (parameterize ((current-input-port buffer*)
                   (current-output-port output*))
      (do ((x (read) (read)))
          ((eof-object? x))
        (for-each (lambda (d)
                    (unless (eq? (car d) 'declaration)
                      (print "<" (car d) ">" (cdr d) "</" (car d) ">")))
                  (cdr x))
        (newline)
        (markdown->svnwiki (car x))))))

(define (document-file file)
  (string-trim-both
   (with-input-from-file file
    (lambda ()
      (with-output-to-string generate-documentation)))))

(define (document-command command)
  (string-append " " (string-trim-both (with-input-from-pipe command read-string))))

(define (document-extension file)
  (document-file file))

(define (document-program file command)
  (string-append (document-command command) "\n\n" (document-file file)))

(define (document-dependencies egg-file)
  (string-intersperse
   (map (lambda (d) (conc "* [[/eggref/5/" d "|" d "]]"))
        (egg-dependencies egg-file))
   "\n"))

(define (document-license file)
  (string-intersperse
   (map (lambda (l) (string-append " " l))
        (with-input-from-file file read-lines))
   "\n"))