;;;; system.scm - simple system-definition facility


(import scheme)

(import coops shell compile-file)
(import srfi-1 (chicken file) (chicken file posix) (chicken format))
(import (chicken pathname))
(import (chicken csi) (chicken platform) (chicken load))
(import (chicken time) (chicken base))
(import (chicken load))


(define verbose-action (make-parameter #f))

(define-syntax define-system
  (syntax-rules ()
    ((_ sname component ...)
     (define sname
       (make <system>
	 'name 'sname
	 'components (list (make-component component) ...))))))

(define (dribble . args)
  (when (verbose-action)
    (apply print "; " (system-name (current-system)) ": " args)))

(define-class <system> ()
  ((name reader: system-name)
   (components accessor: system-components initform: '())))

(define current-system (make-parameter #f))

(define-method (print-object (sys <system>) port)
  (fprintf port "#<system ~a>" (system-name sys)))

(define-class <component> ()
  ((name accessor: component-name)))

(define-class <file> (<component>)
  ((path initform: #f)
   (explanation accessor: file-action-explanation initform: #f)
   (includes accessor: file-includes initform: '())
   (depends accessor: file-dependencies initform: '())))

(define-method (print-object (f <component>) port)
  (fprintf port "#<component ~s>" (component-name f)))

(define-class <scheme-file> (<file>)
  ((compiled-file accessor: file-compiled-file initform: #f)
   (compile-options accessor: file-compile-options initform: '())
   (last-load-time accessor: file-last-load-time initform: #f) ))

(define-class <compiled-scheme-file> (<scheme-file>)
  ())

(define (make-component x #!optional sys)
  (cond ((symbol? x) (make-component (symbol->string x)))
	((string? x) 
	 (or (and sys (find-component x sys))
	     (make <scheme-file> 'name x)))
	((subclass? (class-of x) <file>) x)
	(else (error 'make-component "invalid component" x))))

(define-method (find-component (name #t) (sys <system>))
  (find (lambda (comp) (string=? name (component-name comp)))
	(system-components sys)))

(define ((file-maker class) name #!key (depends '()) (includes '()) path options)
  (define (listify x)
    (if (list? x)
	x
	(list x)))
  (apply 
   make class
   'name name
   'depends (listify depends)
   'includes (listify includes)
   'path path
   (if options (list 'compile-options (listify options)) '())))

(define file (file-maker <file>))  
(define scheme-file (file-maker <scheme-file>))
(define compiled-scheme-file (file-maker <compiled-scheme-file>))

(define-method (file-path (s #t)) s)

(define-method (file-path (f <file>))
  (or (slot-value f 'path)
      (let* ((name (component-name f))
	     (fn (or (file-exists? (make-pathname #f name "scm"))
		     (file-exists? name)
		     (error 'file-path "file not found" name))))
	(set! (slot-value f 'path) fn)
	fn)))

(define-method ((setter file-path) (f <file>) path)
  (set! (slot-value f 'path) path))

(define (walk sys test action)
  (let walk ((comps (system-components sys)))
    (let ((changed #f))
      (for-each 
       (lambda (comp)
	 (let ((deps (canonicalize-files (file-dependencies comp) sys))
	       (incs (canonicalize-files (file-includes comp) sys)))
	   (set! (file-dependencies comp) deps)
	   (set! (file-includes comp) incs)
	   (let ((flag (walk deps)))
	     (cond (flag
		    (set! (file-action-explanation comp)
		      (sprintf "dependency of ~s changed" (component-name comp))))
		   ((any test deps) (set! flag #t))
		   ((test comp) (set! flag #t)))
	     (when flag
	       (set! changed #t)
	       (action comp)))))
       comps)
      changed)))

(define (canonicalize-files files sys)
  (if (any (lambda (x) (or (string? x) (symbol? x))) files)
      (map (cut make-component <> sys) files)
      files))

(define (file-newer? f1 f2)
  (> (file-modification-time (file-path f1))
     (file-modification-time (file-path f2))))

(define (load-system sys #!key quiet force)
  (parameterize ((verbose-action (not quiet))
		 (current-system sys)
		 (##sys#current-module #f))
    (when force (clean-system sys))
    (or (walk sys file-needs-reload? reload-file)
	(begin
	  (dribble "nothing to do.")
	  #f))))

(define (compile-system sys #!key quiet force)
  (parameterize ((verbose-action (not quiet))
		 (current-system sys))
    (when force (clean-system sys))
    (or (walk sys file-needs-recompile? recompile-file)
	(begin
	  (dribble "nothing to do.")
	  #f))))

(define (clean-system sys)
  (for-each clean-file (system-components sys)))

(define (build-system sys #!key quiet force)
  (parameterize ((verbose-action (not quiet))
		 (current-system sys))
    (when force (clean-system sys))
    (or (walk sys file-needs-rebuild? rebuild-file)
	(begin
	  (dribble "nothing to do.")
	  #f))))

(define-method (clean-file (f <file>)) (void))

(define-method (clean-file (f <scheme-file>)) 
  (set! (file-last-load-time f) #f)
  (set! (file-compiled-file f) #f)
  (delete-file* (pathname-replace-extension (file-path f) "so"))) ; for build-system

(define-method (build-file (f <file>)) (void))

(define-method (build-file (f <scheme-file>))
  (when (file-needs-rebuild? f)
    (rebuild-file f)))

(define-method (file-needs-reload? (f <file>)) #f)

(define-method (file-needs-reload? (sf <scheme-file>))
  (let ((llt (file-last-load-time sf)))
    (cond ((not llt)
	   (set! (file-action-explanation sf)
	     (sprintf
		 "file ~s needs to be reloaded because it hasn't been loaded yet"
	       (component-name sf)))
	   #t)
	  ((> (file-modification-time (file-path sf)) llt)
	   (set! (file-action-explanation sf)
	     (sprintf "file ~s needs to be reloaded because it has changed"
	       (component-name sf)))
	   #t)
	  ((any (cut include-file-newer? <> llt) (file-includes sf))
	   (set! (file-action-explanation sf)
	     (sprintf "file ~s needs to be reloaded because included file has changed"
	       (component-name sf)))
	   #t)
	  (else 
	   (set! (file-action-explanation sf) #f)
	   #f))))

(define-method (file-needs-recompile? (sf <scheme-file>))
  (let ((fcf (file-compiled-file sf)))
    (cond ((not fcf)
	   (set! (file-action-explanation sf)
	     (sprintf "file ~s needs to be recompiled because it hasn't been compiled yet"
	       (component-name sf)))
	   #t)
	  ((file-newer? sf fcf)
	   (set! (file-action-explanation sf)
	     (sprintf "file ~s needs to be recompiled because it has changed"
	       (component-name sf)))
	   #t)
	  ((any (cute include-file-newer? <> (file-modification-time fcf))
		(file-includes sf))
	   (set! (file-action-explanation sf)
	     (sprintf "file ~s needs to be recompiled because included file has changed"
	       (component-name sf)))
	   #t)
	  (else
	   (set! (file-action-explanation sf) #f)
	   #f))))

(define-method (file-needs-rebuild? (f <file>)) #f)

(define-method (file-needs-rebuild? (sf <scheme-file>))
  (let* ((path (file-path sf))
	 (cf (pathname-replace-extension path "so"))
	 (cfx (file-exists? cf))
	 (lmt (and cfx (file-modification-time cf))))
    (cond ((not cfx)
	   (set! (file-action-explanation sf)
	     (sprintf "file ~s needs to be rebuilt because no compiled version exists"
	       (component-name sf)))
	   #t)
	  ((> (file-modification-time path) lmt)
	   (set! (file-action-explanation sf)
	     (sprintf "file ~s needs to be rebuilt because it has been modified"
	       (component-name sf)))
	   #t)
	  ((any (cut include-file-newer? <> lmt) (file-includes sf))
	   (set! (file-action-explanation sf)
	     (sprintf "file ~s needs to be rebuilt because included file has changed"
	       (component-name sf)))
	   #t)
	  (else
	   (set! (file-action-explanation sf) #f)
	   #f))))

(define (include-file-newer? f time)
  (> (file-modification-time (file-path f)) time))
	
(define (show-action-explanation f)
  (and-let* ((exp (file-action-explanation f)))
    (dribble exp)))

(define-method (reload-file (f <file>)) (void))

(define-method (reload-file (sf <scheme-file>))
  (show-action-explanation sf)
  (parameterize ((load-verbose (verbose-action)))
    (load (file-path sf)))
  (set! (file-last-load-time sf) (current-seconds)))

(define-method (reload-file (csf <compiled-scheme-file>))
  (recompile-file csf))

(define-method (recompile-file (f <file>)) (void))

(define-method (recompile-file (sf <scheme-file>))
  (show-action-explanation sf)
  (let ((cf (compile-file 
	     (file-path sf) 
	     options: (file-compile-options sf)
	     verbose: (verbose-action))))
    (unless cf (error "recompilation failed" sf))
    (set! (file-last-load-time sf) (current-seconds))
    (set! (file-compiled-file sf) cf)))

(define-method (rebuild-file (f <file>)) (void))

(define-method (rebuild-file (sf <scheme-file>))
  (show-action-explanation sf)
  (let* ((path (file-path sf))
	 (out (pathname-replace-extension path "so")))
    (parameterize ((shell-verbose (verbose-action)))
      (run (csc ,@(file-compile-options sf) -J -s ,path -o ,out)))))


;;; csi toplevel commands

(when (feature? #:csi)
  (let ()
    (define (check)
      (unless (current-system)
	(print* "Enter expression that evaluates to a system: ")
	(current-system (eval (read))))
      (current-system))
    (toplevel-command
     'ls
     (lambda () (load-system (check)))
     ",ls               load selected system")
    (toplevel-command
     'cs
     (lambda () (load-system (check)))
     ",cs               compile selected system")
    (toplevel-command
     'sys
     (lambda () (current-system (eval (read))))
     ",sys SYSTEM       select system")))