Snowflake: Snow integration with Guile module system

["Julian Graham" <joolean@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 2281 bytes --]

Hi Schemers,

So, Snow is a wonderful idea (Guile people, go to
http://snow.iro.umontreal.ca/ right now if you haven't checked out
Snow yet), but there are some drawbacks to its approach to library
management.  Among them is the fact that it doesn't integrate with
your Scheme platform's native module system at all -- in fact, Snow
pretty much just concatenates the bodies of all of your library
implementations on load, which leads to problems with symbol name
collisions [1].  And that's kind of okay.

To get the benefit of Snow packages in, say, Guile, though, it's
necessary to make use of the encapsulation that Guile's module system
provides.  To that end, I've whipped up a small Guile module called
(snow snowflake) (because Scheme module systems are all unique, like
snowflakes!) that converts Snow packages to Guile modules and provides
a Snow-compatible mechanism for loading them.  To wit:

snow:package->module! package

...where 'package' is a string giving the name of a Snow package you
have already downloaded and installed via Snow (e.g.,
"fixnum/v1.0.3"), will copy the implementation files from
$SNOW_SITE_DIR to an appropriate subdirectory of %site-dir/snow (i.e.,
%site-dir/snow/packages/[package-name]/[package-version]) and rewrite
the package's metadata as a Guile module definition.

snow:use-modules module-list

...where 'module-list' is a list of symbols giving
(partially-specified) Snow package names -- e.g., (fixnum/v1) or
(srfi13/v1.0.0 srfi14/v1.0) -- will act as a replacement for Guile's
use-modules form, locating the right versions of packages that have
been installed in Guile's load path via snow:package->module!.  Here's
an example:

(load "snowflake.scm")
(use-modules (snow snowflake))

(snow:package->module! "fixnum/v1.0.3")
(snow:package->module! "srfi14/v1.0.1")
(snow:use-modules (srfi14/v1))

I've attached a copy of Snowflake; it works, but just barely -- you
need write access to Guile's site dir, and the code does no error
checking to speak of.  And I'm sure there are plenty of things it
doesn't get quite right, like exported syntax definitions.  Still, I
hope you guys can take a look and tell me what you think.


Regards,
Julian

[1]: https://webmail.iro.umontreal.ca/pipermail/snow-users-list/2007-October/000096.html

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: snowflake.scm --]
[-- Type: text/x-scheme; name=snowflake.scm, Size: 6274 bytes --]

;; Snowflake: Snow integration with Guile module system
;; Copyright (c) 2007 Julian Graham
;;
;; This program 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.
;;
;; This program 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 this program.  If not, see <http://www.gnu.org/licenses/>.

(define-module (snow snowflake)
  #:export (snow:use-modules
	    snow:package->module!)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 pretty-print)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-2)
  #:use-module (srfi srfi-13))

(define %snow-user-dir% "")
(define %snow-site-dir% "")

