(require 'org-element)
(require 'string-inflection)

(setq *test-tags* (json-read-file "TAGS2"))
(setq *keys* (delete-dups (mapcar (lambda (x) (mapcar (lambda (y) (car y)) x)) *test-tags*)))

(defun classes-with-members (tags-data)
 (delete nil (delete-dups
              (mapcar
               (lambda (x)
                 (if (string-equal (alist-get 'scopeKind x) "class")
                     (alist-get 'scope x)))
               tags-data))))

(defun find-class (cls tags)
 (delete
  nil (mapcar (lambda (x) (let ((val (alist-get 'name x)))
                            (if (string-equal val cls) x)))
              tags)))

(defun find-class-members (cls tags)
 ;;; These are only like "m_*" members, not like member
 ;;; functions or getters or anything like that.
 (delete
  nil (mapcar (lambda (x)
                (if
                    (and (string-equal (alist-get 'scopeKind x) "class")
                         (string-equal (alist-get 'kind x) "member")
                         (string-equal (alist-get 'scope x) cls))
                    x))
              tags)))


(defun tag-apply-predicates (tag-record conditions)
   (mapcar
    (lambda (condition)
      (pcase-let ((`(,func ,p ,q) condition))
        (let ((x (apply func (list (alist-get p tag-record) q))))
          (if (equal nil x) nil
            tag-record))))
    conditions))

(defun find-tags (tags-data conditions)
 ;;; `conditions` is a list with a comparison function,
 ;;;  an alist key, and a value for comparison.
 (delete
  nil
  (mapcan (lambda (tag-record)
            (let ((candidate (tag-apply-predicates tag-record conditions)))
              (if (member nil candidate) nil
                candidate)))
          tags-data)))

(defun select-from-tags (tags-data keys &rest conditions)
 ;;; This one is fit for public consumption.
 (delete-dups
  (mapcar
   (lambda (x) (mapcar (lambda (k) (alist-get k x)) keys))
   (find-tags tags-data conditions))))


(defun tag-namespaced-name (tag)
 (let ((has-namespacep (alist-get 'scopeKind tag)))
   (if (string-equal has-namespacep "namespace")
       (string-join (list (alist-get 'scope tag) "::" (alist-get 'name tag)))
     (alist-get 'name tag))))


(setq *prototypes* (select-from-tags
                   *test-tags*
                   '(name access scope signature)
                   '(string-equal kind "prototype")))

(setq *render-window*
     '("sf::RenderWindow::RenderWindow" "public" "sf::RenderWindow"
       "(WindowHandle handle,const ContextSettings & settings=ContextSettings ())"))

(defun tag-wildcard (x y) t)
(setq *tag-wildcard* '(tag-wildcard i j))

(defun get-header-type-signature-info (tags-data header-path)
 (let* ((prototype-keys '(path name access typeref scope scopeKind signature))
        (parameter-keys '(name typeref))
        (prototypes
         (mapcar (lambda (x) (seq-mapn 'cons prototype-keys x))
                 (select-from-tags
                  tags-data
                  prototype-keys
                  '(string-equal kind "prototype")
                  `(string-equal path ,header-path)))))
   (mapcar (lambda (x)
             (let* ((parameter-info-list (select-from-tags
                                          tags-data parameter-keys
                                          `(string-equal scope ,(alist-get 'name x))
                                          `(string-equal kind "parameter")))
                    (parameter-info-alist (mapcar
                                           (lambda (p) (seq-mapn 'cons parameter-keys p))
                                           parameter-info-list)))
               (cons `(parameters . ,parameter-info-alist) x)))
           prototypes)))

(defun get-all-header-type-signature-info (tags-data)
 (mapcar (lambda (h) (get-header-type-signature-info tags-data h))
         (mapcar
          'car
          (select-from-tags tags-data '(path) *tag-wildcard*))))

(defun get-signatures (tags) (delete nil (get-all-header-type-signature-info tags)))
(defun get-qualified-signatures (tags)
 (let ((qualified (mapcar (lambda (s)
                           (seq-filter
                            (lambda (x) (and
                                         (string-match-p "sf::.+" (alist-get 'name x))
                                         (string-equal "public" (alist-get 'access x))))
                            s))
                          (get-signatures tags))))
   (seq-filter (lambda (x) (not (equal x nil))) qualified)))
(defun get-paths (tags)
 (seq-sort
  'string-collate-lessp
  (mapcar (lambda (x) (alist-get 'path (car x)))
          (get-qualified-signatures tags))))


(setq *signatures* (get-signatures *test-tags*))
     ;;(delete nil (get-all-header-type-signature-info *test-tags*)))
(setq *qualified-signatures* (get-qualified-signatures *test-tags*))
;; (let ((qualified (mapcar (lambda (s)
;;                          (seq-filter
;;                           (lambda (x) (and
;;                                        (string-match-p "sf::.+" (alist-get 'name x))
;;                                        (string-equal "public" (alist-get 'access x))))
;;                           s))
;;                        *signatures*)))
;;   (seq-filter (lambda (x) (not (equal x nil))) qualified)))
(setq *paths* (get-paths *test-tags*))
     ;(seq-sort
;              'string-collate-lessp
;              (mapcar (lambda (x) (alist-get 'path (car x))) *qualified-signatures*)))

(defun constructor-p (prototype)
 (let ((scope (split-string (alist-get 'scope prototype) "::"))
       (name (split-string (alist-get 'name prototype) "::")))
   (equal (last scope) (last name))))

(defun destructor-p (prototype)
 (let ((name (split-string (alist-get 'name prototype) "::")))
   (if (string-match-p "^~.+" (car (last name))) t nil)))

(defun constructor-type (prototype)
 (if (or (destructor-p prototype) (constructor-p prototype)) (alist-get 'scope prototype) nil))

(defun find-param-symbol (param) (car (last (split-string param " "))))

(defun find-param-type (param)
 (let* ((param-tokens (split-string param " "))
        (token-count (length param-tokens)))
   (string-join (seq-take param-tokens (- token-count 1)) " ")))

(defun prepare-signature (sig)
 (let* ((sig-list (split-string (string-trim sig "(" ")") ","))
        (type-symbol-pairs (mapcar
                            (lambda (x) `(,(find-param-type x) ,(find-param-symbol x)))
                            sig-list))

        ;; In most cases, the first parameter should be the object. Then, the predicate
        ;; can be called like `render_window_draw(RenderWindow, Drawable, RenderStates).`

        ;; Other clause orders could be like `render_window_some_static_method(X,Y,Z).`
        ;; for static methods; and `render_window_create(RenderWindow, H, W, Etc).`
        ;; The order matters for currying and sequential application and stuff -- probly
        ;; need to adhere to some standard conventions to keep from getting confused.

        (param-enum (number-sequence 1 (length type-symbol-pairs))))
   (seq-mapn (lambda (i j) (cons (number-to-string i) j)) param-enum type-symbol-pairs)))

(defun format-parameter-rows (sig)
 (let ((row-data (mapcar (lambda (x) (string-join x " | ")) (prepare-signature sig))))
   (string-join (mapcar (lambda (x) (format "| %s | | |" x)) row-data) "\n")))

(defun parameter-table-columns ()
 (let ((columns '("Argv Idx"    "C++ type"    "C++ symbol"
                  "Prolog term" "Prolog mode" "Prolog type")))
   (format "| %s |" (string-join columns " | "))))

(defun make-parameter-table (sig)
 (format "%s\n|-\n%s"
         (parameter-table-columns) (format-parameter-rows sig)))

(defun insert-parameter-table (sig)
 (insert (make-parameter-table sig))
 (org-table-align))

(defun upcase-p (c)
 (let ((s (char-to-string c)))
   (and (string-match "[A-Z]" s)
        (string-equal s (upcase s)))))

(defun look-ahead (char-list i) (nth (+ i 1) char-list))

(defun camel-to-snake (s) (string-inflection-underscore-function s))
(defun camel-to-pascal (s) (string-inflection-pascal-case-function s))


;%(defun camel-to-snake (s)
;%  (string-match-

(defun get-module-name (prototype)
 (let* ((path (alist-get 'path prototype))
        (module-name (last (split-string path "/"))))
   (camel-to-snake (car (split-string (car module-name) ".hpp")))))

(setq *sprite* (car (seq-filter
                    (lambda (x) (string-equal (alist-get 'path (car x))
                                              "include/SFML/Graphics/Sprite.hpp"))
                    *qualified-signatures*)))


;; Argv Idx, SFML type, C++ Parameter, Prolog term, Prolog type, Prolog mode

'(:namespace :module :fn-name :return-type :caller-type :argv-idx :parameter-type)

(defun get-return-type (prototype)
 (cond ((constructor-p prototype) (alist-get 'scope prototype))
       ((destructor-p prototype) "void")
       (t (string-remove-prefix "typename:" (alist-get 'typeref prototype)))))


(defvar *constructor* "constructor")
(defvar *destructor* "destructor")
(defvar *member-function* "member-function")
(defvar *member-data* "member-data")

(defun get-prototype-role (prototype)
 (cond ((constructor-p prototype) *constructor*)
       ((destructor-p prototype) *destructor*)
       (t *member-function*)))


(defun prototype-information (namespace prototype)
 `((:namespace . ,namespace)
   (:module . ,(get-module-name prototype))
   (:fn-name . ,(alist-get 'name prototype))
   (:return-type . ,(get-return-type prototype))
   (:caller-type . ,(alist-get 'scope prototype))
   (:role . ,(get-prototype-role prototype))))

(defun parameter-information (argv-idx parameter)
 `((:argv-idx   . ,argv-idx)
   (:param-type . ,(string-remove-prefix "typename:" (alist-get 'typeref parameter)))
   (:param-sym  . ,(alist-get 'name parameter))))

(defun parameter-list-information (prototype-information parameter-list)
 (let ((caller-info `((:argv-idx . 1)
                      (:param-type . ,(alist-get :caller-type prototype-information))
                      (:param-sym . "<-this"))))
   (cond ((not parameter-list) (list caller-info))
         ((= 1 (length parameter-list)) (append caller-info
                                              `(,(parameter-information 2 (car parameter-list)))))
         (t (let ((argv-index (number-sequence 0 (- (length parameter-list) 1))))
              (append
               `(,caller-info)
               (mapcar
                (lambda (idx) (let ((param (nth idx parameter-list)))
                                (parameter-information (+ 2 idx) param)))
                argv-index)))))))

(defun get-tabular-prototype-signature (namespace prototype)
 (let ((prototype-info (prototype-information namespace prototype)))
   (mapcar
    (lambda (x) (append prototype-info x))
    (parameter-list-information prototype-info (alist-get 'parameters prototype)))))


(setq *sprite-info* (prototype-information "graphics" (car *sprite*)))
(setq *sprite-params* (parameter-list-information *sprite-info* (alist-get 'parameters (car *sprite*))))


(defun prototype-signature-row-infer-prolog-functor (tabular-signature-row)
 (let* ((qualified-name (split-string (alist-get :fn-name tabular-signature-row) "::"))
        (name-parts-count (length qualified-name))
        (name-parts (seq-take (reverse qualified-name) (- name-parts-count 1)))
        (role (alist-get :role tabular-signature-row)))
   (camel-to-snake
    (cond ((string-equal role *constructor*)
           (concat (string-join (delete-dups name-parts) "_") "_create"))
          ((string-equal role *destructor*) (concat (string-join (delete-dups name-parts) "_") "_delete"))
          ((string-equal role *member-function*) (string-join name-parts "_"))))))

(defun prototype-signature-infer-prolog-functor (tabular-signature)
 (prototype-signature-row-infer-prolog-functor (car tabular-signature)))

(defvar *<-this* "<-this")

(defun infer-prolog-term (tabular-signature-row)
 (let ((cpp-sym (alist-get :param-sym tabular-signature-row)))
   (cond ((string-equal cpp-sym *<-this*) (camel-to-pascal
                                           (alist-get :module tabular-signature-row)))
         (t (camel-to-pascal cpp-sym)))))

(defun prototype-signature-row-infer-prolog-information (tabular-signature-row)
 `((:prolog-functor . ,(prototype-signature-row-infer-prolog-functor tabular-signature-row))
   (:prolog-term . ,(infer-prolog-term tabular-signature-row))))  ;;;,(camel-to-pascal (alist-get :param-sym tabular-signature-row)))))

(defun prototype-signature-infer-prolog-information (tabular-signature)
 (mapcar 'prototype-signature-row-infer-prolog-information tabular-signature))

You are viewing proxied material from sdf.org. The copyright of proxied material belongs to its original authors. Any comments or complaints in relation to proxied material should be directed to the original authors of the content concerned. Please see the disclaimer for more details.