;;;; s48-modules.scm


(module s48-modules (define-structure define-interface
		      define-structures include-relative)

  (import scheme 
	  (except chicken define-interface)
	  srfi-1
	  files)

  (begin-for-syntax
   (require 'srfi-1 'files)
   (define s48-modules:*interfaces* '()) )

  ;; Evil hackery to get around the way INCLUDE works
  (define-for-syntax s48-modules:*current-file* #f)

  (define-syntax s48-modules:set-current-file!
    (lambda (x r c)
      (set! s48-modules:*current-file* (cadr x))
      `(,(r 'begin))) )

  (define-for-syntax (s48-modules:get-current-file)
    (or s48-modules:*current-file*
        (and (feature? #:compiling) ##compiler#source-filename)
        ##sys#current-source-filename))

  (define-syntax include-relative
    (lambda (x r c)
      (let* ((old-file (s48-modules:get-current-file))
             (file (make-pathname
                   (if old-file
                       (pathname-directory old-file)
                       ".")
                   (cadr x))))
        `(,(r 'begin)
          (,(r 's48-modules:set-current-file!) ,file)
          (,(r 'include) ,file)
          (,(r 's48-modules:set-current-file!) ,old-file) ) )) )

  (define-for-syntax (s48-modules:parse-interface loc iface r c)
    (let ((iface (##sys#strip-syntax iface)))
      (define (fail)
	(syntax-error loc "invalid interface specification" iface))
      (let parse ((iface iface))
	(cond ((symbol? iface)
	       (let ((a (assq iface s48-modules:*interfaces*)))
		 (if a
		     (cdr a)
		     (fail))))
	      ((or (not (list? iface)) (not (pair? iface))) (fail))
	      ((c (r 'export) (car iface))
	       (map (lambda (sym)  ;; collapse  '(name :type) => 'name
                      (if (pair? sym) (car sym) sym))
                    (cdr iface)))
	      ((c (r 'compound-interface) (car iface))
	       (delete-duplicates
		(append-map parse (cdr iface)) 
		eq?))
	      (else (fail))))))

  (define-syntax define-interface
    (lambda (x r c)
      (when (or (not (= 3 (length x)))
		(not (symbol? (cadr x)) ) )
	(syntax-error 'define-interface "invalid interface declaration" x))
      `(,(r 'begin-for-syntax)
	(,(r 'set!) s48-modules:*interfaces* 
	 (,(r 'alist-cons)
	  ',(##sys#strip-syntax (cadr x))
	  ',(s48-modules:parse-interface 'define-interface (caddr x) r c)
	  s48-modules:*interfaces*)))))

  (define-syntax define-structure
    (syntax-rules ()
      ((_ name iface body ...)
       (define-structures ((name iface)) body ...))))
  
  (define-syntax define-structures
    (lambda (x r c)
      (##sys#check-syntax 'define-structures x '(_ #((symbol _) 1) . #(_ 0)))
      (let* ((%open (r 'open))
	     (%for-syntax (r 'for-syntax))
	     (%files (r 'files))
	     (%begin (r 'begin))
	     (%begin-for-syntax (r 'begin-for-syntax))
	     (%subset (r 'subset))
	     (%with-prefix (r 'with-prefix))
	     (%modify (r 'modify))
	     (%expose (r 'expose))
	     (%hide (r 'hide))
	     (%only (r 'only))
	     (%except (r 'except))
	     (%rename (r 'rename))
	     (%prefix (r 'prefix))
	     (%module (r 'module))
	     (%include-relative (r 'include-relative))
	     (%import (r 'import))
	     (%import-for-syntax (r 'import-for-syntax))
	     (heads (cadr x))
	     (defs '())
	     (iname1 (string->symbol (string-append "_" (symbol->string (caar heads))))))
	(define (process1 head)
	  (let ((name (car head))
		(exports (s48-modules:parse-interface 'define-structures (cadr head) r c)))
	    `(,%module ,name ,exports (,%import ,iname1))))
	(define (parse-struct spec)
	  (cond ((symbol? spec) spec)
		((or (not (list? spec)) (< (length spec) 2))
		 (syntax-error 
		  'define-structures "invalid structure specification"
		  spec))
		((c %subset (car spec))
		 `(,%only ,(parse-struct (cadr spec)) ,@(cddr spec)))
		((c %with-prefix (car spec))
		 `(,%prefix ,(parse-struct (cadr spec)) ,(caddr spec)))
		((c %modify (car spec))
		 (fold-right
		  (lambda (mod current)
		    (unless (pair? mod)
		      (syntax-error 'define-structures "invalid modifier" mod))
		    (cond ((c %expose (car mod))
			   `(,%only ,current ,@(cdr mod)))
			  ((c %hide (car mod))
			   `(,%except ,current ,@(cdr mod)))
			  ((c %prefix (car mod))
			   `(,%prefix ,current ,(cadr mod)))
			  ((c %rename (car mod))
			   `(,%rename ,current ,@(cdr mod)))
			  (else 
			   (syntax-error 'define-structures "invalid modifier" mod))))
		  (cadr spec)
		  (cddr spec)))
		(else 
		 (syntax-error 
		  'define-structures "invalid structure specification"
		  spec))))
	(define (process-body body fs)
	  (if (null? body)
	      (reverse defs)
	      (let ((clause (car body)))
		(cond ((or (not (list? clause)) (< (length clause) 2))
		       (syntax-error 'define-structures "invalid structure clause"
				     clause))
		      ((c %open (car clause))
		       (set! defs 
			 (cons `(,(if fs %import-for-syntax %import)
				 ,@(map parse-struct (cdr clause)))
			       defs))
		       (process-body (cdr body) fs))
		      ((c %for-syntax (car clause))
		       (process-body (cdr clause) #t)
		       (process-body (cdr body) fs))
		      ((c %begin (car clause))
		       (set! defs
			 (cons
			  `(,(if fs %begin-for-syntax %begin)
			    ,@(cdr clause)) 
			  defs))
		       (process-body (cdr body) fs))
		      ((c %files (car clause))
		       (set! defs 
			 (cons `(,%include-relative
				 ,@(map
                                    (lambda (fspec)
                                      (let ((f (cond ((string? fspec) fspec)
                                                     ((list? fspec)
                                                      (string-intersperse
                                                       (map ->string fspec)
                                                       "/") )
                                                     (else (->string fspec)))))
                                        (make-pathname
                                         (and ##sys#current-source-filename
                                              (pathname-directory
                                               ##sys#current-source-filename))
                                         f)) )
					(cdr clause)))
			       defs))
		       (process-body (cdr body) fs))
		      (else (syntax-error 
			     'define-structures
			     "invalid structure clause"
			     clause))))))
	`(,%begin
         (,%module ,iname1 *
                   (import (only s48-modules include-relative))
                   ,@(process-body (cddr x) #f))
	  ,@(map process1 (cadr x))))))

)