ADD function to add goal link

local/lib/org-x/org-x-dag.el

@@ -137,6 +137,17 @@ that file as it currently sits on disk.")
           (parent-tags (and inherit? (ascend id nil))))
       (append local-tags parent-tags init))))
 
+(defun org-x-dag-id->link (id)
+  (org-x-dag-with-id-in-file id
+    (let ((desc (org-get-heading t t t t)))
+      (->> (org-ml-build-secondary-string! desc)
+           (apply #'org-ml-build-link id :type "id")))))
+
+(defun org-x-dag-id->link-item (id)
+  (->> (org-x-dag-id->link id)
+       (org-ml-build-paragraph)
+       (org-ml-build-item)))
+
 (defun org-x-dag-id->parents (id)
   (->> (plist-get org-x-dag :dag)
        (dag-get-parents id)))
@@ -200,6 +211,124 @@ A date like (YEAR MONTH DAY).")
     (setq org-x-dag-selected-week week-date)
     (org-x-dag-set-planning-quarter-at-date week-date)))
 
+;;; PLANNING
+
+(defun org-x--qtp-headline-get-year (headline)
+  (let ((rt (org-ml-get-property :raw-value headline)))
+    (if (s-matches-p "[0-9]\\{4\\}" rt) (string-to-number rt)
+      (error "Invalid year headline in quarterly plan: %s" rt))))
+
+(defun org-x--qtp-headline-get-quarter (headline)
+  (let ((rt (org-ml-get-property :raw-value headline)))
+    (-if-let ((_ qt) (s-match "Q\\([0-9]\\)" rt)) (string-to-number qt)
+      (error "Invalid quarter headline in quarterly plan: %s" rt))))
+
+(defun org-x-dag-qtp-to-children (qt-plan)
+  (-let* (((&plist :categories :goals) qt-plan)
+          ;; TODO what happens if there are no categories?
+          (sec (-some->> categories
+                 (--map-indexed (org-ml-build-item!
+                                 :bullet it-index
+                                 :paragraph (symbol-name it)))
+                 (apply #'org-ml-build-plain-list)
+                 (org-ml-build-drawer org-x-drwr-categories)
+                 (org-ml-build-section))))
+    (if sec (cons sec goals) goals)))
+
+(defun org-x-dag-qtp-from-children (children)
+  ;; ignore properties, planning, etc
+  (-let* (((sec goals) (if (org-ml-is-type 'section (car children))
+                           `(,(car children) ,(cdr children))
+                         `(nil ,children)))
+          (cats (-some->> sec
+                  (--find (org-x--is-drawer-with-name org-x-drwr-categories it))
+                  (org-x-qtp-drawer-to-categories))))
+    (list :categories cats :goals goals)))
+
+(defun org-x-dag-qtp-get (quarter)
+  (org-x-with-file (org-x-qtp-get-file)
+    (-let (((year qnum) quarter))
+      (->> (org-ml-parse-subtrees 'all)
+           (org-x--qtp-headline-find-year year)
+           (org-ml-headline-get-subheadlines)
+           (org-x--qtp-headline-find-quarter qnum)
+           (org-ml-get-children)
+           (org-x-dag-qtp-from-children)))))
+
+(defun org-x-dag-qtp-set (quarter qt-plan)
+  (cl-flet*
+      ((build-qt-headline
+        (quarter children)
+        (let ((title (list (format "Q%s" quarter))))
+          (apply #'org-ml-build-headline :title title :level 2 children)))
+       (build-yr-headline
+        (year qnum children)
+        (->> (build-qt-headline qnum children)
+             (org-ml-build-headline! :title-text (number-to-string year)))))
+    (org-x-with-file (org-x-qtp-get-file)
+      (-let* (((year qnum) quarter)
+              (sts (org-ml-parse-subtrees 'all))
+              (children (org-x-dag-qtp-to-children qt-plan)))
+        (-if-let (st-yr (org-x--qtp-headline-find-year year sts))
+            (-if-let (st-qt (->> (org-ml-headline-get-subheadlines st-yr)
+                                 (org-x--qtp-headline-find-quarter qnum)))
+                (org-ml-update* (org-ml-set-children children it) st-qt)
+              (org-ml-update*
+                (-snoc it (build-qt-headline qnum children))
+                st-yr))
+          (let ((end (1+ (org-ml-get-property :end (-last-item sts)))))
+            (org-ml-insert end (build-yr-headline year qnum children))))))))
+
+(defmacro org-x-dag-qtp-map (quarter form)
+  (declare (indent 1))
+  `(let ((it (org-x-dag-qtp-get ,quarter)))
+     (org-x-dag-qtp-set ,quarter ,form)))
+
+(defun org-x-dag-qtp-get-key (key quarter)
+  (plist-get (org-x-dag-qtp-get quarter) key))
+
+(defun org-x-dag-qtp-set-key (quarter key xs)
+  (org-x-dag-qtp-map quarter
+    (plist-put it key xs)))
+
+(defun org-x-qtp-get-categories (quarter)
+  (org-x-dag-qtp-get-key :categories quarter))
+
+(defun org-x-qtp-get-goals (quarter)
+  (org-x-dag-qtp-get-key :goals quarter))
+
+(defun org-x-qtp-set-categories (quarter categories)
+  (org-x-dag-qtp-set-key quarter :categories categories))
+
+(defun org-x-qtp-set-goals (quarter goals)
+  (org-x-dag-qtp-set-key quarter :goals goals))
+
+(defmacro org-x-qtp-map-categories (quarter form)
+  `(let ((it (org-x-qtp-get-categories ,quarter)))
+     (org-x-qtp-set-categories ,quarter ,form)))
+
+(defmacro org-x-qtp-map-goals (quarter form)
+  `(let ((it (org-x-qtp-get-goals ,quarter)))
+     (org-x-qtp-set-goals ,quarter ,form)))
+
+(defun org-x-qtp-add-goal (quarter headline)
+  (org-x-qtp-map-goals quarter (cons headline it)))
+
+(defun org-x-dag-headline-add-id (headline)
+  (org-ml-headline-set-node-property "ID" (org-id-new) headline))
+
+(defun org-x-qtp-build-goal-headline (ids title)
+  (let ((d (org-x-dag-build-parent-link-drawer ids)))
+    (->> (org-ml-build-headline! :level 3
+                                 :title-text title
+                                 :todo-keyword org-x-kw-todo
+                                 :section-children (list d))
+         (org-x-dag-headline-add-id))))
+
+(defun org-x-qtp-add-goal-ids (quarter ids title)
+  (->> (org-x-qtp-build-goal-headline ids title)
+       (org-x-qtp-add-goal quarter)))
+
 ;;; BUFFER SCANNING
 
 (defun org-x-dag-get-local-property (prop)
@@ -852,12 +981,17 @@ FUTURE-LIMIT in a list."
 
 ;;; STATUS DETERMINATION
 
-(defmacro org-x-dag-with-key (key &rest body)
+(defmacro org-x-dag-with-id (key &rest body)
   (declare (indent 1))
   `(progn
      (goto-char (org-x-dag-id->point ,key))
      ,@body))
 
+(defmacro org-x-dag-with-id-in-file (id &rest body)
+  (declare (indent 1))
+  `(org-x-with-file (org-x-dag-id->file ,id)
+     (org-x-dag-with-id ,id ,@body)))
+
 (defun org-x-headline-get-task-status-0 (kw)
   (if (member kw org-x-done-keywords)
       (-if-let (c (org-x-dag-headline-is-closed-p t))
@@ -896,7 +1030,7 @@ FUTURE-LIMIT in a list."
                                      (alist-get top-status ',trans-tbl))))
                  (cons top-status* child-results))
              (let ((it-kw (org-x-dag-id->todo key)))
-               (org-x-dag-with-key key
+               (org-x-dag-with-id key
                  (-> ,task-form
                      (nth ',allowed-codes)
                      (list)))))))
@@ -907,7 +1041,7 @@ FUTURE-LIMIT in a list."
 
 (defun org-x-dag-headline-get-project-status (key tags children)
   ;; ASSUME children will always be at least 1 long
-  (org-x-dag-with-key key
+  (org-x-dag-with-id key
     (let ((keyword (org-x-dag-id->todo key)))
       (-let (((status . child-results)
               (cond
@@ -957,7 +1091,7 @@ FUTURE-LIMIT in a list."
         (cons (list :key key :status status :tags tags) child-results)))))
 
 (defun org-x-dag-headline-get-iterator-project-status (key children)
-  (org-x-dag-with-key key
+  (org-x-dag-with-id key
     (let* ((kw (org-x-dag-id->todo key))
            (status
             (cond
@@ -992,7 +1126,7 @@ FUTURE-LIMIT in a list."
       status)))
 
 (defun org-x-dag-headline-get-iterator-task-status (key)
-  (org-x-dag-with-key key
+  (org-x-dag-with-id key
     (if (org-x-dag-id->is-done-p key) :empt
       (-if-let (ts (or (org-x-dag-headline-is-scheduled-p t)
                        (org-x-dag-headline-is-deadlined-p t)))
@@ -1044,7 +1178,7 @@ FUTURE-LIMIT in a list."
         (-let* (((&plist :key :status :tags) result)
                 (priority (alist-get status org-x-project-status-priorities)))
           (when (>= priority 0)
-            (org-x-dag-with-key key
+            (org-x-dag-with-id key
               (-> (org-x-dag-format-tag-node cat tags key)
                   (org-add-props nil
                       'x-toplevelp (org-x-dag-id->is-toplevel-p key)
@@ -1054,7 +1188,7 @@ FUTURE-LIMIT in a list."
         (cat key)
         (let ((tags (org-x-dag-id->tags t org-file-tags key)))
           ;; TODO don't hardcode these things
-          (org-x-dag-with-key key
+          (org-x-dag-with-id key
             (unless (or (member org-x-tag-incubated tags)
                         (org-x-dag-headline-is-iterator-p))
               (-some->> (org-x-dag-id->headline-children key)
@@ -1070,7 +1204,7 @@ FUTURE-LIMIT in a list."
       ((format-result
         (tags cat key)
         (-let ((status (org-x-dag-headline-get-iterator-status key)))
-          (org-x-dag-with-key key
+          (org-x-dag-with-id key
             (-> (org-x-dag-format-tag-node cat tags key)
                 (org-add-props nil
                     'x-status status))))))
@@ -1078,7 +1212,7 @@ FUTURE-LIMIT in a list."
         (org-x-dag-id->is-toplevel-p it)
       (let ((tags (org-x-dag-id->tags t org-file-tags it)))
         (unless (member org-x-tag-incubated tags)
-          (org-x-dag-with-key it
+          (org-x-dag-with-id it
             (when (org-x-dag-headline-is-iterator-p)
               (list (format-result tags it-category it)))))))))
   
@@ -1103,7 +1237,7 @@ FUTURE-LIMIT in a list."
         (category is-standalone key)
         (let ((tags (org-x-dag-id->tags t org-file-tags key)))
           ;; filter out incubators
-          (org-x-dag-with-key key
+          (org-x-dag-with-id key
             (unless (or (member org-x-tag-incubated tags)
                         (org-x-dag-headline-is-scheduled-p nil)
                         (org-x-dag-headline-is-deadlined-p nil))
@@ -1126,7 +1260,7 @@ FUTURE-LIMIT in a list."
         (category key)
         (let ((tags (org-x-dag-id->tags t org-file-tags key)))
           (when (member org-x-tag-incubated tags)
-            (org-x-dag-with-key key
+            (org-x-dag-with-id key
               (let* ((sch (org-x-dag-headline-is-scheduled-p t))
                      (dead (org-x-dag-headline-is-deadlined-p t))
                      (is-project (org-x-dag-id->headline-children key)))
@@ -1146,7 +1280,7 @@ FUTURE-LIMIT in a list."
         (category key)
         (let ((tags (org-x-dag-id->tags t org-file-tags key)))
           (unless (member org-x-tag-incubated tags)
-            (org-x-dag-with-key key
+            (org-x-dag-with-id key
               (-let (((is-archivable is-project)
                       (-if-let (children (org-x-dag-id->headline-children key))
                           (-> (org-x-dag-headline-get-project-status key tags children)
@@ -1163,7 +1297,7 @@ FUTURE-LIMIT in a list."
                           'x-project-p is-project)))))))))
     (org-x-dag-with-files (org-x-get-action-files)
         (org-x-dag-id->is-toplevel-p it)
-      (org-x-dag-with-key it
+      (org-x-dag-with-id it
         (if (org-x-dag-headline-is-iterator-p)
             (->> (org-x-dag-id->headline-children it)
                  (--map (format-key it-category it)))
@@ -1189,7 +1323,7 @@ FUTURE-LIMIT in a list."
                                          :parentlessp nil))))))
       (org-x-dag-with-files (list (org-x-get-lifetime-goal-file))
           nil
-        (org-x-dag-with-key it
+        (org-x-dag-with-id it
           (list (format-id it-category it)))))))
 
 (defun org-x-dag-scan-epgs ()
@@ -1216,7 +1350,7 @@ FUTURE-LIMIT in a list."
                                          :parentlessp (not has-parents)))))))
       (org-x-dag-with-files (list (org-x-get-endpoint-goal-file))
           nil
-        (org-x-dag-with-key it
+        (org-x-dag-with-id it
           (list (format-id it-category it)))))))
 
 (defun org-x-dag-scan-goals ()
@@ -1226,7 +1360,7 @@ FUTURE-LIMIT in a list."
   (cl-flet
       ((format-id
         (category id)
-        (org-x-dag-with-key id
+        (org-x-dag-with-id id
           (-when-let (error-type
                       (if (org-x-dag-headline-is-iterator-p)
                           (unless (org-x-dag-get-local-property "ARCHIVE")
@@ -1240,7 +1374,7 @@ FUTURE-LIMIT in a list."
                     'x-error error-type))))))
     (org-x-dag-with-files (org-x-dag-get-files)
         (not (org-x-dag-id->is-done-p it))
-      (org-x-dag-with-key it
+      (org-x-dag-with-id it
         (list (format-id it-category it))))))
 
 (defun org-x-dag-scan-agenda (sel-date)
@@ -1258,7 +1392,7 @@ FUTURE-LIMIT in a list."
                      (--map (funcall format-datetime-fun sel-date pos it cat tags id) it)))))))
        (format-id
         (todayp cat id)
-        (org-x-dag-with-key id
+        (org-x-dag-with-id id
           (-when-let (res (org-x-dag-headline-get-planning))
             (-let (((dead sched) res))
               (append
@@ -1386,26 +1520,22 @@ FUTURE-LIMIT in a list."
                (-map #'parse-item))
         (error "Invalid parent link drawer")))))
 
-(defun org-x-dag-headline-set-parent-links (link-pairs headline)
-  (cl-flet
-      ((from-pair
-        (pair)
-        (-let (((id . desc) pair))
-          (->> (org-ml-build-secondary-string! desc)
-               (apply #'org-ml-build-link id :type "id")
-               (org-ml-build-paragraph)
-               (org-ml-build-item)))))
-    (let ((pl (->> (-map #'from-pair link-pairs)
-                   (apply #'org-ml-build-plain-list))))
-      (org-ml-headline-map-contents* (org-x-logbook-config)
-        (-if-let (i (--find-index (org-x--is-drawer-with-name
-                                   org-x-drwr-parent-links it)
-                                  it))
-            (let ((d (nth i it)))
-              (-replace-at i (org-ml-set-children (list pl) d) it))
-          (-> (org-ml-build-drawer "X_PARENT_LINKS" pl)
-            (cons it)))
-        headline))))
+(defun org-x-dag-build-parent-link-drawer (ids)
+  (->> (-map #'org-x-dag-id->link-item ids)
+       (apply #'org-ml-build-plain-list)
+       (org-ml-build-drawer "X_PARENT_LINKS")))
+
+(defun org-x-dag-headline-set-parent-links (ids headline)
+  (org-ml-headline-map-contents* (org-x-logbook-config)
+    (-if-let (i (--find-index (org-x--is-drawer-with-name
+                               org-x-drwr-parent-links it)
+                              it))
+        (let ((d (nth i it))
+              (pl (->> (-map #'org-x-dag-build-parent-link-item ids)
+                       (apply #'org-ml-build-plain-list))))
+          (-replace-at i (org-ml-set-children (list pl) d) it))
+      (cons (org-x-dag-build-parent-link-drawer ids) it))
+    headline))
 
 (defmacro org-x-dag-headline-map-parent-links* (form headline)
   (let ((h (make-symbol "--headline")))