ndwarshuis
/
emacs-config
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

FIX misuse of either (appease the haskell gods)

This commit is contained in:
Nathan Dwarshuis 2022-04-03 18:19:30 -04:00
parent 5b7bf448f2
commit 8b68d8a993
2 changed files with 135 additions and 155 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
local/lib/either/either.el
View File

@ -56,35 +56,27 @@ left/right slot."
(`(:right ,it) (either :right ,form)) (`(:right ,it) (either :right ,form))
(e (error "Learn to use functors, dummy; this isn't one: %s" e)))))) (e (error "Learn to use functors, dummy; this isn't one: %s" e))))))
(defmacro either-from-right (either default &rest body) (defun either-from-right (either default)
"Apply BODY to the right slot of EITHER. "Return contents of EITHER if right or DEFAULT."
(pcase either
(`(:left ,_) default)
(`(:right ,x) x)
(e (error "Not an either: %s" e))))
If EITHER is right, return result of FORM where the right slot is (defun either-from-left (either default)
bound to 'it'. Return DEFAULT otherwise." "Return contents of EITHER if left or DEFAULT."
(declare (indent 2)) (pcase either
`(pcase ,either (`(:left ,x) x)
(`(:left ,_) ,default) (`(:right ,_) default)
(`(:right ,it) ,@body) (e (error "Not an either: %s" e))))
(e (error "Not an either: %s" e))))
(defmacro either-from-left (either default &rest body) ;; (defun either-from-right* (either default fun)
"Apply BODY to the left slot of EITHER. ;; (declare (indent 2))
;; (either-from-right either default (funcall fun it)))
If EITHER is left, return result of FORM where the left slot is ;; (defun either-from-left* (either default fun)
bound to 'it'. Return DEFAULT otherwise." ;; (declare (indent 2))
(declare (indent 2)) ;; (either-from-left either default (funcall fun it)))
`(pcase ,either
(`(:left ,it) ,@body)
(`(:right ,_) ,default)
(e (error "Not an either: %s" e))))
(defun either-from-right* (either default fun)
(declare (indent 2))
(either-from-right either default (funcall fun it)))
(defun either-from-left* (either default fun)
(declare (indent 2))
(either-from-left either default (funcall fun it)))
(defmacro either-from (either left-form right-form) (defmacro either-from (either left-form right-form)
"Apply forms to the left or right slot of EITHER. "Apply forms to the left or right slot of EITHER.

246
local/lib/org-x/org-x-dag.el
View File

@ -2126,8 +2126,7 @@ used for optimization."
ns)) ns))
(defun org-x-dag-ht-get-maybe (htbl id key) (defun org-x-dag-ht-get-maybe (htbl id key)
(either-from-right (ht-get htbl id) nil (either-from (ht-get htbl id) nil (plist-get it key)))
(plist-get it key)))
(defun org-x-dag-ns-qtp (adjlist links ns) (defun org-x-dag-ns-qtp (adjlist links ns)
(-let (((&alist :lifetime ht-l :endpoint ht-e :quarterly ht-q) ns)) (-let (((&alist :lifetime ht-l :endpoint ht-e :quarterly ht-q) ns))
@ -2292,7 +2291,8 @@ used for optimization."
(org-x-dag-ht-propagate-down adjlist :action :planned ns) (org-x-dag-ht-propagate-down adjlist :action :planned ns)
(org-x-dag-ht-map-down adjlist :action ns (org-x-dag-ht-map-down adjlist :action ns
(lambda (h id) (lambda (h id)
(either-from-right (ht-get h id) nil (either-from (ht-get h id)
nil
(-when-let (committed (plist-get it :committed)) (-when-let (committed (plist-get it :committed))
`(,committed ,(plist-get it :survivalp))))) `(,committed ,(plist-get it :survivalp)))))
(lambda (plist to-set) (lambda (plist to-set)
@ -2668,16 +2668,16 @@ FUTURE-LIMIT in a list."
(future-limit (org-x-dag-datetime-shift sel-datetime warn-shift warn-shifttype))) (future-limit (org-x-dag-datetime-shift sel-datetime warn-shift warn-shifttype)))
(org-x-dag-unfold-timestamp sel-datetime d r future-limit))) (org-x-dag-unfold-timestamp sel-datetime d r future-limit)))
(defun org-x-dag-headline-get-planning () ;; (defun org-x-dag-headline-get-planning ()
(let ((end (save-excursion (outline-next-heading)))) ;; (let ((end (save-excursion (outline-next-heading))))
(save-excursion ;; (save-excursion
(when (re-search-forward org-planning-line-re end t) ;; (when (re-search-forward org-planning-line-re end t)
;; TODO this is rather slow since I'm using a general org-ml parsing ;; ;; TODO this is rather slow since I'm using a general org-ml parsing
;; function; I'm also not even using the match results from the planning ;; ;; function; I'm also not even using the match results from the planning
;; line re, which might be useful ;; ;; line re, which might be useful
(-let* ((pl (org-ml-parse-this-element))) ;; (-let* ((pl (org-ml-parse-this-element)))
(->> (org-ml-get-properties '(:deadline :scheduled) pl) ;; (->> (org-ml-get-properties '(:deadline :scheduled) pl)
(--map (-some-> it (org-x-dag-partition-timestamp))))))))) ;; (--map (-some-> it (org-x-dag-partition-timestamp)))))))))
(defun org-x-dag-id->agenda-timestamp (id) (defun org-x-dag-id->agenda-timestamp (id)
"Retrieve timestamp information of ID for sorting agenda views. "Retrieve timestamp information of ID for sorting agenda views.
@ -2743,8 +2743,9 @@ except it ignores inactive timestamps."
;; misc ;; misc
'type (concat "tagsmatch" ts-type))))) 'type (concat "tagsmatch" ts-type)))))
(defun org-x-dag-format-item (id extra category tags time) (defun org-x-dag-format-item (id extra tags time)
(let* ((tags* (org-x-dag-prepare-tags tags)) (let* ((tags* (org-x-dag-prepare-tags tags))
(category (org-x-dag-id->hl-meta-prop id :category))
(level (org-x-dag-id->formatted-level id)) (level (org-x-dag-id->formatted-level id))
(todo-state (org-x-dag-id->todo id)) (todo-state (org-x-dag-id->todo id))
(head (format "%s %s" todo-state (org-x-dag-id->title id))) (head (format "%s %s" todo-state (org-x-dag-id->title id)))
@ -2772,7 +2773,7 @@ except it ignores inactive timestamps."
'ts-date (org-x-dag-date-to-absolute ts-date) 'ts-date (org-x-dag-date-to-absolute ts-date)
'type type)) 'type type))
(defun org-x-dag-format-scheduled-node (sel-date pos datetime category tags id) (defun org-x-dag-format-scheduled-node (sel-date pos datetime tags id)
(-let* (((this-date this-time) (org-x-dag-datetime-split datetime)) (-let* (((this-date this-time) (org-x-dag-datetime-split datetime))
(diff (org-x-dag-date-diff this-date sel-date)) (diff (org-x-dag-date-diff this-date sel-date))
(pastp (< diff 0)) (pastp (< diff 0))
@ -2789,10 +2790,10 @@ except it ignores inactive timestamps."
`(,sel-date "scheduled"))) `(,sel-date "scheduled")))
(props (org-x-dag-planning-props id face pos date this-date type))) (props (org-x-dag-planning-props id face pos date this-date type)))
;; NOTE: I don't care about habits, no need to consider them ;; NOTE: I don't care about habits, no need to consider them
(-> (org-x-dag-format-item id extra category tags this-time) (-> (org-x-dag-format-item id extra tags this-time)
(org-add-props props)))) (org-add-props props))))
(defun org-x-dag-format-deadline-node (sel-date pos datetime category tags id) (defun org-x-dag-format-deadline-node (sel-date pos datetime tags id)
(-let* (((this-date this-time) (org-x-dag-datetime-split datetime)) (-let* (((this-date this-time) (org-x-dag-datetime-split datetime))
(diff (org-x-dag-date-diff this-date sel-date)) (diff (org-x-dag-date-diff this-date sel-date))
(pastp (< diff 0)) (pastp (< diff 0))
@ -2812,7 +2813,7 @@ except it ignores inactive timestamps."
((date type) (if futurep `(,sel-date "upcoming-deadline") ((date type) (if futurep `(,sel-date "upcoming-deadline")
`(,this-date "deadline"))) `(,this-date "deadline")))
(props (org-x-dag-planning-props id face pos date this-date type))) (props (org-x-dag-planning-props id face pos date this-date type)))
(-> (org-x-dag-format-item id extra category tags this-time) (-> (org-x-dag-format-item id extra tags this-time)
(org-add-props props)))) (org-add-props props))))
;;; ID FUNCTIONS ;;; ID FUNCTIONS
@ -3156,28 +3157,24 @@ except it ignores inactive timestamps."
(defun org-x-dag-scan-projects () (defun org-x-dag-scan-projects ()
(org-x-dag-with-action-ids (org-x-dag-with-action-ids
(either-from-right* (org-x-dag-id->bs it) nil (pcase (either-from-right (org-x-dag-id->bs it) nil)
(lambda (bs) (`(:sp-proj . ,status-data)
(pcase bs ;; NOTE in the future there might be more than just the car to this
(`(:sp-proj . ,status-data) (let ((status (car status-data)))
;; NOTE in the future there might be more than just the car to this (-when-let (priority (cl-case status
(let ((status (car status-data))) (:proj-active 4)
(-when-let (priority (cl-case status (:proj-wait 3)
(:proj-active 4) (:proj-hold 2)
(:proj-wait 3) (:proj-stuck 1)))
(:proj-hold 2) (-when-let ((&plist :committed) (-when-let (ns (org-x-dag-id->ns it))
(:proj-stuck 1))) (either-from-right ns nil)))
(-when-let (ns (org-x-dag-id->ns it)) (let ((tags (org-x-dag-id->tags nil it)))
(either-from-right* ns nil (-> (org-x-dag-format-tag-node tags it)
(lambda (it-ns) (org-add-props nil
(when (plist-get it-ns :committed) 'x-toplevelp (org-x-dag-id->is-toplevel-p it)
(let ((tags (org-x-dag-id->tags nil it))) 'x-status status
(-> (org-x-dag-format-tag-node tags it) 'x-priority priority)
(org-add-props nil (list))))))))))
'x-toplevelp (org-x-dag-id->is-toplevel-p it)
'x-status status
'x-priority priority)
(list)))))))))))))))
(defun org-x-dag--item-add-goal-ids (item ids) (defun org-x-dag--item-add-goal-ids (item ids)
(if ids (if ids
@ -3186,17 +3183,15 @@ except it ignores inactive timestamps."
(defun org-x-dag-scan-iterators () (defun org-x-dag-scan-iterators ()
(org-x-dag-with-action-ids (org-x-dag-with-action-ids
(either-from-right (org-x-dag-id->bs it) nil (pcase (either-from-right (org-x-dag-id->bs it) nil)
(lambda (bs) (`(:sp-proj . ,status-data)
(pcase bs (let ((status (car status-data)))
(`(:sp-proj . ,status-data) (when (memq status '(:iter-empty :iter-active))
(let ((status (car status-data))) (let ((tags (org-x-dag-id->tags nil it)))
(when (memq status '(:iter-empty :iter-active)) (-> (org-x-dag-format-tag-node tags it)
(let ((tags (org-x-dag-id->tags nil it))) (org-add-props nil
(-> (org-x-dag-format-tag-node tags it) 'x-status status)
(org-add-props nil (list)))))))))
'x-status status)
(list)))))))))))
(defun org-x-dag-get-task-nodes (pred id) (defun org-x-dag-get-task-nodes (pred id)
(declare (indent 2)) (declare (indent 2))
@ -3214,57 +3209,51 @@ except it ignores inactive timestamps."
;; TODO this includes tasks underneath cancelled headlines ;; TODO this includes tasks underneath cancelled headlines
(defun org-x-dag-scan-tasks () (defun org-x-dag-scan-tasks ()
(org-x-dag-with-action-ids (org-x-dag-with-action-ids
(either-from-right* (org-x-dag-id->bs it) nil (pcase (either-from-right (org-x-dag-id->bs it) nil)
(lambda (bs) (`(:sp-task :task-active ,s)
(pcase bs (-let (((&plist :todo :sched :dead) s))
(`(:sp-task :task-active ,s) (-let (((&plist :committed c) (-when-let (ns (org-x-dag-id->ns it))
(-let (((&plist :todo :sched :dead) s)) (either-from-right ns nil))))
(-when-let (ns (org-x-dag-id->ns it)) (when (and (not sched) (not dead) c)
(either-from-right* ns nil (let ((tags (org-x-dag-id->tags nil it))
(lambda (it-ns) (bp (org-x-dag-id->buffer-parent it)))
(-let (((&plist :committed c) it-ns)) (-> (org-x-dag-format-tag-node tags it)
(when (and (not sched) (not dead) c) (org-add-props nil
(let ((tags (org-x-dag-id->tags nil it)) 'x-is-standalone (not bp)
(bp (org-x-dag-id->buffer-parent it))) 'x-status :active)
(-> (org-x-dag-format-tag-node tags it) (list))))))))))
(org-add-props nil
'x-is-standalone (not bp)
'x-status :active)
(list)))))))))))))))
(defun org-x-dag-scan-tasks-with-goals () (defun org-x-dag-scan-tasks-with-goals ()
(org-x-dag-with-action-ids (org-x-dag-with-action-ids
(either-from-right* (org-x-dag-id->bs it) nil (pcase (either-from-right (org-x-dag-id->bs it) nil)
(lambda (bs) (`(:sp-task :task-active ,s)
(pcase bs (-let (((&plist :todo) s)
(`(:sp-task :task-active ,s) (goal-ids (-when-let (ns (org-x-dag-id->ns it))
(-let (((&plist :todo) s) (either-from ns
(goal-ids (-when-let (ns (org-x-dag-id->ns it)) nil
(either-from-right ns nil (unless (plist-get it :survivalp)
(unless (plist-get it :survivalp) (plist-get it :committed)))))
(plist-get it :committed))))) (tags (org-x-dag-id->tags nil it))
(tags (org-x-dag-id->tags nil it)) (bp (org-x-dag-id->buffer-parent it)))
(bp (org-x-dag-id->buffer-parent it))) (-> (org-x-dag-format-tag-node tags it)
(-> (org-x-dag-format-tag-node tags it) (org-add-props nil
(org-add-props nil 'x-is-standalone (not bp)
'x-is-standalone (not bp) 'x-status :active)
'x-status :active) (org-x-dag--item-add-goal-ids goal-ids)))))))
(org-x-dag--item-add-goal-ids goal-ids)))))))))
(defun org-x-dag-scan-projects-with-goals () (defun org-x-dag-scan-projects-with-goals ()
(org-x-dag-with-action-ids (org-x-dag-with-action-ids
(either-from-right* (org-x-dag-id->bs it) nil (pcase (either-from-right (org-x-dag-id->bs it) nil)
(lambda (bs) (`(:sp-proj . ,s)
(pcase bs (unless (eq (car s) :proj-complete)
(`(:sp-proj . ,s) (let ((goal-ids (-when-let (ns (org-x-dag-id->ns it))
(unless (eq (car s) :proj-complete) (either-from ns
(let ((goal-ids (-when-let (ns (org-x-dag-id->ns it)) nil
(either-from-right ns nil (unless (plist-get it :survivalp)
(unless (plist-get it :survivalp) (plist-get it :committed)))))
(plist-get it :committed))))) (tags (org-x-dag-id->tags nil it)))
(tags (org-x-dag-id->tags nil it))) (-> (org-x-dag-format-tag-node tags it)
(-> (org-x-dag-format-tag-node tags it) (org-x-dag--item-add-goal-ids goal-ids))))))))
(org-x-dag--item-add-goal-ids goal-ids))))))))))
(defun org-x-dag-scan-survival-tasks () (defun org-x-dag-scan-survival-tasks ()
(cl-flet (cl-flet
@ -3342,19 +3331,17 @@ except it ignores inactive timestamps."
(defun org-x-dag-scan-archived () (defun org-x-dag-scan-archived ()
(org-x-dag-with-action-ids (org-x-dag-with-action-ids
(either-from-right* (org-x-dag-id->bs it) nil (-when-let ((comptime is-project)
(lambda (bs) (pcase (either-from-right (org-x-dag-id->bs it) nil)
(-when-let ((comptime is-project) (`(:sp-proj :proj-complete ,c) `(,c t))
(pcase bs (`(:sp-task :task-complete ,c) `(,c nil))))
(`(:sp-proj :proj-complete ,c) `(,c t)) (-let ((epoch (plist-get comptime :epoch)))
(`(:sp-task :task-complete ,c) `(,c nil)))) (when (org-x-dag-time-is-archivable-p epoch)
(-let ((epoch (plist-get comptime :epoch))) (let ((tags (org-x-dag-id->tags nil it)))
(when (org-x-dag-time-is-archivable-p epoch) (-> (org-x-dag-format-tag-node tags it)
(let ((tags (org-x-dag-id->tags nil it))) (org-add-props nil
(-> (org-x-dag-format-tag-node tags it) 'x-project-p is-project)
(org-add-props nil (list))))))))
'x-project-p is-project)
(list))))))))))
(defun org-x-dag--classify-goal-link (which which-goal id) (defun org-x-dag--classify-goal-link (which which-goal id)
(let ((f (org-x-dag-id->file id))) (let ((f (org-x-dag-id->file id)))
@ -3448,32 +3435,33 @@ except it ignores inactive timestamps."
(defun org-x-dag-scan-agenda (sel-date) (defun org-x-dag-scan-agenda (sel-date)
(cl-flet* (cl-flet*
((format-timestamps ((format-timestamps
(todayp sel-date cat id pts get-datetimes-fun format-datetime-fun) (todayp sel-date id ts get-datetimes-fun format-datetime-fun)
(-when-let (datetimes (funcall get-datetimes-fun sel-date pts)) (let ((pts (org-x-dag-partition-timestamp ts)))
(let ((tags (org-x-dag-id->tags nil id))) (-when-let (datetimes (funcall get-datetimes-fun sel-date pts))
;; TODO this will show all tasks regardless of if they have a ;; TODO this will show all tasks regardless of if they have a
;; goal/plan or not ;; goal/plan or not
(-let (((&plist :pos) pts) (-let ((tags (org-x-dag-id->tags nil id))
((&plist :pos) pts)
(donep (org-x-dag-id->is-done-p id))) (donep (org-x-dag-id->is-done-p id)))
(--> datetimes (--> datetimes
(--remove (and donep (not (org-x-dag-datetime= (-take 3 it) sel-date))) it) (--remove (and donep (not (org-x-dag-datetime= (-take 3 it) sel-date))) it)
(if (not todayp) (--remove (org-x-dag-datetime< (-take 3 it) sel-date) it) it) (if (not todayp) (--remove (org-x-dag-datetime< (-take 3 it) sel-date) it) it)
(--map (funcall format-datetime-fun sel-date pos it cat tags id) it)))))) (--map (funcall format-datetime-fun sel-date pos it tags id) it)))))))
(format-id (let ((todayp (= (org-x-dag-date-to-absolute sel-date) (org-today))))
(todayp cat id) ;; TODO this won't show daily nodes
(append (org-x-dag-with-action-ids
(-when-let (dead (org-x-dag-id->planning-timestamp :deadline id)) (pcase (either-from-right (org-x-dag-id->bs it) nil)
(format-timestamps todayp sel-date cat id dead (`(:sp-task :task-active ,s)
#'org-x-dag-get-deadlines-at (-let (((&plist :sched :dead) s))
#'org-x-dag-format-deadline-node)) (append
(-when-let (sched(org-x-dag-id->planning-timestamp :scheduled id)) (when dead
(format-timestamps todayp sel-date cat id sched (format-timestamps todayp sel-date it dead
#'org-x-dag-get-scheduled-at #'org-x-dag-get-deadlines-at
#'org-x-dag-format-scheduled-node))))) #'org-x-dag-format-deadline-node))
(org-x-dag-with-files (org-x-dag->action-files) (when sched
nil (format-timestamps todayp sel-date it sched
(let ((todayp (= (org-x-dag-date-to-absolute sel-date) (org-today)))) #'org-x-dag-get-scheduled-at
(format-id todayp it-category it))))) #'org-x-dag-format-scheduled-node))))))))))
(defun org-x-dag-scan-quarterly-plan () (defun org-x-dag-scan-quarterly-plan ()
(let ((week-file (list (org-x-get-weekly-plan-file))) (let ((week-file (list (org-x-get-weekly-plan-file)))