;;; Copyright (C) 2007, 2008 Magnus Henoch
;;;
;;; 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 2 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, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA

(in-package :darcs)

(defvar *darcs-commands* ()
  "List of commands that can be executed from the command line.
Each element is a symbol that names the command.  The corresponding
function is named cmd-SYMBOL, and is called with all command line
arguments but the first one.  It should return an integer exit code.")

(eval-when (:compile-toplevel :load-toplevel)
  (defun command-function (command)
    "Turn a command symbol into a function symbol."
    (intern (format nil "CMD-~A" command) :darcs)))

(defun handle-command-line (argv)
  "Handle a command line, emulating the real darcs client.
ARGV is a list of strings.  This function is to be called in some
platform-dependent manner, while being portable itself.  An integer
exit code is returned."
  (let* ((command (find (car argv) *darcs-commands* :test #'string-equal))
	 (function (when command (command-function command))))
    (if (null command)
	(progn
	  (if (null argv)
	      (format *error-output* "No command given!~%")
	      (format *error-output* "Invalid command '~A'!~%" (car argv)))
	  (usage)
	  1)
	(handler-case
	    (let ((retval (funcall function (cdr argv))))
	      (fresh-line)
	      (if (numberp retval)
		  retval
		  (progn
		    (warn "~A didn't give a proper exit code." command)
		    0)))
	  (invalid-arguments (c)
	    (with-accessors ((ctrl simple-condition-format-control)
			     (args simple-condition-format-arguments)) c
	      (when ctrl
		(apply #'format *error-output* ctrl args)))
	    (command-usage command)
	    1)))))

(defun usage ()
  "Print usage information about commands to *ERROR-OUTPUT*."
  (format *error-output* "Usage: darcs COMMAND ...~%~%Commands:~%")
  (dolist (cmd *darcs-commands*)
    (let ((function (command-function cmd)))
      (format *error-output* "  ~A~15,2T~A~%" 
	      cmd
	      (car (split-sequence:split-sequence 
		    #\Newline (get function 'darcs-documentation)
		    :count 1))))))

(defun command-usage (command)
  "Print longer documentation for COMMAND."
  (format *error-output* "~&~A~%" (get (command-function command) 'darcs-documentation)))

(defmacro define-darcs-command (name options operands docstring &body body)
  "Define a darcs command called NAME.
NAME is passed to COMMAND-FUNCTION to make the name of the function.
OPTIONS is a list of variables holding OPTION structures, describing
the options accepted by the commnad.
OPERANDS is a destructuring lambda list for the non-option arguments
accepted by the command."
  (flet ((option-symbol (name)
	   (intern (concatenate 'string "OPT-" (symbol-name name)))))
    (let ((function (command-function name))
	  (args-sym (gensym))
	  (options-sym (gensym))
	  (operands-sym (gensym)))
      `(progn
	 (pushnew ',name *darcs-commands*)
	 (defun ,function (,args-sym) ,docstring
		(multiple-value-bind (,options-sym ,operands-sym)
		    (getopt ,args-sym
			    (list ,@(mapcar #'option-symbol options)))
		  ,@(when (null options)
			  `((declare (ignore ,options-sym))))
		  (let ,(mapcar
			 (lambda (o)
			   `(,o (cdr (assoc (option-keyword ,(option-symbol o)) ,options-sym))))
			 options)
		    ;; XXX: what if this fails?
		    (destructuring-bind ,operands ,operands-sym
		      ,@body))))
	 (setf (get ',function 'darcs-documentation)
	       ;; XXX: documentation for operands
	       ,(if (null options)
		    docstring
		    `(format nil
			     "~A~%~%~:{~A~30,5T~A~%~}"
			     ,docstring
			     (mapcar
			      (lambda (opt)
				(list
				 (cond
				   ((and (option-short opt)
					 (option-long opt))
				    (format nil "--~A~@[=~A~], -~C"
					    (option-long opt)
					    (option-arg opt)
					    (option-short opt)))
				   ((option-short opt)
				    (format nil "-~C~@[ ~A~]"
					    (option-short opt)
					    (option-arg opt)))
				   ((option-long opt)
				    (format nil "--~A~@[=~A~]"
					    (option-long opt)
					    (option-arg opt)))
				   (t
				    (error "Option ~A has neither short nor long argument form." (option-keyword opt))))
				 (option-help opt)))
			      (list ,@(mapcar #'option-symbol options))))))))))  

(defparameter opt-repodir 
  (make-option
   :keyword :repodir
   :long "repodir"
   :arg "DIRECTORY"
   :help "Use DIRECTORY instead of current directory"))

(defun find-repo (&optional (dir *default-pathname-defaults*))
  "Find repository in current directory or above.
Signal an error if there is none, else return the repository root.
If DIR is specified, search for repository there instead."
  (if (fad:directory-exists-p (upath-subdir dir '("_darcs")))
      (fad:directory-exists-p dir)	;get directory truename
      (let ((parent-dir (ignore-errors
			  (fad:directory-exists-p
			   (merge-pathnames 
			    (make-pathname :directory '(:relative :up))
			    dir)))))
	(if (and parent-dir (not (equal dir parent-dir)))
	    (find-repo parent-dir)
	    (error "Not in a darcs repo.")))))

(defmacro with-repo (repodir &body body)
  "Given a --repodir argument, canonicalize it and change directory accordingly.
That is, if there is no --repodir option, don't change current directory,
and bind variable to the repository root directory.
If there is a --repodir option, ensure it refers to an existing directory,
and change the current directory to it.
\(This is actually how the original darcs does it.\)"
  (let ((original-repodir (gensym)))
    `(let* ((,original-repodir ,repodir)
	    (,repodir
	     (if ,repodir
		 (or (fad:directory-exists-p ,repodir)
		     (error "Directory ~A does not exist." ,repodir))
		 (find-repo)))
	    ;; If explicit --repodir argument was specified, change directory.
	    ;; Otherwise, leave it, even if the actual repository is in a
	    ;; parent directory.
	    (*default-pathname-defaults* 
	     (if (null ,original-repodir)
		 *default-pathname-defaults*
		 (fad:pathname-as-directory ,repodir))))
       ,@body)))

(define-darcs-command add (repodir) (&rest files-and-dirs 
					   &aux already-there)
  "Add files and directories for later recording.

Usage: darcs add FILE ..."
  (with-repo repodir
    (dolist (file files-and-dirs)
      (handler-case
	  (progn
	    (add-file repodir file)
	    ;; (format t "~&Added ~A" file)
	    )
	(already-in-repository (c)
	  ;; Save the files and directories that are already in the
	  ;; repository for pretty error printing.
	  (push (slot-value c 'file) already-there))))
    (when already-there
      (setf already-there (nreverse already-there))
      (let* ((with-path (mapcar (lambda (f) (merge-pathnames f repodir)) already-there))
	     (nfiles 0)
	     (ndirs 0))
	(dolist (f with-path)
	  (let ((truename (fad:file-exists-p f)))
	    (assert truename)
	    (if (fad:directory-pathname-p f)
		(incf ndirs)
		(incf nfiles))))
	(assert (= (+ nfiles ndirs) (length already-there)))
	;; We want the message to look just like darcs', in order to
	;; pass its test suite (in particular tests/add.pl).
	(format *error-output*
		"~&The following ~A already in the repository"
		(cond
		  ((zerop nfiles)
		   (if (= ndirs 1)
		       "directory is"
		       "directories are"))
		  ((zerop ndirs)
		   (if (= nfiles 1)
		       "file is"
		       "files are"))
		  (t
		   "files and directories are")))
	(format *error-output* ":~%~{ ~A~}" already-there))))
  0)

(define-darcs-command whatsnew () ()
  "See what has been changed in the working directory.

Usage: darcs whatsnew"
  (diff-repo-display (find-repo)))

(define-darcs-command init (repodir) ()
    "Initialize a darcs repository in the current directory."
  (let ((repodir (or repodir
		     *default-pathname-defaults*)))
    (format t "Creating repo in ~A...~%" repodir)
    (create-repo repodir)
    0))

(defparameter opt-author
  (make-option
   :keyword :author
   :short #\A
   :long "author"
   :arg "EMAIL"
   :help "specify author id"))

(defparameter opt-all-patches
  (make-option
   :keyword :all-patches
   :short #\a
   :long "all"
   :help "answer yes to all patches"))

(defparameter opt-patch-name
  (make-option
   :keyword :patch-name
   :short #\m
   :long "patch-name"
   :arg "PATCHNAME"
   :help "name of patch"))

(defparameter opt-ask-deps
  (make-option
   :keyword :ask-deps
   :long "ask-deps"
   :help "ask for extra dependencies"))

(define-darcs-command record
    (author all-patches patch-name ask-deps repodir)
    (&rest files)
    "Save changes in the working copy to the repository as a patch."
  (with-repo repodir
    (let* ((author (or author
		       ;; XXX: other ways to indicate author
		       (progn
			 (format *query-io* "~&Who is the author? ")
			 (finish-output *query-io*)
			 (read-line *query-io*))))
	   (patch-name (or patch-name
			   (progn
			     (format *query-io* "~&What is the patch name? ")
			     (finish-output *query-io*)
			     (read-line *query-io*))))
	   (files (mapcar
		   (lambda (file)
		     (setf file (enough-namestring file repodir))
		     (if (fad:directory-exists-p file)
			 (sanitize-filename file :type :directory)
			 (sanitize-filename file :type :file)))
		   files)))
      ;; XXX: long log

      (let ((patches (diff-repo repodir)))
	(flet ((ask (patch)
		 ;; If any files were specified, use only patches
		 ;; touching those files/directories.
		 (if (or (null files)
			 (and (typep patch 'file-patch)
			      (member (patch-filename patch) files :test #'equal))
			 (and (typep patch 'directory-patch)
			      (member (patch-directory patch) files :test #'equal)))
		     ;; If all-patches was requested, record all patches
		     ;; matching the file criterion.
		     (or all-patches
			 (progn
			   (display-patch patch *query-io*)
			   (y-or-n-p "Record patch ~A?" patch)))
		     nil)))
	  (record-patches repodir patch-name author :now nil
			  (select-patches patches #'ask))
	  (format t "~&Finished recording patch '~A'~%" patch-name)
	  0)))))

(define-darcs-command pull
    (all-patches repodir)
  (&rest from-repositories)
  "Copy and apply patches from another repository to this one."
  (let* ((ourrepo
	  (if repodir
	      (or (fad:directory-exists-p repodir)
		  (error "Directory ~A does not exist." repodir))
	      (find-repo)))
	 ;; If explicit --repodir argument was specified, change directory.
	 ;; Otherwise, leave it, even if the actual repository is in a
	 ;; parent directory.
	 (*default-pathname-defaults* 
	  (if (null repodir)
	      *default-pathname-defaults*
	      (fad:pathname-as-directory ourrepo))))

    (if from-repositories
	;; Get truename for all repositories, if they are local paths.
	(map-into 
	 from-repositories
	 (lambda (dir)
	   (setf dir (make-upath dir))
	   (when (typep dir 'pathname)
	     (setf dir (or
			(fad:directory-exists-p dir)
			(error "Directory ~A does not exist." dir))))
	   dir)
	 from-repositories)
	;; If no remote repository specified, use the default one.
	(setf from-repositories (list nil)))

    ;; We can't pull from ourselves.
    (when (member ourrepo from-repositories :test #'equal)
      (error "Can't pull from current repository!"))

    (dolist (theirrepo from-repositories)
      (pull ourrepo theirrepo :select-patches (if all-patches :all :ask)))

    ;; Change the default repository.
    (when (first from-repositories)
      (set-default-repo ourrepo (upath-to-string (first from-repositories) :truename t)))

    0))

(define-darcs-command get
    (repodir)
  (from)
  "Get a copy of a repository."
  (setf from (make-upath from))
  (let* ((to (or 
	      ;; Either there is an explicit repodir...
	      repodir
	      ;; ...or we make one relative to the current directory.
	      (make-pathname
	       :directory
	       (list :relative
		     (typecase from
		       ;; If we have a local pathname, use the last component.
		       (pathname
			(or (pathname-name from)
			    (car (last (pathname-directory from)))))
		       ;; Otherwise, use the part from the last slash.
		       (t
			(let* ((s (upath-to-string from))
			       (last-slash (position #\/ s :from-end t)))
			  (if last-slash
			      (subseq s (1+ last-slash))
			      s)))))))))
    (get-repo from to))
  0)