(define init-lock (make-mutex))
(define initted #f)

(define (init)
  (lock-mutex init-lock)
  (if (not initted)
      (begin
	(and-let* ((sud (getenv "SNOW_USER_DIR"))) (set! %snow-user-dir% sud))
	(and-let* ((ssd (getenv "SNOW_SITE_DIR"))) (set! %snow-site-dir% ssd))
	(set! initted #t)))
  (unlock-mutex init-lock))

(define-macro (snow:use-modules lst)
  (define (list->version vs) (string-append "v" (string-join vs #\.)))
  (define (version->list v) (map string->number
				 (string-split (substring v 1) #\.)))
  (define (match-version package v)
    (let* ((matches 
	    (filter-map 
	     (lambda (x) 
	       (and-let* ((xs (string-append x "/snow/packages/" package))
			  (dir (and (access? xs F_OK) (opendir xs))))
			 (let lp () 
			   (let ((n (readdir dir)))
			     (cond ((eof-object? n) #f)
				   ((string-prefix? v n) n)
				   (else (lp)))))))
	     %load-path)))
      (or (and (not (null? matches))
	       (let ((best-match 
		      (car (sort matches
				 (lambda (x y)
				   (> (length (version->list x))
				      (length (version->list y))))))))
		 (string->symbol best-match)))
	  (error "no code for module" package))))
  `(use-modules ,(map (lambda (module-sym)
			(let* ((s (symbol->string module-sym))
			       (si (string-index s #\/))
			       (n (substring s 0 si))
			       (sn (string->symbol n))
			       (vs (substring s (+ si 1))))
			  (list 'snow 'packages sn (match-version n vs) sn)))
		      lst)))

(define (snow:package->module! pkg)

  (define (mkdirs path)
    (or (access? path F_OK)
	(let ((pes (substring path 0 (string-rindex path #\/))))
	  (mkdirs pes)
	  (mkdir path))))

  (define (copy-dir from-dir to-dir excludes)
    (let ((dirstrm (opendir from-dir)))
      (mkdirs to-dir)
      (let f ((n (readdir dirstrm)))
	(or (eof-object? n)
	    (begin (or (eqv? (string-ref n 0) #\.)
		       (let* ((fn (string-append from-dir "/" n))
			      (tn (string-append to-dir "/" n))
			      (type (stat:type (stat fn))))
			 (or (member n excludes)
			     (cond ((eq? type 'regular) (copy-file fn tn))
				   ((eq? type 'directory) 
				    (copy-dir fn tn))))))
		   (f (readdir dirstrm)))))))

  (define (cexpand exprs)
    (define (test feature)
      (cond ((eq? feature 'else) #t)
	    ((symbol? feature) (eq? feature 'guile))
	    ((and (pair? feature) (list? feature))
	     (case (car feature)
	       ((and) (every test (cdr feature)))
	       ((or) (any test (cdr feature)))
	       ((not) (not (test (cadr feature))))))
	    (else #f)))
    
    (if (pair? exprs)
	(let ((expr (car exprs)))
	  (cond ((and (pair? expr) (eq? (car expr) 'cond-expand))
		 (let loop ((clauses (cdr expr)))
		   (let* ((clause (car clauses))
			  (res (test (car clause))))
		     (if res 
			 (append (cdr clause) (cexpand (cdr exprs)))
			 (loop (cdr clauses))))))
		((and (pair? expr) (eq? (car expr) 'test*))
		 (cexpand (cdr exprs)))
		(else (cons expr (cexpand (cdr exprs))))))
	exprs))
  
  (init)
  (let* ((pkg-dir (string-append %snow-site-dir% "/current/pack"))
	 (name (substring pkg 0 (string-index pkg #\/)))
	 (ver (substring pkg (+ (string-index pkg #\/) 1)))
	 (full-pkg-dir (string-join (list pkg-dir name ver "snow") "/"))
	 (full-pkg-file (string-append full-pkg-dir "/" name ".scm"))
	 (dest-dir (string-join (list (%site-dir) "snow" "packages" name ver)
				"/")))

    (and (access? full-pkg-dir R_OK)
	 (access? full-pkg-file R_OK))
    
    (copy-dir full-pkg-dir dest-dir `(,full-pkg-file))
    (let* ((pred (lambda (x) (lambda (y) (and (list? y) (eq? (car y) x)))))
	   (pf (open-input-file full-pkg-file))
	   (of (open-output-file (string-append dest-dir "/" name ".scm")))
	   (sx (read pf))

	   (sn (string->symbol name))
	   (sv (string->symbol ver))
							   
	   (nsx `(define-module (snow packages ,sn ,sv ,sn)))

	   (procedures (list))
	   (macros (list)))
      
     
      (for-each (lambda (x) 
		  (let ((cx (cadr x))
			(type (car x)))
		    (if (eq? type 'define-macro)
			(set! macros (append macros `(,x)))
			(set! procedures (append procedures `(,x))))))
		(cexpand (cdr (find (pred 'provide:) 
				    (cddr sx)))))

      (or (null? procedures) 
	  (append! nsx (list #:export (map (lambda (x) 
					     (let ((y (cadr x)))
					       (if (pair? y) (car y) y)))
					   procedures))))
      (or (null? macros) 
	  (append! nsx (list #:export-syntax (map (lambda (x) (caadr x))
						  macros))))
	       
      (pretty-print nsx of)
      (newline of)
      (let ((requirements (map cadr (filter (pred 'require:) (cddr sx)))))
	(or (null? requirements)
	    (begin (pretty-print `(use-modules (snow snowflake)) of)
		   (pretty-print `(snow:use-modules ,requirements) of))))
      (for-each (lambda (x) (pretty-print x of)) macros)
      (pretty-print '(define-macro include* load) of)
      (pretty-print '(define-macro (test* . exprs)
		       (eval (if (null? (cdr exprs)) 
				 (car exprs) 
				 (cons 'begin exprs))
			     (interaction-environment)))
		    of)
      (pretty-print '(define-macro (expect* expr)
		       (false-if-exception ,expr)) 
		    of)
      (do ((c (read-line pf 'split) (read-line pf 'split)))
	  ((eof-object? (cdr c)) (close of))
	(write-line (car c) of))

      (close pf)
      (close of))))

[-- Attachment #3: Type: text/plain, Size: 140 bytes --]

_______________________________________________
Guile-user mailing list
Guile-user@gnu.org
http://lists.gnu.org/mailman/listinfo/guile-user