;;; -*- Mode: LISP; Package: :mk; BASE: 10; Syntax: ANSI-Common-Lisp; -*-
;;;
;;;   Touched: Sun May 13 18:16:34 2007 +0530 <enometh@net.meer>
;;;   Time-stamp: <2007-05-15 14:56:45 madhu>
;;;   Status: Experimental.  Do not Redistribute.
;;;   Copyright (C) 2007 Madhu.  All Rights Reserved.
;;;   Bugs-To: <enometh@net.meer>
;;;
(cl:defpackage #:defsys-madhu
  (:use #:cl)
  (:export #:defsystem #:oos)
  (:nicknames #:mk))
(cl:in-package #:defsys-madhu)


;;;
;;;
;;;
(defclass defsystem-base-class () ())

(defclass standard-options-mixin ()
  ((pretty-name :initarg :pretty-name :type string :accessor pretty-name)
   (default-package :initarg :default-package :type string :accessor default-package)
   (default-pathname :initarg :default-pathname :accessor default-pathname)
   (parent-object :type (or null module-container) :accessor parent-object)
   (property-list :initarg :property-list :type list :accessor property-list)))

(defclass options-mixin (standard-options-mixin)
  ((options :accessor options :type list :initform nil)))

(defclass module-container (defsystem-base-class options-mixin)
  ((module-groups :type list :accessor modules)
   (default-module-class :initarg :default-module-class :type class :accessor default-module-class)))

(defclass default-system (module-container)
  ((name :type symbol :initarg :name :accessor system-name)))

(defclass default-module-group (module-container)
  ((name :type symbol :initarg :name)))

(defclass default-module (defsystem-base-class options-mixin)
  ((name :type string :initarg :name :accessor module-filename)))

(defclass lisp-module (default-module) ())


;;;
;;;
;;;
(defvar *default-system-class* 'default-system)
(defvar *default-module-group-class* 'default-module-group)
(defvar *default-module-class* 'lisp-module)
(defvar *default-file-type* nil)
(defvar *source-file-types* '("lisp" "cl" "l" "lsp"))


;;;
;;; IMPNOTES ; madhu 070514
;;;
;;; - Read a subset of mk:defsystem's source syntax.
;;; - Ignore :depends-on.  Only implement :serial dependencies.
;;; - Handle mk:defsystem's :module XXX without a :source-pathname "" as
;;;   a directory component named "xxx".
;;; - Implement a new :patch-pathname option to mk:defsystem to specify
;;;   an alternative location to :source-pathname
;;; - Components can be specified as pathnames with directories.  Relative
;;;   pathnames are merged with parent. If Absolute, pathnames are treated
;;;   as :private-files. and the :binary-pathname and :patch-pathname
;;;   options to defsystem are not applicable to this component.
;;; - Only Implement (mk:oos :load :compile-during-load).
;;; - Implement no optimizations/caching.  Run as slowly as possible.

(defun containing-system (obj)
  (loop for x = (parent-object obj) then p
	for p = (parent-object x)
	if (null p) do (check-type x default-system)
	and return x))

(defun default-file-type (obj)
  (check-type obj lisp-module)
  (or (getf (options obj) :default-file-type)
      (getf (options (containing-system obj)) :source-extension)
      (car *source-file-types*)))

(defun %get-base-directory (obj &optional dircomps)
  "Return as values a pathname of the base directory, a list of strings
denoting reversed directory components that were encountered when traversing
the component tree upwards, the component corresponding to the base directory,
and a boolean: non-NIL if that component was at the root."
  (check-type obj lisp-module)
  (loop for x = (parent-object obj) then parent
	for parent = (parent-object x)
	and p = (getf (options x) :source-pathname)
	and q = (and (slot-boundp x 'default-pathname) (default-pathname x))
	do (assert (typep x 'module-container))
	(cond ((null parent)
	       (assert (typep x 'default-system))
	       (etypecase q
		 (pathname
		  (assert (null p))
		  (return (values q dircomps x t)))
		 (null
		  (assert (pathnamep p))
		  (return (values p dircomps x t)))))
	      (t (etypecase q
		   (pathname
		    (assert (null p))
		    (let ((comp (pathname-directory q)))
		      (ecase (car comp)
			(:relative
			 (setq dircomps (nreconc (cdr comp) dircomps))) ;loop
			(:absolute
			 (assert (null (pathname-type q)))
			 #+XXX
			 (assert (null (pathname-version q)))
			 (assert (null (pathname-name q)))
			 (return (values q dircomps x nil))))))
		   (null
		    (etypecase p
		      (null)		;loop
		      ((or string pathname)
		       (cond ((and (stringp p) (string= "" p)) nil) ;loop
			     (t (let* ((d (if (stringp p) (pathname p) p))
				       (comp (pathname-directory d)))
				  (assert (null (pathname-type d)))
				  #+XXX
				  (assert (null (pathname-version d)))
				  (cond ((null (cdr comp))
					 (push p dircomps)) ;loop
					(t (assert (null (pathname-name d)))
					   (ecase (car comp)
					     (:relative
					      (setq dircomps (nreconc (cdr comp) dircomps))) ;loop
					     (:absolute
					      (return (values d dircomps x nil)))))))))))))))))

(defun source-pathname (obj)
  (check-type obj lisp-module)
  (let (dircomps path)
    (or (getf (options obj) :source-pathname) ; cache here
	(when (setq path (and (slot-boundp obj 'default-pathname)
			      (default-pathname obj)))
	  (assert (pathnamep path))
	  (let ((comp (pathname-directory path)))
	    (ecase (car comp)
	      (:absolute path)
	      (:relative (setq dircomps (nreverse (cdr comp))) nil))))
	(multiple-value-bind (base-directory dircomps x rootp)
	    (%get-base-directory obj dircomps)
	  (let ((file-type (default-file-type obj))
		(file-name (module-filename obj))
		(dircomps (nreverse dircomps)) b d)
	    (flet ((mkpath (base) (make-pathname :name file-name :type file-type :version nil :directory (append (pathname-directory base) dircomps) :defaults base)))
	      (or (and rootp (setq b (getf (options x) :patch-pathname))
		   (probe-file (setq d (mkpath b))) d)
		  (mkpath base-directory))))))))

(defvar +product-file-type+ (or #+(and cmu x86) "x86f" "fasl"))

(defun %product-file-type (obj)
  (check-type obj lisp-module)
  (or (getf (options obj) :product-file-type)
      (getf (options (containing-system obj)) :binary-extension)
      +product-file-type+))

(defun product-pathname (obj)
  (check-type obj lisp-module)
  (let (dircomps path b)
    (or (getf (options obj) :product-pathname) ; cache here
	(when (setq path (and (slot-boundp obj 'default-pathname)
			      (default-pathname obj)))
	  (assert (pathnamep path))
	  (let ((comp (pathname-directory path)))
	    (ecase (car comp)
	      (:absolute (make-pathname :name (module-filename obj)
					:type (%product-file-type obj)
					:version nil
					:directory comp
					:defaults path))
	      (:relative (setq dircomps (nreverse (cdr comp))) nil))))
	(multiple-value-bind (base-directory dircomps x rootp)
	    (%get-base-directory obj dircomps)
	  (when (and rootp (setq b (getf (options x) :binary-pathname)))
	    (assert (pathnamep b))
	    (setq base-directory b))
	  (make-pathname :name (module-filename obj)
			 :type (%product-file-type obj)
			 :version nil
			 :directory (append (pathname-directory base-directory)
					    (nreverse dircomps))
			 :defaults base-directory)))))

(defun lookup-module-by-name (module-container name &optional errorp)
  (check-type module-container module-container)
  (check-type name symbol)
  (loop for x = module-container then (parent-object x) while x do
	(assert (> (length (modules x)) 0))
	(loop for y in (modules x)
	      do (typecase y
		   (default-module)
		   (symbol)
		   (module-container
		    (when (slot-boundp y 'name)
		      (if (eq name (slot-value y 'name))
			  (return-from lookup-module-by-name y)))))))
  (when errorp
    (error "~A not found in the moduler container ~S or its parents."
	   name module-container)))


;;;
;;;
;;;
(defun plist-sans-keys (plist &rest keys)
  ;; <3247672165664225@naggum.no>
  (loop with sans for tail = (nth-value 2 (get-properties plist keys))
	unless tail return (nreconc sans plist) do
	(loop until (eq plist tail) do
	      (push (pop plist) sans)
	      (push (pop plist) sans))
	(setq plist (cddr plist))))

(defun parse-mk-module (name parent &optional args)
  (let* ((key (etypecase name
		(symbol (assert name)
			(assert (symbol-package name))
			name)
		(string (intern (string-upcase name) :keyword))))
	 (x (make-instance *default-module-group-class* :name key)))
    (setf (parent-object x) parent)
    (setf (modules x) (parse-mk-components (getf args :components) x))
    (setf (getf (options x) :source-pathname)
	  (or (getf args :source-pathname)
	      (etypecase name
		(symbol (string-downcase (symbol-name name)))
		(string name))))
    (let ((ignored (plist-sans-keys args :source-pathname :components)))
      (when ignored
	(warn "TODO: PARSE-MK-MODULE ~S: IGNORING OPTIONS ~S." key ignored)))
    x))

(defun parse-mk-file (spec parent &optional args)
  (etypecase spec
    (string (parse-mk-file (pathname spec) parent args))
    (pathname
     (when args (warn "TODO: PARSE-MK-FILE ~S: IGNORING ARGS ~S." spec args))
     (assert (typep parent 'module-container))
     (let* ((name (pathname-name spec))
	    (type (pathname-type spec))
	    (comp (pathname-directory spec))
	    (obj (make-instance
		  (or (and parent (slot-boundp parent 'default-module-class)
			   (default-module-class parent))
		      *default-module-class*) :name name)))
       (setf (parent-object obj) parent)
       (when (cdr comp) (setf (default-pathname obj) spec))
       (when type
	 (assert (stringp type))
	 (setf (getf (options obj) :default-file-type) type))
       obj))))

(defun parse-mk-components (list parent)
  (loop for x in list collect
	(etypecase x
	  (cons (etypecase (car x)
		  (keyword
		   (ecase (car x)
		     (:module (parse-mk-module (cadr x) parent (cddr x)))
		     (:file (parse-mk-file (cadr x) parent (cddr x)))))
		  (string (parse-mk-file (pathname (car x)) parent (cdr x)))
		  (pathname (parse-mk-file (car x) parent (cdr x)))))
	  (atom (parse-mk-file x parent)))))

(defvar *all-systems* (make-hash-table :test #'eq))

(defmacro defsystem (name &rest args &key source-pathname depends-on
		     binary-pathname patch-pathname source-extension
		     binary-extension components &allow-other-keys)
  (let ((name-var (gensym))
	(source-pathname-var (gensym))
	(depends-on-var (gensym))
	(binary-pathname-var (gensym))
	(patch-pathname-var (gensym))
	(source-extension-var (gensym))
	(binary-extension-var (gensym))
	(components-var (gensym))
	(ignored-var (gensym)))
    `(let ((,name-var ',name)
	   (,source-pathname-var ,source-pathname)
	   (,depends-on-var ',depends-on)
	   (,binary-pathname-var ,binary-pathname)
	   (,patch-pathname-var ,patch-pathname)
	   (,source-extension-var ,source-extension)
	   (,binary-extension-var ,binary-extension)
	   (,components-var ',components)
	   (,ignored-var ',(plist-sans-keys args :source-pathname :components
					    :patch-pathname :binary-pathname
					    :source-extension
					    :binary-extension)))
       (check-type ,name-var symbol)
       (assert ,name-var)
       (assert (symbol-package ,name-var))
       (let ((obj (or ;;XXX (gethash ,name-var *all-systems*)
		      (setf (gethash ,name-var *all-systems*)
			    (make-instance *default-system-class*
					   :name ,name-var)))))
	 (let* ((o (make-instance *default-module-group-class*)))
	   (setf (modules o) (parse-mk-components ,components-var o)
		 (parent-object o) obj)
	   (setf (modules obj) (list o)))
	 (setf (parent-object obj) nil)
	 (setf (getf (options obj) :source-pathname)
	       (pathname (or ,source-pathname-var *load-pathname*)))
	 (when ,patch-pathname-var
	   (setf (getf (options obj) :patch-pathname)
		 (pathname ,patch-pathname-var)))
	 (when ,binary-extension-var
	   (setf (getf (options obj) :binary-extension) ,binary-extension-var))
	 (when ,binary-pathname-var
	   (setf (getf (options obj) :binary-pathname)
		 (pathname ,binary-pathname-var)))
	 (when ,source-extension-var
	   (setf (getf (options obj) :source-extension) ,source-extension-var))
	 (when ,ignored-var
	     (warn "TODO: DEFSYSTEM ~S: IGNORING ARGS: ~S."
		   ,name-var ,ignored-var))
	 obj))))

(defvar *oos-verbose* t)
(defvar *load-source-instead-of-binary* nil)
(defvar *load-source-if-no-binary* nil)
(defvar *compile-during-load* nil)
(defvar *bother-user-if-no-binary* nil)
(defvar *minimal-load* nil)
(defvar *oos-force* nil)
(defvar *load-binary-if-source-is-newer* nil)

(defun load-module (obj)
  (check-type obj lisp-module)
  (flet ((mycompile (src output)
	   (format t "compile and load ~A to ~A~%" src output)
	   (ensure-directories-exist output :verbose t)
	   (compile-file src :output-file output :verbose *oos-verbose*))
	 (myload (x)
	   (format t "load ~A~%" x)
	   (load x :verbose *oos-verbose*)))
    (let ((source (source-pathname obj))
	  (product (product-pathname obj)))
      (assert (probe-file source))
      (cond (*load-source-instead-of-binary* (myload source))
	    ((not (probe-file product))
	     (cond (*compile-during-load*
		    (mycompile source product) (myload product))
		   (*load-source-if-no-binary* (myload source))
		   (t (error "No product file ~A~%For source file ~A"
			     product source))))
	    ((< (file-write-date product) (file-write-date source))
	     (cond (*compile-during-load*
		    (mycompile source product) (myload product))
		   (*load-binary-if-source-is-newer* (myload product))
		   (t (myload source)))) ;XXX bother user here
	    ((and *oos-force* *compile-during-load*) ;XXX
	     (mycompile source product) (myload product))
	    (t (myload product))))))

(defun oos (name operation
	    &key ((:force *oos-force*) *oos-force*)
	    ((:verbose *oos-verbose*) *oos-verbose*)
	    ((:compile-during-load *compile-during-load*)
	     *compile-during-load*)
	    ((:load-source-if-no-binary *load-source-if-no-binary*)
	     *load-source-if-no-binary*)
	    ((:load-source-instead-of-binary *load-source-instead-of-binary*)
	     *load-source-instead-of-binary*)
	    ((:bother-user-if-no-binary *bother-user-if-no-binary*) ;XXX
	     *bother-user-if-no-binary*)
	    ((:minimal-load *minimal-load*)  ;XXX
	     *minimal-load*))
  (let ((system name))
    (loop (etypecase system
	    (null (return (error "System ~S not found." name)))
	    (default-system (return))
	    (string (setq system (intern (string-upcase system) :keyword)))
	    (symbol (setq system (gethash system *all-systems*)))))
    (unless (eq operation :load)
      (cerror "Continue :LOAD."
	      "~A: Operation ~A not supported.  Only LOAD SERIAL is supported."
	      system operation))
    (labels ((serial (obj &optional parent)
	       (etypecase obj
		 (lisp-module (load-module obj))
		 (symbol		;XXX bogus
		  (let ((x (or (lookup-module-by-name parent obj)
			       (gethash obj *all-systems*))))
		    (cond (x (serial x))
			  (t (warn "OOS: ~S: IGNORING UNKNOWN COMPONENT ~S."
				   name obj)))))
		 (module-container
		  (map nil (lambda (x) (serial x obj)) (modules obj))))))
      (serial system))))