;;;
;;; This text is copied from the web page:
;;;   http://clang.llvm.org/docs/LibASTMatchersReference.html
;;;
;;; Copy the three sections for Node Matchers, Narrowing matchers and Traversal matchers
;;; into the files node.txt, narrowing.txt and traversal.txt
;;; and run this program

;;; Load the lists that describe each matcher.
;;; They describe the VariadicDynCastAllOfMatcher<SourceT,TargetT> matcher
;;; where each entry is (SourceT matcher TargetT)
;;; The way they work is the second entry cooresponds to a C++ matcher with the
;;; C++ name eg: :class-template-decl -> classTemplateDecl(...)
;;; The third entry and further correspond to the types of the arguments of
;;; the matcher.
;;; The first entry cooresponds to the type that the matcher matches.
;;; The first entry cooresponds to the type of the matcher and any other matcher
;;; that has that type as an argument can contain this matcher.

(defun extract-matcher-class (str)
  (let ((pos-< (position #\< str))
        (pos-> (position #\> str)))
    (if pos-<
        (ast-tooling:intern-matcher-keyword (subseq str (1+ pos-<) pos->))
        (ast-tooling:intern-matcher-keyword str))))

(defun parse-node-matcher-line (line)
  (let ((*readtable* (copy-readtable)))
    (setf (readtable-case *readtable*) :preserve)
    (flet ((ellipsis-reader (stream char)
             (declare (ignore char))
             (let ((dot1 (read-char stream))
                   (dot2 (read-char stream)))
               :ellipsis)))
      (set-macro-character #\. #'ellipsis-reader)
      (with-input-from-string (sin line)
        (let ((a (extract-matcher-class (string (read sin))))
              (b (ast-tooling:intern-matcher-keyword (string (read sin))))
              (c (extract-matcher-class (string (read sin)))))
          (list a b c))))))

(defun substitute-colons (line)
  (let* ((sa (substitute #\_ #\: line)))
    sa))

(defun parse-node-matcher-rules (rules)
  (with-open-file (sin rules :direction :input)
    (loop for line = (read-line sin nil :eof)
       until (eq line :eof)
       when (> (length line) 0)
       collect (parse-node-matcher-line (substitute-colons line)))))

(defun intern-argument (x y)
  (intern (format nil "~a-~a" (string-upcase x) (string-upcase (string y))) :keyword))

(defun extract-narrowing-arguments (arguments)
  (let ((cur arguments)
        results)
    (block args
      (loop
         (unless cur (return-from args (nreverse results)))
         (let* ((sym (car cur))
                (str (string sym)))
           (cond
             ((search "Matcher<" str)
              (push (extract-matcher-class str) results))
             ((eq sym :ellipsis) 
              (push :ellipsis results))
             ((eq sym '|std__string|)
              (setf cur (cdr cur))
              (let ((arg (intern-argument "string" (car cur))))
                (push arg results)))
             ((eq sym '|StringRef|)
              (setf cur (cdr cur))
              (let ((arg (intern-argument "stringref" (car cur))))
                (push arg results)))
             ((eq sym '|unsigned|)
              (setf cur (cdr cur))
              (let ((arg (intern-argument "unsigned" (car cur))))
                (push arg results)))
             ((eq sym '|double|)
              (setf cur (cdr cur))
              (let ((arg (intern-argument "double" (car cur))))
                (push arg results)))
             ((eq sym '|CastKind|)
              (setf cur (cdr cur))
              (let ((arg (intern-argument "CastKind" (car cur))))
                (push arg results)))
             ((eq sym '|bool|)
              (setf cur (cdr cur))
              (let ((arg (intern-argument "bool" (car cur))))
                (push arg results)))
             ((eq sym '|Decl*|)
              (setf cur (cdr cur))
              (let ((arg (intern-argument "Decl*" (car cur))))
                (push arg results)))
             ((eq sym '|Stmt*|)
              (setf cur (cdr cur))
              (let ((arg (intern-argument "Stmt*" (car cur))))
                (push arg results)))
             ((eq sym '|Type*|)
              (setf cur (cdr cur))
              (let ((arg (intern-argument "Type*" (car cur))))
                (push arg results)))
             ((eq sym '|Other|)
              (setf cur (cdr cur))
              (let ((arg (intern-argument "Other" (car cur))))
                (push arg results)))
             ((eq sym '|OpenMPClauseKind|)
              (setf cur (cdr cur))
              (let ((arg (intern-argument "OpenMPClauseKind" (car cur))))
                (push arg results)))
             ((eq sym '|=|)
              (setf cur (cdr cur))
              (let ((arg (intern-argument "=" (car cur))))
                (push arg results)))
             ((eq sym '|Regex__RegexFlags|)
              (setf cur (cdr cur))
              (let ((arg (intern-argument "Regex__RegexFlags" (car cur))))
                (push arg results)))
             ((eq sym '|ValueT|)
              (setf cur (cdr cur))
              (let ((arg (intern-argument "valuet" (car cur))))
                (push arg results)))
             ((eq sym '|attr__Kind|)
              (setf cur (cdr cur))
              (let ((arg (intern-argument "kind" (car cur))))
                (push arg results)))
             ((eq sym '|UnaryExprOrTypeTrait|)
              (setf cur (cdr cur))
              (let ((arg (intern-argument "unary-expr-or-type-trait" (car cur))))
                (push arg results)))
             ((eq sym '|nodeMatcherFunction|)
              nil)
             ((eq sym '|const|)
              nil)
             (t (error "Handle argument ~a" sym)))
           (setf cur (cdr cur)))))))

(defun parse-narrowing-matcher-line (line)
  (flet ((comma-reader (stream char)
           (declare (ignore char stream))
           (values))
         (ellipsis-reader (stream char)
           (declare (ignore char))
           (let ((dot1 (read-char stream))
                 (dot2 (read-char stream)))
             (declare (ignore dot1 dot2))
             :ellipsis)))
    (let ((*readtable* (copy-readtable)))
      (setf (readtable-case *readtable*) :preserve)
      (set-macro-character #\, #'comma-reader)
      (set-macro-character #\. #'ellipsis-reader)
      (with-input-from-string (sin line)
        (let ((a (extract-matcher-class (string (read sin)))))
          (when (eq a 'unspecified) (return-from parse-narrowing-matcher-line nil))
          (let ((b (ast-tooling:intern-matcher-keyword (string (read sin))))
                (c (loop for x = (read sin nil :eof)
                         until (eq x :eof)
                         collect x)))
            (list* a b (extract-narrowing-arguments c))))))))

(defun parse-narrowing-matcher-rules (rules)
  (let (results)
    (with-open-file (sin rules :direction :input)
      (loop for line = (let ((line (read-line sin nil :eof)))
                         (when (eq line :eof)
                           (return-from parse-narrowing-matcher-rules results))
                         line)
            when (> (length line) 0)
              do (let ((parsed (parse-narrowing-matcher-line (substitute-colons line))))
                   (format t "parsed: ~a~%" parsed)
                   (when parsed (push parsed results)))))
    (reverse results)))

(defun extract-traversal-arguments (arguments)
  (let ((cur arguments)
        results)
    (block args
      (loop
         (unless cur (return-from args (nreverse results)))
         (let* ((sym (car cur))
                (str (string sym)))
           (cond
             ((search "Matcher<" str)
              (push (extract-matcher-class str) results))
             ((eq sym :ellipsis)
              (push :ellipsis results))
             ((eq sym '|InnerMatcher|) nil)
             ((eq sym '|Matcher|) nil)
             ((eq sym '|Matcher1|) nil)
             ((eq sym '|Matcher2|) nil)
             ((eq sym '|BaseSpecMatcher|) nil)
             ((eq sym '|TraversalKind|) nil)
             ((eq sym '|TK|) nil)
             ((eq sym '|InnerType|) nil)
             ((eq sym '|Inner|) nil)
             ((eq sym '|ArgMatcher|) nil)
             ((eq sym '|ParamMatcher|) nil)
             ((eq sym '|Base|) nil)
             ((eq sym '|unsigned|)
              (setf cur (cdr cur))
              (let ((arg (intern-argument "unsigned" (car cur))))
                (push arg results)))
             (t (error "Handle argument ~a" sym)))
           (setf cur (cdr cur)))))))

(defun parse-traversal-matcher-line (line)
  (flet ((comma-reader (stream char)
           (declare (ignore char))
           (values))
         (ellipsis-reader (stream char)
           (declare (ignore char))
           (let ((dot1 (read-char stream))
                 (dot2 (read-char stream)))
             :ellipsis)) )
    (let ((*readtable* (copy-readtable)))
      (setf (readtable-case *readtable*) :preserve)
      (set-macro-character #\, #'comma-reader)
      (set-macro-character #\. #'ellipsis-reader)
      (with-input-from-string (sin line)
        (let ((a (extract-matcher-class (string (read sin))))
              (b (ast-tooling:intern-matcher-keyword (string (read sin))))
              (c (loop for x = (read sin nil :eof)
                       until (eq x :eof)
                       collect x)))
          (list* a b (extract-traversal-arguments c)))))))

(defun parse-traversal-matcher-rules (rules)
  (with-open-file (sin rules :direction :input)
    (loop for line = (read-line sin nil :eof)
       until (eq line :eof)
       when (> (length line) 0)
       collect (parse-traversal-matcher-line (substitute-colons line)))))

(let ((rules-suffix "-13"))
  (setf *default-pathname-defaults* (truename "sys:src;lisp;modules;clang-tool;"))
  (with-open-file (fout (pathname (format nil "./rules~a.lisp" rules-suffix)) :direction :output :if-exists :supersede)
    (let* ((node-matcher-rules (parse-node-matcher-rules (pathname (format nil "node-matchers~a.txt" rules-suffix))))
           (narrowing-matcher-rules (parse-narrowing-matcher-rules (pathname (format nil "narrowing-matchers~a.txt" rules-suffix))))
           (traversal-matcher-rules (parse-traversal-matcher-rules (pathname (format nil "traversal-matchers~a.txt" rules-suffix)))))
      (format fout "(in-package :clang-tool)~%")
      (format fout "(defparameter *node-matcher-rules* ~%'~s)~%" node-matcher-rules)
      (format fout "(defparameter *narrowing-matcher-rules* ~%'~s)~%" narrowing-matcher-rules)
      (format fout "(defparameter *traversal-matcher-rules* ~%'~s)~%" traversal-matcher-rules))))
