(in-package #:format-string-builder)

(defclass format-string-command ()
  ((at-p :initarg :at-p :accessor at-p :initform nil)
   (colon-p :initarg :colon-p :accessor colon-p :initform nil)))

(defclass simple-format-string-command (format-string-command)
  ((format-char :initarg :format-char :accessor format-char)
   (modifiers :initarg :modifiers :accessor modifiers :initform nil)))

(defclass compound-format-string-command (format-string-command)
  ((start-char :initarg :start-char :accessor start-char)
   (contents :initarg :contents :accessor contents :initform nil)
   (end-char :initarg :end-char :accessor end-char)
   (modifiers :initarg :modifiers :accessor modifiers :initform nil)))

(defclass sectioned-format-string-command (compound-format-string-command)
  ())

(defmethod print-object ((obj compound-format-string-command) s)
  (declare (optimize (debug 3)))
  (print-unreadable-object (obj s :type t :identity t)
    (format s "~:@{\"~:[~;:~]~:[~;@~]~a...~a\" modifiers: ~s~}"
            (mapcar (lambda (x) (funcall x obj))
                    '(colon-p at-p start-char end-char modifiers)))))

(defgeneric print-format-modifiers (command stream)
  (:method ((command format-string-command) s)
     ;; TODO: format here causes inconsistent behavior :p
     (mapl (lambda (x)
             (princ (car x) s)
             (when (cdr x) (princ #\, s)))
           (modifiers command))))

(defgeneric print-format-representation (command stream)
  (:documentation "Prints the appropriate control sequence to the stream passed in
                   The :before method will print the Tilde."))

(defmethod print-format-representation ((commands list) s)
  (dolist (command commands)
    (print-format-representation command s)))

(defmethod print-format-representation ((literal character) s)
  (princ literal s))

(defmethod print-format-representation ((literal integer) s)
  (princ literal s))

(defmethod print-format-representation ((literal string) s)
  (princ literal s))

(defmethod print-format-representation :around ((command format-string-command) s)
  (princ #\~ s)
  (print-format-modifiers command s)
  (when (colon-p command)
    (princ #\: s))
  (when (at-p command)
    (princ #\@ s))
  (call-next-method))

(defmethod print-format-representation ((command simple-format-string-command) s)
  (princ (format-char command) s))

(defmethod print-format-representation :before ((command compound-format-string-command) s)
  (princ (start-char command) s))

(defmethod print-format-representation ((command compound-format-string-command) s)
  (print-format-representation (contents command) s))

(defmethod print-format-representation :after ((command compound-format-string-command) s)
  (princ #\~ s)
  (princ (end-char command) s))

(defmethod print-format-representation ((command sectioned-format-string-command) s)
  (mapcar (op (princ _ s))
	  (intersperse "~;" (contents command))))

;;; TODO: should this be a generic function?
(defun convert-modifier (modifier)
  (flet ((validate-modifier (modifier)
           (when (member (elt (string modifier) 0) '(#\: #\@ #\,))
             (error "Invalid modifier: ~s" modifier))
           modifier))
    (typecase modifier
      (character  (concatenate 'string "'" (string (validate-modifier modifier))))
      (string (validate-modifier modifier))
      (null "")
      (t modifier))))

(defun generate-function-defs ()
  (loop for name being the hash-keys in *format-string-registry* using (hash-value spec)
        collect `(,name (&key colon-p at-p)
                        (make-instance ,@spec :colon-p colon-p :at-p at-p))))

(defgeneric dispatch-command (command args)
  (:method ((command simple-format-string-command) args)
   (setf (modifiers command) (mapcar #'convert-modifier args))
   command)
  (:method ((command compound-format-string-command) args)
   (destructuring-bind ((&rest modifiers) &rest contents) args
     (setf (modifiers command) (mapcar #'convert-modifier modifiers))
     (setf (contents command) (mapcar #'form-step contents))
     command)))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (#-dev defvar #+dev defparameter
	 *format-string-registry* (make-hash-table))

  (defun form-step (form)
    (flet ((dispatch-keyword (keyword &optional args)
	     (if-let ((spec (gethash keyword *format-string-registry*)))
	       (let ((result (apply #'make-instance spec)))
		 (when args
		   (dispatch-command result args))
		 result))))
      (etypecase form
	(list (cond ((null form) nil)
		    ((keywordp (car form)) (dispatch-keyword (car form) (cdr form)))))
	((or character string) form)
	(keyword (dispatch-keyword form)))))

  (defun make-format-string (forms)
    (with-output-to-string (*format-stream*)
      (print-format-representation
       (mapcar #'form-step (macroexpand forms))
       *format-stream*))))

(defun define-simple-format-char (name format-char &key at-p colon-p)
  (setf (gethash (intern (string name) :keyword)
                 *format-string-registry*)
        `(simple-format-string-command :format-char ,format-char
                                       :at-p ,at-p
                                       :colon-p ,colon-p)))

(defun define-compound-format-char (name start-char end-char &key at-p colon-p)
  (setf (gethash (intern (string name) :keyword)
                 *format-string-registry*)
        `(compound-format-string-command :start-char ,start-char
                                         :end-char ,end-char
                                         :at-p ,at-p
                                         :colon-p ,colon-p)))

(defun define-sectioned-format-char (name start-char end-char &key at-p colon-p)
  (setf (gethash (intern (string name) :keyword)
		 *format-string-registry*)
	`(sectioned-format-string-command :start-char ,start-char
					  :end-char ,end-char
					  :at-p ,at-p
					  :colon-p ,colon-p)))

(defmacro define-compound-format-chars (&body specs)
  `(progn
     ,@(loop for spec in specs
	     collect `(define-compound-format-char ,@spec))))

(defmacro define-simple-format-chars (&body specs)
  `(progn
     ,@(loop for spec in specs
             collect `(define-simple-format-char ,@spec))))

(defmacro define-format-chars (&body body)
  `(macrolet ((:simple (name (char) &key at-p colon-p)
                `(define-simple-format-char ,name ,char
                                            :at-p ,at-p :colon-p ,colon-p))
              (:simples (&rest specs)
                (list* 'progn
                       (mapcar (lambda (spec)
                                 `(:simple ,@spec))
                               specs)))
              (:compound (name (start-char end-char) &key at-p colon-p)
                `(define-compound-format-char ,name ,start-char ,end-char
                                              :at-p ,at-p :colon-p ,colon-p))
              (:compounds (&rest specs)
                (list* 'progn
                       (mapcar (lambda (spec)
                                 `(:compound ,@spec))
                               specs)))
	      (:sectioned (name (start-char end-char) &key at-p colon-p)
		`(define-sectioned-format-char ,name ,start-char ,end-char
					       :at-p ,at-p :colon-p ,colon-p)))
     ,@body))

(defmacro format* (stream format-spec &rest args)
  `(format ,stream
           ,(make-format-string format-spec)
           ,@args))

(defmacro define-message (name (stream-arg &rest args) &body spec)
  "Define a function called NAME that takes a stream argument and a
variable argument list that formats the arguments according to the
spec passed as the body."
  (flet ((get-argument-names (arg-list)
           (loop for s in arg-list
                 when (and (symbolp s) (not (char= (elt (symbol-name s) 0) #\&))) collect s
                 when (consp s) collect (car s))))
    (with-gensyms (fs the-rest)
      `(let ((,fs ,(make-format-string spec)))
         (defun ,name (,stream-arg ,@args &rest ,the-rest)
           (apply #'format ,stream-arg ,fs ,@(get-argument-names args) ,the-rest))))))

(define-format-chars

  ;; Iteration characters.
  (:compounds
    (:map (#\{ #\}))
    (:rest (#\{ #\}) :at-p t)

    (:ap (#\{ #\}) :colon-p t)
    (:apply (#\{ #\}) :colon-p t)

    (:aprest (#\{ #\}) :at-p t :colon-p t)
    (:apply-rest (#\{ #\}) :at-p t :colon-p t))

  ;; Alignment characters.
  (:compounds
    (:spread (#\< #\>))

    (:ljust (#\< #\>) :at-p t)
    (:left (#\< #\>) :at-p t)

    (:rjust (#\< #\>) :colon-p t)
    (:right (#\< #\>) :colon-p t)

    (:cjust (#\< #\>) :at-p t :colon-p t)
    (:center (#\< #\>) :at-p t :colon-p t))

  ;; Conditional output
  (:sectioned :y-or-n (#\[ #\]) :colon-p t)

  ;; Case printing characters.
  (:compounds
    (:lowercase (#\( #\)))
    (:downcase (#\( #\)))
    (:uppercase (#\( #\)) :at-p t :colon-p t)
    (:upcase (#\( #\)) :at-p t :colon-p t)
    (:titlecase (#\( #\)) :colon-p t)
    (:capitalize (#\( #\)) :colon-p t)
    (:initialcap (#\( #\)) :at-p t))

  (:compounds
    (:own-line (#\& #\%)))

  (:simples
    (:str (#\a))
    (:repr (#\s))
    (:float (#\f))
    (:dec (#\d))
    (:decimal (#\d))
    (:hex (#\x))
    (:hexadecimal (#\d))
    (:oct (#\o))
    (:octal (#\o))
    (:currency (#\$))
    (:exit (#\^))
    (:go-to (#\*))
    (:end-section (#\;))
    (:fresh-line (#\&))
    (:ensure-line (#\&))
    (:new-line (#\%))))

#+null
(progn
  (define-message hello (stream name)
    (:titlecase () "hello" #\space :str))

  (define-message print-comma-separated (stream)
    (:own-line ()
	       (:rest () :str :exit ", "))))