;; 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))))