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

40
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
If EITHER is right, return result of FORM where the right slot is (`(:left ,_) default)
bound to 'it'. Return DEFAULT otherwise." (`(:right ,x) x)
(declare (indent 2))
`(pcase ,either
(`(:left ,_) ,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-left (either default)
"Apply BODY to the left slot of EITHER. "Return contents of EITHER if left or DEFAULT."
(pcase either
If EITHER is left, return result of FORM where the left slot is (`(:left ,x) x)
bound to 'it'. Return DEFAULT otherwise." (`(:right ,_) default)
(declare (indent 2))
`(pcase ,either
(`(:left ,it) ,@body)
(`(:right ,_) ,default)
(e (error "Not an either: %s" e)))) (e (error "Not an either: %s" e))))
(defun either-from-right* (either default fun) ;; (defun either-from-right* (either default fun)
(declare (indent 2)) ;; (declare (indent 2))
(either-from-right either default (funcall fun it))) ;; (either-from-right either default (funcall fun it)))
(defun either-from-left* (either default fun) ;; (defun either-from-left* (either default fun)
(declare (indent 2)) ;; (declare (indent 2))
(either-from-left either default (funcall fun it))) ;; (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.

122
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,9 +3157,7 @@ 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)
(pcase bs
(`(:sp-proj . ,status-data) (`(:sp-proj . ,status-data)
;; NOTE in the future there might be more than just the car to this ;; NOTE in the future there might be more than just the car to this
(let ((status (car status-data))) (let ((status (car status-data)))
@ -3167,17 +3166,15 @@ except it ignores inactive timestamps."
(:proj-wait 3) (:proj-wait 3)
(:proj-hold 2) (:proj-hold 2)
(:proj-stuck 1))) (:proj-stuck 1)))
(-when-let (ns (org-x-dag-id->ns it)) (-when-let ((&plist :committed) (-when-let (ns (org-x-dag-id->ns it))
(either-from-right* ns nil (either-from-right ns nil)))
(lambda (it-ns)
(when (plist-get it-ns :committed)
(let ((tags (org-x-dag-id->tags nil it))) (let ((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-add-props nil (org-add-props nil
'x-toplevelp (org-x-dag-id->is-toplevel-p it) 'x-toplevelp (org-x-dag-id->is-toplevel-p it)
'x-status status 'x-status status
'x-priority priority) 'x-priority priority)
(list))))))))))))))) (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,9 +3183,7 @@ 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)
(pcase bs
(`(:sp-proj . ,status-data) (`(:sp-proj . ,status-data)
(let ((status (car status-data))) (let ((status (car status-data)))
(when (memq status '(:iter-empty :iter-active)) (when (memq status '(:iter-empty :iter-active))
@ -3196,7 +3191,7 @@ except it ignores inactive timestamps."
(-> (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-status status) 'x-status status)
(list))))))))))) (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,15 +3209,11 @@ 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)
(pcase bs
(`(:sp-task :task-active ,s) (`(:sp-task :task-active ,s)
(-let (((&plist :todo :sched :dead) s)) (-let (((&plist :todo :sched :dead) s))
(-when-let (ns (org-x-dag-id->ns it)) (-let (((&plist :committed c) (-when-let (ns (org-x-dag-id->ns it))
(either-from-right* ns nil (either-from-right ns nil))))
(lambda (it-ns)
(-let (((&plist :committed c) it-ns))
(when (and (not sched) (not dead) c) (when (and (not sched) (not dead) c)
(let ((tags (org-x-dag-id->tags nil it)) (let ((tags (org-x-dag-id->tags nil it))
(bp (org-x-dag-id->buffer-parent it))) (bp (org-x-dag-id->buffer-parent it)))
@ -3230,17 +3221,16 @@ except it ignores inactive timestamps."
(org-add-props nil (org-add-props nil
'x-is-standalone (not bp) 'x-is-standalone (not bp)
'x-status :active) 'x-status :active)
(list))))))))))))))) (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)
(pcase bs
(`(:sp-task :task-active ,s) (`(:sp-task :task-active ,s)
(-let (((&plist :todo) s) (-let (((&plist :todo) s)
(goal-ids (-when-let (ns (org-x-dag-id->ns it)) (goal-ids (-when-let (ns (org-x-dag-id->ns it))
(either-from-right ns nil (either-from 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))
@ -3249,22 +3239,21 @@ except it ignores inactive timestamps."
(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)
(pcase bs
(`(:sp-proj . ,s) (`(:sp-proj . ,s)
(unless (eq (car s) :proj-complete) (unless (eq (car s) :proj-complete)
(let ((goal-ids (-when-let (ns (org-x-dag-id->ns it)) (let ((goal-ids (-when-let (ns (org-x-dag-id->ns it))
(either-from-right ns nil (either-from 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,10 +3331,8 @@ 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
(lambda (bs)
(-when-let ((comptime is-project) (-when-let ((comptime is-project)
(pcase bs (pcase (either-from-right (org-x-dag-id->bs it) nil)
(`(:sp-proj :proj-complete ,c) `(,c t)) (`(:sp-proj :proj-complete ,c) `(,c t))
(`(:sp-task :task-complete ,c) `(,c nil)))) (`(:sp-task :task-complete ,c) `(,c nil))))
(-let ((epoch (plist-get comptime :epoch))) (-let ((epoch (plist-get comptime :epoch)))
@ -3354,7 +3341,7 @@ except it ignores inactive timestamps."
(-> (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-project-p is-project) 'x-project-p is-project)
(list)))))))))) (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)
(let ((pts (org-x-dag-partition-timestamp ts)))
(-when-let (datetimes (funcall get-datetimes-fun sel-date pts)) (-when-let (datetimes (funcall get-datetimes-fun sel-date pts))
(let ((tags (org-x-dag-id->tags nil id)))
;; 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
(org-x-dag-with-action-ids
(pcase (either-from-right (org-x-dag-id->bs it) nil)
(`(:sp-task :task-active ,s)
(-let (((&plist :sched :dead) s))
(append (append
(-when-let (dead (org-x-dag-id->planning-timestamp :deadline id)) (when dead
(format-timestamps todayp sel-date cat id dead (format-timestamps todayp sel-date it dead
#'org-x-dag-get-deadlines-at #'org-x-dag-get-deadlines-at
#'org-x-dag-format-deadline-node)) #'org-x-dag-format-deadline-node))
(-when-let (sched(org-x-dag-id->planning-timestamp :scheduled id)) (when sched
(format-timestamps todayp sel-date cat id sched (format-timestamps todayp sel-date it sched
#'org-x-dag-get-scheduled-at #'org-x-dag-get-scheduled-at
#'org-x-dag-format-scheduled-node))))) #'org-x-dag-format-scheduled-node))))))))))
(org-x-dag-with-files (org-x-dag->action-files)
nil
(let ((todayp (= (org-x-dag-date-to-absolute sel-date) (org-today))))
(format-id todayp it-category it)))))
(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)))