supertag/supertag-ops-schema.el at main · yibie/supertag · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
;;; supertag/ops/schema.el --- Tag schema materialization for Supertag -*- lexical-binding: t; -*-

;;; Commentary:
;; Centralizes tag schema resolution, including inheritance handling
;; and caching. The cache stores materialized field definitions for
;; fast runtime access while preserving validation safeguards.

;;; Code:

(require 'cl-lib)
(require 'subr-x)
(require 'supertag-core-index)
(require 'supertag-core-store)

(defvar supertag-ops-schema--resolved-cache (make-hash-table :test 'equal)
  "Materialized tag schema cache keyed by tag id.")

(defvar supertag-ops-schema--source-token nil
  "Source token represented by the resolved schema cache.")

(defun supertag-ops-schema-clear-cache ()
  "Clear materialized Tag schemas."
  (setq supertag-ops-schema--resolved-cache (make-hash-table :test 'equal)
        supertag-ops-schema--source-token nil))

(defun supertag-ops-schema--ensure-plist (data)
  "Ensure DATA is represented as a plist."
  (cond
   ((null data) nil)
   ((hash-table-p data)
    (let (plist)
      (maphash (lambda (k v)
                 (setq plist (plist-put plist k v)))
               data)
      plist))
   ((listp data) data)
   (t (error "Unsupported tag data format: %S" data))))

(defun supertag-ops-schema--get-all-raw-tags ()
  "Return a hash table of tag-id -> raw tag plist."
  (let ((raw (supertag-store-get-collection :tags))
        (result (make-hash-table :test 'equal))
        (count 0))
    (when (hash-table-p raw)
      (maphash (lambda (tag-id data)
                 (setq count (1+ count))
                 (puthash tag-id (supertag-ops-schema--ensure-plist data) result))
               raw))
    result))

(defun supertag-ops-schema--detect-cycles (parent-map)
  "Raise an error when PARENT-MAP contains inheritance cycles."
  (let ((visited (make-hash-table :test 'equal))
        (stack (make-hash-table :test 'equal)))
    (cl-labels ((dfs (node path)
                  (puthash node t visited)
                  (puthash node t stack)
                  (let ((parent (gethash node parent-map)))
                    (when parent
                      (cond
                       ((gethash parent stack)
                        (error "Tag inheritance cycle detected: %s"
                               (mapconcat #'identity (append path (list parent)) " -> ")))
                       ((not (gethash parent visited))
                        (dfs parent (append path (list parent)))))))
                  (remhash node stack)))
      (maphash (lambda (tag-id _parent)
                 (unless (gethash tag-id visited)
                   (dfs tag-id (list tag-id))))
               parent-map))))

(defun supertag-ops-schema--build-parent-map (raw-tags)
  "Construct a child->parent map from RAW-TAGS and validate it."
  (let ((parent-map (make-hash-table :test 'equal)))
    (maphash
     (lambda (tag-id tag-data)
       (let ((parent (plist-get (supertag-ops-schema--ensure-plist tag-data) :extends)))
         (when (and parent (stringp parent) (not (string-empty-p parent)))
           (if (gethash parent raw-tags)
               (progn
                 (puthash tag-id parent parent-map)
                 )
             (message "[supertag] Warning: parent tag '%s' referenced by '%s' not found. Ignoring extends."
                      parent tag-id)))))
    raw-tags)
    (supertag-ops-schema--detect-cycles parent-map)
    parent-map))

(defun supertag-ops-schema--merge-field-definitions (base override)
  "Merge OVERRIDE plist onto BASE plist and return a fresh copy."
  (let ((result (copy-tree base)))
    (cl-loop for (key val) on override by #'cddr
             do (setq result (plist-put result key val)))
    result))

(defun supertag-ops-schema--get-tag-fields (tag-id _raw-tags)
  "Return global field definitions directly associated with TAG-ID."
  (let* ((assoc-table (supertag-store-get-collection :tag-field-associations))
         (defs (supertag-store-get-collection :field-definitions))
         (raw-entries (and (hash-table-p assoc-table)
                           (gethash tag-id assoc-table)))
         (order (cond
                 ((and (listp raw-entries) (plistp (car raw-entries)))
                  (mapcar (lambda (entry) (plist-get entry :field-id))
                          raw-entries))
                 ((listp raw-entries) raw-entries)
                 (t nil)))
         result)
    (dolist (fid order (nreverse result))
      (when-let* ((def (and fid (hash-table-p defs) (gethash fid defs))))
        (push (copy-tree def) result)))))

(defun supertag-ops-schema--resolve-fields-for-tag (tag-id parent-map raw-tags)
  "Resolve final fields for TAG-ID using PARENT-MAP and RAW-TAGS."
  (let ((chain '())
        (current tag-id))
    (while current
      (push current chain)
      (setq current (gethash current parent-map)))
    (let ((ordered-fields '()))
      (dolist (tid (nreverse chain))
        (let ((fields (supertag-ops-schema--get-tag-fields tid raw-tags)))
          (dolist (field fields)
            (let ((name (or (plist-get field :name)
                            (plist-get field :id))))
              (when name
                (let ((existing (cl-assoc name ordered-fields :test #'equal)))
                  (if existing
                      ;; Merge: child properties override parent properties while preserving position.
                      (setcdr existing (supertag-ops-schema--merge-field-definitions (cdr existing) field))
                    ;; Append new field, preserving declared order.
                    (setq ordered-fields
                          (append ordered-fields (list (cons name (copy-tree field))))))))))))
      (mapcar #'cdr ordered-fields))))

(defun supertag-ops-schema--materialize-all ()
  "Populate `supertag-ops-schema--resolved-cache' with materialized schemas."
  (let* ((raw-tags (supertag-ops-schema--get-all-raw-tags))
         (parent-map (supertag-ops-schema--build-parent-map raw-tags)))
    (clrhash supertag-ops-schema--resolved-cache)
    (maphash
     (lambda (tag-id tag-data)
       (let* ((final-fields (supertag-ops-schema--resolve-fields-for-tag tag-id parent-map raw-tags))
              (materialized (plist-put (copy-sequence (supertag-ops-schema--ensure-plist tag-data))
                                       :fields final-fields)))
         (puthash tag-id materialized supertag-ops-schema--resolved-cache)))
     raw-tags)))

;;;###autoload
(defun supertag-ops-schema-rebuild-cache ()
  "Rebuild the tag schema materialization cache."
  (interactive)
  (condition-case err
      (progn
        (supertag-ops-schema--materialize-all)
        (setq supertag-ops-schema--source-token
              (supertag-index-source-token
               '(:tags :field-definitions :tag-field-associations)))
        (when (called-interactively-p 'interactive)
          (message "Supertag schema cache rebuilt (%d tags)."
                   (hash-table-count supertag-ops-schema--resolved-cache))))
    (error
     (supertag-ops-schema-clear-cache)
     (signal (car err) (cdr err)))))

(defun supertag-ops-schema-get-resolved-tag (tag-id)
  "Return the materialized tag plist for TAG-ID, or nil if not cached."
  (unless (supertag-index-source-current-p
           supertag-ops-schema--source-token
           '(:tags :field-definitions :tag-field-associations))
    (supertag-ops-schema-rebuild-cache))
  (gethash tag-id supertag-ops-schema--resolved-cache))

(provide 'supertag-ops-schema)

;;; supertag/ops/schema.el ends here