(in-package :cl-user)

;;
;; The very first thing we'd need is a syntax for entities.
;;

;; (method <gfun-name> {spec} s1 .. sn)

;;
(defun parse-defmethod (form)
  (let (gfun
        comb
        args)
    (pop form)
    (setf gfun (pop form))
    (do () ((not (keywordp (car form))))
      (setf comb (append comb (list (pop form)))))
    (setf args
          (parse-defmethod-args (car form)))
    `("defmethod"
      $
      ,(patternfy gfun)
      ,@(mapcar #'patternfy comb)
      ,args
      *)))

(defun parse-defmethod-args (args)
  (let ((res nil))
    ;; required
    (do () ((or (null args) (member (car args) lambda-list-keywords)))
      (let ((arg (pop args)))
        (if (eql arg 't)
            (push '_ res)
            (push `(_ ,(patternfy arg))
                  res))))
    (reverse res)))

(defparameter *wsp* (format nil "[~A~A~A()#;]+" #\space #\tab #\newline))

(defun patternfy (x)
  (cond ((keywordp x)
         (concatenate 'string
                      (regexp-quote (concatenate 'string ":" (princ-to-string x)))
                      *wsp*))
        ((symbolp x)
         (concatenate 'string
                      "\\([a-zA-Z0-9./-]*:\\)?"
                      (regexp-quote (princ-to-string x))
                      *wsp*))
        ((atom x) (princ-to-string x))
        ((consp x)
         (mapcar #'patternfy x))))

(defun regexp-quote (string)
  (with-output-to-string (bag)
    (loop for c across string do
          (cond ((or (alphanumericp c)
                     (find c "-/"))
                 (princ c bag))
                (t
                 (princ "[" bag)
                 (princ c bag)
                 (princ "]" bag))))))

(defmethod source-match-pattern ((thing pcl:standard-method))
  (let ((def
            (first (slot-value thing 'pcl::source)))
        (fn (second (slot-value thing 'pcl::source))))
    (list
     (and fn
          (namestring
           (merge-pathnames (make-pathname :type "lisp")
                            fn)))
     (parse-defmethod def)
     def)))

(defmethod source-match-pattern ((thing pcl:standard-reader-method))
  (let ((fn (slot-value thing 'pcl::source))
        (class (pcl:class-name (car (PCL:METHOD-SPECIALIZERS thing))))
        (name
         (pcl:slot-definition-name (pcl:accessor-method-slot-definition thing))))
    (list
     (and fn
          (namestring
           (merge-pathnames (make-pathname :type "lisp")
                            fn)))
     ;; we want that a little more precise ...
     `("\\(defclass\\|define-protocol-class\\)" ,(patternfy class) _
       (* $ (,(patternfy name) *) *)
       *)
     nil)))

(defmethod source-match-pattern ((thing function))
  (let ((file (get-simple-source-info thing)))
    (list
     file
     `("defun" $ ,(patternfy (KERNEL:%FUNCTION-NAME thing)) *)
     nil)))

(defun macro-function-source-match-pattern (thing)
  (let ((file (get-simple-source-info thing)))
    (list
     file
     `("defmacro" $ ,(patternfy (cadr (KERNEL:%FUNCTION-NAME thing))) *)
     nil)))

(defun get-simple-source-info (fun)
  (let ((path (ilisp::fun-defined-from-pathname fun)))
    (when (and path (probe-file path))
      (namestring (truename path)))))

(defun ilisp::source-file-2 (name package type)
  type
  (let ((*package* (find-package :cl-user)))
    (prin1
     (let ((symbol (find-symbol (string-upcase name) (string-upcase package))))
       (cond ((and symbol
                   (and (fboundp symbol))
                   (typep (symbol-function symbol) 'standard-generic-function))
              (source-file-2-gfun (symbol-function symbol)))
             ((and symbol
                   (macro-function symbol)
                   )
              (list (macro-function-source-match-pattern (macro-function symbol))))
             ((and symbol
                   (and (fboundp symbol))
                   (typep (symbol-function symbol) 'function))
              (list (source-match-pattern (symbol-function symbol))))
             (t
              nil)))))
  (values))

(defun source-file-2-gfun (gfun)
  (mapcar #'source-match-pattern (pcl:generic-function-methods gfun)))