diff options
Diffstat (limited to 'emacs.d/vendor')
| -rw-r--r-- | emacs.d/vendor/org-clubhouse.el | 365 | ||||
| -rw-r--r-- | emacs.d/vendor/reason-indent.el | 304 | ||||
| -rw-r--r-- | emacs.d/vendor/reason-interaction.el | 216 | ||||
| -rw-r--r-- | emacs.d/vendor/reason-mode.el | 242 | ||||
| -rw-r--r-- | emacs.d/vendor/refmt.el | 231 | ||||
| -rw-r--r-- | emacs.d/vendor/slack-snippets.el | 228 |
6 files changed, 1586 insertions, 0 deletions
diff --git a/emacs.d/vendor/org-clubhouse.el b/emacs.d/vendor/org-clubhouse.el new file mode 100644 index 000000000000..ba1f004a2410 --- /dev/null +++ b/emacs.d/vendor/org-clubhouse.el @@ -0,0 +1,365 @@ +;;; private/grfn/org-clubhouse.el + +(require 'dash) +(require 'dash-functional) +(require 's) +(require 'org) +(require 'org-element) +(require 'cl) + +;;; +;;; Configuration +;;; + +(defvar org-clubhouse-auth-token nil + "Authorization token for the Clubhouse API") + +(defvar org-clubhouse-team-name nil + "Team name to use in links to Clubhouse +ie https://app.clubhouse.io/<TEAM_NAME>/stories") + +(defvar org-clubhouse-project-ids nil + "Specific list of project IDs to synchronize with clubhouse. +If unset all projects will be synchronized") + +(defvar org-clubhouse-workflow-name "Default") + +(defvar org-clubhouse-state-alist + '(("LATER" . "Unscheduled") + ("[ ]" . "Ready for Development") + ("TODO" . "Ready for Development") + ("OPEN" . "Ready for Development") + ("ACTIVE" . "In Development") + ("PR" . "Review") + ("DONE" . "Merged") + ("[X]" . "Merged") + ("CLOSED" . "Merged"))) + +;;; +;;; Utilities +;;; + +(defun ->list (vec) (append vec nil)) + +(defun reject-archived (item-list) + (-filter (lambda (item) (equal :json-false (alist-get 'archived item))) item-list)) + +(defun alist->plist (key-map alist) + (->> key-map + (-map (lambda (key-pair) + (let ((alist-key (car key-pair)) + (plist-key (cdr key-pair))) + (list plist-key (alist-get alist-key alist))))) + (-flatten-n 1))) + +(defun alist-get-equal (key alist) + "Like `alist-get', but uses `equal' instead of `eq' for comparing keys" + (->> alist + (-find (lambda (pair) (equal key (car pair)))) + (cdr))) + +;;; +;;; Org-element interaction +;;; + +;; (defun org-element-find-headline () +;; (let ((current-elt (org-element-at-point))) +;; (if (equal 'headline (car current-elt)) +;; current-elt +;; (let* ((elt-attrs (cadr current-elt)) +;; (parent (plist-get elt-attrs :post-affiliated))) +;; (goto-char parent) +;; (org-element-find-headline))))) + +(defun org-element-find-headline () + (let ((current-elt (org-element-at-point))) + (when (equal 'headline (car current-elt)) + (cadr current-elt)))) + +(defun org-element-extract-clubhouse-id (elt) + (when-let ((clubhouse-id-link (plist-get elt :CLUBHOUSE-ID))) + (string-match + (rx "[[" (one-or-more anything) "]" + "[" (group (one-or-more digit)) "]]") + clubhouse-id-link) + (string-to-int (match-string 1 clubhouse-id-link)))) + + + +(defun org-element-clubhouse-id () + (org-element-extract-clubhouse-id + (org-element-find-headline))) + +;;; +;;; API integration +;;; + +(defvar org-clubhouse-base-url* "https://api.clubhouse.io/api/v2") + +(defun org-clubhouse-auth-url (url) + (concat url + "?" + (url-build-query-string + `(("token" ,org-clubhouse-auth-token))))) + +(defun org-clubhouse-baseify-url (url) + (if (s-starts-with? org-clubhouse-base-url* url) url + (concat org-clubhouse-base-url* + (if (s-starts-with? "/" url) url + (concat "/" url))))) + +(defun org-clubhouse-request (method url &optional data) + (message "%s %s %s" method url (prin1-to-string data)) + (let* ((url-request-method method) + (url-request-extra-headers + '(("Content-Type" . "application/json"))) + (url-request-data data) + (buf)) + + (setq url (-> url + org-clubhouse-baseify-url + org-clubhouse-auth-url)) + + (setq buf (url-retrieve-synchronously url)) + + (with-current-buffer buf + (goto-char url-http-end-of-headers) + (prog1 (json-read) (kill-buffer))))) + +(cl-defun to-id-name-pairs + (seq &optional (id-attr 'id) (name-attr 'name)) + (->> seq + ->list + (-map (lambda (resource) + (cons (alist-get id-attr resource) + (alist-get name-attr resource)))))) + +(cl-defun org-clubhouse-fetch-as-id-name-pairs + (resource &optional + (id-attr 'id) + (name-attr 'name)) + "Returns the given resource from clubhouse as (id . name) pairs" + (let ((resp-json (org-clubhouse-request "GET" resource))) + (-> resp-json + ->list + reject-archived + (to-id-name-pairs id-attr name-attr)))) + +(defun org-clubhouse-link-to-story (story-id) + (format "https://app.clubhouse.io/%s/story/%d" + org-clubhouse-team-name + story-id)) + +(defun org-clubhouse-link-to-epic (epic-id) + (format "https://app.clubhouse.io/%s/epic/%d" + org-clubhouse-team-name + epic-id)) + +(defun org-clubhouse-link-to-project (project-id) + (format "https://app.clubhouse.io/%s/project/%d" + org-clubhouse-team-name + project-id)) + +;;; +;;; Caching +;;; + + + +(defvar org-clubhouse-cache-clear-functions ()) + +(defmacro defcache (name &optional docstring &rest body) + (let* ((doc (when docstring (list docstring))) + (cache-var-name (intern (concat (symbol-name name) + "-cache"))) + (clear-cache-function-name + (intern (concat "clear-" (symbol-name cache-var-name))))) + `(progn + (defvar ,cache-var-name :no-cache) + (defun ,name () + ,@doc + (when (equal :no-cache ,cache-var-name) + (setq ,cache-var-name (progn ,@body))) + ,cache-var-name) + (defun ,clear-cache-function-name () + (interactive) + (setq ,cache-var-name :no-cache)) + + (push (quote ,clear-cache-function-name) + org-clubhouse-cache-clear-functions)))) + +(defun org-clubhouse-clear-cache () + (interactive) + (-map #'funcall org-clubhouse-cache-clear-functions)) + +;;; +;;; API resource functions +;;; + +(defcache org-clubhouse-projects + "Returns projects as (project-id . name)" + (org-clubhouse-fetch-as-id-name-pairs "projects")) + +(defcache org-clubhouse-epics + "Returns projects as (project-id . name)" + (org-clubhouse-fetch-as-id-name-pairs "epics")) + +(defcache org-clubhouse-workflow-states + "Returns worflow states as (name . id) pairs" + (let* ((resp-json (org-clubhouse-request "GET" "workflows")) + (workflows (->list resp-json)) + ;; just assume it exists, for now + (workflow (-find (lambda (workflow) + (equal org-clubhouse-workflow-name + (alist-get 'name workflow))) + workflows)) + (states (->list (alist-get 'states workflow)))) + (to-id-name-pairs states + 'name + 'id))) + +(defun org-clubhouse-stories-in-project (project-id) + "Returns the stories in the given project as org bugs" + (let ((resp-json (org-clubhouse-request "GET" (format "/projects/%d/stories" project-id)))) + (->> resp-json ->list reject-archived + (-reject (lambda (story) (equal :json-true (alist-get 'completed story)))) + (-map (lambda (story) + (cons + (cons 'status + (cond + ((equal :json-true (alist-get 'started story)) + 'started) + ((equal :json-true (alist-get 'completed story)) + 'completed) + ('t + 'open))) + story))) + (-map (-partial #'alist->plist + '((name . :title) + (id . :id) + (status . :status))))))) + +;;; +;;; Story creation +;;; + +(cl-defun org-clubhouse-create-story-internal + (title &key project-id epic-id) + (assert (and (stringp title) + (integerp project-id) + (or (null epic-id) (integerp epic-id)))) + (org-clubhouse-request + "POST" + "stories" + (json-encode + `((name . ,title) + (project_id . ,project-id) + (epic_id . ,epic-id))))) + +(defun org-clubhouse-prompt-for-project (cb) + (ivy-read + "Select a project: " + (-map #'cdr (org-clubhouse-projects)) + :require-match t + :history 'org-clubhouse-project-history + :action (lambda (selected) + (let ((project-id + (->> (org-clubhouse-projects) + (-find (lambda (proj) + (string-equal (cdr proj) selected))) + car))) + (message "%d" project-id) + (funcall cb project-id))))) + +(defun org-clubhouse-prompt-for-epic (cb) + (ivy-read + "Select an epic: " + (-map #'cdr (org-clubhouse-epics)) + :history 'org-clubhouse-epic-history + :action (lambda (selected) + (let ((epic-id + (->> (org-clubhouse-epics) + (-find (lambda (proj) + (string-equal (cdr proj) selected))) + car))) + (message "%d" epic-id) + (funcall cb epic-id))))) + +(defun org-clubhouse-populate-created-story (story) + (let ((elt (org-element-find-headline)) + (story-id (alist-get 'id story)) + (epic-id (alist-get 'epic_id story)) + (project-id (alist-get 'project_id story))) + + (org-set-property "clubhouse-id" + (org-make-link-string + (org-clubhouse-link-to-story story-id) + (number-to-string story-id))) + + (org-set-property "clubhouse-epic" + (org-make-link-string + (org-clubhouse-link-to-epic epic-id) + (alist-get epic-id (org-clubhouse-epics)))) + + (org-set-property "clubhouse-project" + (org-make-link-string + (org-clubhouse-link-to-project project-id) + (alist-get project-id (org-clubhouse-projects)))) + + (org-todo "TODO"))) + +(defun org-clubhouse-create-story () + (interactive) + ;; (message (org-element-find-headline)) + (when-let ((elt (org-element-find-headline)) + (title (plist-get elt :title))) + (if (plist-get elt :CLUBHOUSE-ID) + (message "This headline is already a clubhouse story!") + (org-clubhouse-prompt-for-project + (lambda (project-id) + (when project-id + (org-clubhouse-prompt-for-epic + (lambda (epic-id) + (let* ((story (org-clubhouse-create-story-internal + title + :project-id project-id + :epic-id epic-id))) + (org-clubhouse-populate-created-story story)))))))))) + +;;; +;;; Story updates +;;; + +(cl-defun org-clubhouse-update-story-internal + (story-id &rest attrs) + (assert (and (integerp story-id) + (listp attrs))) + (org-clubhouse-request + "PUT" + (format "stories/%d" story-id) + (json-encode attrs))) + +(defun org-clubhouse-update-status () + (when-let (clubhouse-id (org-element-clubhouse-id)) + (let* ((elt (org-element-find-headline)) + (todo-keyword (-> elt (plist-get :todo-keyword) (substring-no-properties)))) + (message todo-keyword) + (when-let ((clubhouse-workflow-state + (alist-get-equal todo-keyword org-clubhouse-state-alist)) + (workflow-state-id + (alist-get-equal clubhouse-workflow-state (org-clubhouse-workflow-states)))) + (org-clubhouse-update-story-internal + clubhouse-id + :workflow_state_id workflow-state-id) + (message "Successfully updated clubhouse status to \"%s\"" + clubhouse-workflow-state))))) + +(define-minor-mode org-clubhouse-mode + :init-value nil + :group 'org + :lighter "Org-Clubhouse" + :keymap '() + (add-hook 'org-after-todo-state-change-hook + 'org-clubhouse-update-status + nil + t)) diff --git a/emacs.d/vendor/reason-indent.el b/emacs.d/vendor/reason-indent.el new file mode 100644 index 000000000000..8fd3c9425866 --- /dev/null +++ b/emacs.d/vendor/reason-indent.el @@ -0,0 +1,304 @@ +;;; reason-indent.el --- Indentation functions for ReasonML -*-lexical-binding: t-*- + +;; Portions Copyright (c) 2015-present, Facebook, Inc. All rights reserved. + +;;; Commentary: + +;; Indentation functions for Reason. + +;;; Code: + +(defconst reason-re-ident "[[:word:][:multibyte:]_][[:word:][:multibyte:]_[:digit:]]*") + +(defcustom reason-indent-offset 2 + "Indent Reason code by this number of spaces." + :type 'integer + :group 'reason-mode + :safe #'integerp) + +(defun reason-looking-back-str (str) + "Like `looking-back' but for fixed strings rather than regexps. +Works around some regexp slowness. +Argument STR string to search for." + (let ((len (length str))) + (and (> (point) len) + (equal str (buffer-substring-no-properties (- (point) len) (point)))))) + +(defun reason-paren-level () + "Get the level of nesting inside parentheses." + (nth 0 (syntax-ppss))) + +(defun reason-in-str-or-cmnt () + "Return whether point is currently inside a string or a comment." + (nth 8 (syntax-ppss))) + +(defun reason-rewind-past-str-cmnt () + "Rewind past string or comment." + (goto-char (nth 8 (syntax-ppss)))) + +(defun reason-rewind-irrelevant () + "Rewind past irrelevant characters (whitespace of inside comments)." + (interactive) + (let ((starting (point))) + (skip-chars-backward "[:space:]\n") + (if (reason-looking-back-str "*/") (backward-char)) + (if (reason-in-str-or-cmnt) + (reason-rewind-past-str-cmnt)) + (if (/= starting (point)) + (reason-rewind-irrelevant)))) + +(defun reason-align-to-expr-after-brace () + "Align the expression at point to the expression after the previous brace." + (save-excursion + (forward-char) + ;; We don't want to indent out to the open bracket if the + ;; open bracket ends the line + (when (not (looking-at "[[:blank:]]*\\(?://.*\\)?$")) + (when (looking-at "[[:space:]]") + (forward-word 1) + (backward-word 1)) + (current-column)))) + +(defun reason-align-to-prev-expr () + "Align the expression at point to the previous expression." + (let ((alignment (save-excursion + (forward-char) + ;; We don't want to indent out to the open bracket if the + ;; open bracket ends the line + (when (not (looking-at "[[:blank:]]*\\(?://.*\\)?$")) + (if (looking-at "[[:space:]]") + (progn + (forward-word 1) + (backward-word 1)) + (backward-char)) + (current-column))))) + (if (not alignment) + (save-excursion + (forward-char) + (forward-line) + (back-to-indentation) + (current-column)) + alignment))) + +;;; Start of a reason binding +(defvar reason-binding + (regexp-opt '("let" "type" "module" "fun"))) + +(defun reason-beginning-of-defun (&optional arg) + "Move backward to the beginning of the current defun. + +With ARG, move backward multiple defuns. Negative ARG means +move forward. + +This is written mainly to be used as `beginning-of-defun-function'. +Don't move to the beginning of the line. `beginning-of-defun', +which calls this, does that afterwards." + (interactive "p") + (re-search-backward (concat "^\\(" reason-binding "\\)\\_>") + nil 'move (or arg 1))) + +(defun reason-end-of-defun () + "Move forward to the next end of defun. + +With argument, do it that many times. +Negative argument -N means move back to Nth preceding end of defun. + +Assume that this is called after ‘beginning-of-defun’. So point is +at the beginning of the defun body. + +This is written mainly to be used as `end-of-defun-function' for Reason." + (interactive) + ;; Find the opening brace + (if (re-search-forward "[{]" nil t) + (progn + (goto-char (match-beginning 0)) + ;; Go to the closing brace + (condition-case nil + (forward-sexp) + (scan-error + ;; The parentheses are unbalanced; instead of being unable to fontify, just jump to the end of the buffer + (goto-char (point-max))))) + ;; There is no opening brace, so consider the whole buffer to be one "defun" + (goto-char (point-max)))) + +(defun reason-rewind-to-beginning-of-current-level-expr () + "Rewind to the beginning of the expression on the current level of nesting." + (interactive) + (let ((current-level (reason-paren-level))) + (back-to-indentation) + (when (looking-at "=>") + (reason-rewind-irrelevant) + (back-to-indentation)) + (while (> (reason-paren-level) current-level) + (backward-up-list) + (back-to-indentation)))) + +(defun reason-mode-indent-line () + "Indent current line." + (interactive) + (let ((indent + (save-excursion + (back-to-indentation) + ;; Point is now at beginning of current line + (let* ((level (reason-paren-level)) + (baseline + ;; Our "baseline" is one level out from the indentation of the expression + ;; containing the innermost enclosing opening bracket. That + ;; way if we are within a block that has a different + ;; indentation than this mode would give it, we still indent + ;; the inside of it correctly relative to the outside. + (if (= 0 level) + 0 + (save-excursion + (reason-rewind-irrelevant) + (if (save-excursion + (reason-rewind-to-beginning-of-current-level-expr) + (looking-at "<")) + (progn + (reason-rewind-to-beginning-of-current-level-expr) + (current-column)) + (progn + (backward-up-list) + (reason-rewind-to-beginning-of-current-level-expr) + + (cond + ((looking-at "switch") + (current-column)) + + ((looking-at "|") + (+ (current-column) (* reason-indent-offset 2))) + + (t + (let ((current-level (reason-paren-level))) + (save-excursion + (while (and (= current-level (reason-paren-level)) + (not (looking-at reason-binding))) + (reason-rewind-irrelevant) + (reason-rewind-to-beginning-of-current-level-expr)) + (+ (current-column) reason-indent-offset))))))))))) + (cond + ;; A function return type is indented to the corresponding function arguments + ((looking-at "=>") + (+ baseline reason-indent-offset)) + + ((reason-in-str-or-cmnt) + (cond + ;; In the end of the block -- align with star + ((looking-at "*/") (+ baseline 1)) + ;; Indent to the following shape: + ;; /* abcd + ;; * asdf + ;; */ + ;; + ((looking-at "*") (+ baseline 1)) + ;; Indent to the following shape: + ;; /* abcd + ;; asdf + ;; */ + ;; + (t (+ baseline (+ reason-indent-offset 1))))) + + ((looking-at "</") (- baseline reason-indent-offset)) + + ;; A closing brace is 1 level unindented + ((looking-at "}\\|)\\|\\]") + (save-excursion + (reason-rewind-irrelevant) + (let ((jsx? (reason-looking-back-str ">"))) + (backward-up-list) + (reason-rewind-to-beginning-of-current-level-expr) + (cond + ((looking-at "switch") baseline) + + (jsx? (current-column)) + + (t (- baseline reason-indent-offset)))))) + + ;; Doc comments in /** style with leading * indent to line up the *s + ((and (nth 4 (syntax-ppss)) (looking-at "*")) + (+ 1 baseline)) + + ;; If we're in any other token-tree / sexp, then: + (t + (or + ;; If we are inside a pair of braces, with something after the + ;; open brace on the same line and ending with a comma, treat + ;; it as fields and align them. + (when (> level 0) + (save-excursion + (reason-rewind-irrelevant) + (backward-up-list) + ;; Point is now at the beginning of the containing set of braces + (reason-align-to-expr-after-brace))) + + (progn + (back-to-indentation) + (cond ((looking-at (regexp-opt '("and" "type"))) + baseline) + ((save-excursion + (reason-rewind-irrelevant) + (= (point) 1)) + baseline) + ((save-excursion + (while (looking-at "|") + (reason-rewind-irrelevant) + (back-to-indentation)) + (looking-at (regexp-opt '("type")))) + (+ baseline reason-indent-offset)) + ((looking-at "|\\|/[/*]") + baseline) + ((and (> level 0) + (save-excursion + (reason-rewind-irrelevant) + (backward-up-list) + (reason-rewind-to-beginning-of-current-level-expr) + (looking-at "switch"))) + (+ baseline reason-indent-offset)) + ((save-excursion + (reason-rewind-irrelevant) + (looking-back "[{;,\\[(]" (- (point) 2))) + baseline) + ((and + (save-excursion + (reason-rewind-irrelevant) + (reason-rewind-to-beginning-of-current-level-expr) + (and (looking-at reason-binding) + (not (progn + (forward-sexp) + (forward-sexp) + (skip-chars-forward "[:space:]\n") + (looking-at "="))))) + (not (save-excursion + (skip-chars-backward "[:space:]\n") + (reason-looking-back-str "=>")))) + (save-excursion + (reason-rewind-irrelevant) + (backward-sexp) + (reason-align-to-prev-expr))) + ((save-excursion + (reason-rewind-irrelevant) + (looking-back "<\/.*?>" (- (point) 30))) + baseline) + (t + (save-excursion + (reason-rewind-irrelevant) + (reason-rewind-to-beginning-of-current-level-expr) + + (if (looking-at "|") + baseline + (+ baseline reason-indent-offset))))) + ;; Point is now at the beginning of the current line + )))))))) + + (when indent + ;; If we're at the beginning of the line (before or at the current + ;; indentation), jump with the indentation change. Otherwise, save the + ;; excursion so that adding the indentations will leave us at the + ;; equivalent position within the line to where we were before. + (if (<= (current-column) (current-indentation)) + (indent-line-to indent) + (save-excursion (indent-line-to indent)))))) + +(provide 'reason-indent) + +;;; reason-indent.el ends here diff --git a/emacs.d/vendor/reason-interaction.el b/emacs.d/vendor/reason-interaction.el new file mode 100644 index 000000000000..6ceaed1e9340 --- /dev/null +++ b/emacs.d/vendor/reason-interaction.el @@ -0,0 +1,216 @@ +;;; reason-interaction.el --- Phrase navitagion for rtop -*-lexical-binding: t-*- + +;; Portions Copyright (c) 2015-present, Facebook, Inc. All rights reserved. + +;;; Commentary: + +;; Phrase navigation for utop and maybe other REPLs. + +;; The utop compatibility layer for Reason was mainly taken from: +;; https://github.com/ocaml/tuareg/blob/master/tuareg-light.el (big thanks!) + +;;; Code: + +(defun reason-backward-char (&optional step) + "Go back one char. +Similar to `backward-char` but it does not signal errors +`beginning-of-buffer` and `end-of-buffer`. It optionally takes a +STEP parameter for jumping back more than one character." + (when step (goto-char (- (point) step)) + (goto-char (1- (point))))) + +(defun reason-forward-char (&optional step) + "Go forward one char. +Similar to `forward-char` but it does not signal errors +`beginning-of-buffer` and `end-of-buffer`. It optionally takes a +STEP parameter for jumping back more than one character." + (when step (goto-char (+ (point) step)) + (goto-char (1+ (point))))) + +(defun reason-in-literal-p () + "Return non-nil if point is inside an Reason literal." + (nth 3 (syntax-ppss))) + +(defconst reason-comment-delimiter-regexp "\\*/\\|/\\*" + "Regex for identify either open or close comment delimiters.") + +(defun reason-in-between-comment-chars-p () + "Return non-nil iff point is in between the comment delimiter chars. +It returns non-nil if point is between the chars only (*|/ or /|* +where | is point)." + (and (not (bobp)) (not (eobp)) + (or (and (char-equal ?/ (char-before)) (char-equal ?* (char-after))) + (and (char-equal ?* (char-before)) (char-equal ?/ (char-after)))))) + +(defun reason-looking-at-comment-delimiters-p () + "Return non-nil iff point in between comment delimiters." + (looking-at-p reason-comment-delimiter-regexp)) + +(defun reason-in-between-comment-delimiters-p () + "Return non-nil if inside /* and */." + (nth 4 (syntax-ppss))) + +(defun reason-in-comment-p () + "Return non-nil iff point is inside or right before a comment." + (or (reason-in-between-comment-delimiters-p) + (reason-in-between-comment-chars-p) + (reason-looking-at-comment-delimiters-p))) + +(defun reason-beginning-of-literal-or-comment () + "Skip to the beginning of the current literal or comment (or buffer)." + (interactive) + (goto-char (or (nth 8 (syntax-ppss)) (point)))) + +(defun reason-inside-block-scope-p () + "Skip to the beginning of the current literal or comment (or buffer)." + (and (> (nth 0 (syntax-ppss)) 0) + (let ((delim-start (nth 1 (syntax-ppss)))) + (save-excursion + (goto-char delim-start) + (char-equal ?{ (following-char)))))) + +(defun reason-at-phrase-break-p () + "Is the underlying `;' a phrase break?" + ;; Difference from OCaml, the phrase separator is a single semi-colon + (and (not (eobp)) + (char-equal ?\; (following-char)))) + +(defun reason-skip-to-close-delimiter (&optional limit) + "Skip to the end of a Reason block. +It basically calls `re-search-forward` in order to go to any +closing delimiter, not concerning itself with balancing of any +sort. Client code needs to check that. +LIMIT is passed to `re-search-forward` directly." + (re-search-forward "\\s)" limit 'move)) + +(defun reason-skip-back-to-open-delimiter (&optional limit) + "Skip to the beginning of a Reason block backwards. +It basically calls `re-search-backward` in order to go to any +opening delimiter, not concerning itself with balancing of any +sort. Client code needs to check that. +LIMIT is passed to `re-search-backward` directly." + (re-search-backward "\\s(" limit 'move)) + +(defun reason-find-phrase-end () + "Skip to the end of a phrase." + (while (and (not (eobp)) + (not (reason-at-phrase-break-p))) + (if (re-search-forward ";" nil 'move) + (progn (when (reason-inside-block-scope-p) + (reason-skip-to-close-delimiter)) + (goto-char (1- (point)))) + ;; avoid infinite loop at the end of the buffer + (re-search-forward "[[:space:]\\|\n]+" nil 'move))) + (min (goto-char (1+ (point))) (point-max))) + +(defun reason-skip-blank-and-comments () + "Skip blank spaces and comments." + (cond + ((eobp) (point)) + ((or (reason-in-between-comment-chars-p) + (reason-looking-at-comment-delimiters-p)) (progn + (reason-forward-char 1) + (reason-skip-blank-and-comments))) + ((reason-in-between-comment-delimiters-p) (progn + (search-forward "*/" nil t) + (reason-skip-blank-and-comments))) + ((eolp) (progn + (reason-forward-char 1) + (reason-skip-blank-and-comments))) + (t (progn (skip-syntax-forward " ") + (point))))) + +(defun reason-skip-back-blank-and-comments () + "Skip blank spaces and comments backwards." + (cond + ((bobp) (point)) + ((looking-back reason-comment-delimiter-regexp) (progn + (reason-backward-char 1) + (reason-skip-back-blank-and-comments))) + ((reason-in-between-comment-delimiters-p) (progn + (search-backward "/*" nil t) + (reason-backward-char 1) + (reason-skip-back-blank-and-comments))) + ((or (reason-in-between-comment-chars-p) + (reason-looking-at-comment-delimiters-p)) (progn + (reason-backward-char 1) + (reason-skip-back-blank-and-comments))) + ((bolp) (progn + (reason-backward-char 1) + (reason-skip-back-blank-and-comments))) + (t (progn (skip-syntax-backward " ") + (point))))) + +(defun reason-ro (&rest words) + "Build a regex matching iff at least a word in WORDS is present." + (concat "\\<" (regexp-opt words t) "\\>")) + +(defconst reason-find-phrase-beginning-regexp + (concat (reason-ro "end" "type" "module" "sig" "struct" "class" + "exception" "open" "let") + "\\|^#[ \t]*[a-z][_a-z]*\\>\\|;")) + +(defun reason-at-phrase-start-p () + "Return t if is looking at the beginning of a phrase. +A phrase starts when a toplevel keyword is at the beginning of a line." + (or (looking-at "#") + (looking-at reason-find-phrase-beginning-regexp))) + +(defun reason-find-phrase-beginning-backward () + "Find the beginning of a phrase and return point. +It scans code backwards, therefore the caller can assume that the +beginning of the phrase (if found) is always before the starting +point. No error is signalled and (point-min) is returned when a +phrease cannot be found." + (beginning-of-line) + (while (and (not (bobp)) (not (reason-at-phrase-start-p))) + (if (reason-inside-block-scope-p) + (reason-skip-back-to-open-delimiter) + (re-search-backward reason-find-phrase-beginning-regexp nil 'move))) + (point)) + +(defun reason-discover-phrase () + "Discover a Reason phrase in the buffer." + ;; TODO reason-with-internal-syntax ;; tuareg2 modifies the syntax table (removed for now) + ;; TODO stop-at-and feature for phrase detection (do we need it?) + ;; TODO tuareg2 has some custom logic for module and class (do we need it?) + (save-excursion + (let ((case-fold-search nil)) + (reason-skip-blank-and-comments) + (list (reason-find-phrase-beginning-backward) ;; beginning + (reason-find-phrase-end) ;; end + (save-excursion ;; end-with-comment + (reason-skip-blank-and-comments) + (point)))))) + +(defun reason-discover-phrase-debug () + "Discover a Reason phrase in the buffer (debug mode)." + (let ((triple (reason-discover-phrase))) + (message (concat "Evaluating: \"" (reason-fetch-phrase triple) "\"")) + triple)) + +(defun reason-fetch-phrase (triple) + "Fetch the phrase text given a TRIPLE." + (let* ((start (nth 0 triple)) + (end (nth 1 triple))) ;; we don't need end-with-comment + (buffer-substring-no-properties start end))) + +(defun reason-next-phrase () + "Skip to the beginning of the next phrase." + (cond + ((reason-at-phrase-start-p) (point)) + ((eolp) (progn + (forward-char 1) + (reason-skip-blank-and-comments) + (reason-next-phrase))) + ((reason-inside-block-scope-p) (progn (reason-skip-to-close-delimiter) + (reason-next-phrase))) + ((looking-at ";") (progn + (forward-char 1) + (reason-next-phrase))) + (t (progn (end-of-line) + (reason-next-phrase))))) + +(provide 'reason-interaction) + +;;; reason-interaction.el ends here diff --git a/emacs.d/vendor/reason-mode.el b/emacs.d/vendor/reason-mode.el new file mode 100644 index 000000000000..789735955db2 --- /dev/null +++ b/emacs.d/vendor/reason-mode.el @@ -0,0 +1,242 @@ +;;; reason-mode.el --- A major mode for editing ReasonML -*-lexical-binding: t-*- +;; Portions Copyright (c) 2015-present, Facebook, Inc. All rights reserved. + +;; Version: 0.4.0 +;; Author: Mozilla +;; Url: https://github.com/reasonml-editor/reason-mode +;; Keywords: languages, ocaml +;; Package-Requires: ((emacs "24.3")) + +;; This file is NOT part of GNU Emacs. + +;; This file is distributed under the terms of both the MIT license and the +;; Apache License (version 2.0). + +;;; Commentary: +;; This project provides useful functions and helpers for developing code +;; using the Reason programming language (https://facebook.github.io/reason). +;; +;; Reason is an umbrella project that provides a curated layer for OCaml. +;; +;; It offers: +;; - A new, familiar syntax for the battle-tested language that is OCaml. +;; - A workflow for compiling to JavaScript and native code. +;; - A set of friendly documentations, libraries and utilities. +;; +;; See the README.md for more details. + +;;; Code: + +(require 'reason-indent) +(require 'refmt) +(require 'reason-interaction) + +(eval-when-compile (require 'rx) + (require 'compile) + (require 'url-vars)) + +;; Syntax definitions and helpers +(defvar reason-mode-syntax-table + (let ((table (make-syntax-table))) + + ;; Operators + (dolist (i '(?+ ?- ?* ?/ ?& ?| ?^ ?! ?< ?> ?~ ?@)) + (modify-syntax-entry i "." table)) + + ;; Strings + (modify-syntax-entry ?\" "\"" table) + (modify-syntax-entry ?\\ "\\" table) + (modify-syntax-entry ?\' "_" table) + + ;; Comments + (modify-syntax-entry ?/ ". 124b" table) + (modify-syntax-entry ?* ". 23n" table) + (modify-syntax-entry ?\n "> b" table) + (modify-syntax-entry ?\^m "> b" table) + + table)) + +(defgroup reason nil + "Support for Reason code." + :link '(url-link "http://facebook.github.io/reason/") + :group 'languages) + +(defcustom reason-mode-hook nil + "Hook called by `reason-mode'." + :type 'hook + :group 'reason) + +;; Font-locking definitions and helpers +(defconst reason-mode-keywords + '("and" "as" + "else" "external" + "fun" "for" + "if" "impl" "in" "include" + "let" + "module" "match" "mod" "move" "mutable" + "open" + "priv" "pub" + "rec" "ref" "return" + "self" "static" "switch" "struct" "super" + "trait" "type" + "use" + "virtual" + "where" "when" "while")) + +(defconst reason-mode-consts + '("true" "false")) + +(defconst reason-special-types + '("int" "float" "string" "char" + "bool" "unit" "list" "array" "exn" + "option" "ref")) + +(defconst reason-camel-case + (rx symbol-start + (group upper (0+ (any word nonascii digit "_"))) + symbol-end)) + +(eval-and-compile + (defconst reason--char-literal-rx + (rx (seq (group "'") + (or (seq "\\" anything) + (not (any "'\\"))) + (group "'"))))) + +(defun reason-re-word (inner) + "Build a word regexp given INNER." + (concat "\\<" inner "\\>")) + +(defun reason-re-grab (inner) + "Build a grab regexp given INNER." + (concat "\\(" inner "\\)")) + +(defun reason-regexp-opt-symbols (words) + "Like `(regexp-opt words 'symbols)`, but will work on Emacs 23. +See rust-mode PR #42. +Argument WORDS argument to pass to `regexp-opt`." + (concat "\\_<" (regexp-opt words t) "\\_>")) + +;;; Syntax highlighting for Reason +(defvar reason-font-lock-keywords + `((,(reason-regexp-opt-symbols reason-mode-keywords) . font-lock-keyword-face) + (,(reason-regexp-opt-symbols reason-special-types) . font-lock-builtin-face) + (,(reason-regexp-opt-symbols reason-mode-consts) . font-lock-constant-face) + + (,reason-camel-case 1 font-lock-type-face) + + ;; Field names like `foo:`, highlight excluding the : + (,(concat (reason-re-grab reason-re-ident) ":[^:]") 1 font-lock-variable-name-face) + ;; Module names like `foo::`, highlight including the :: + (,(reason-re-grab (concat reason-re-ident "::")) 1 font-lock-type-face) + ;; Name punned labeled args like ::foo + (,(concat "[[:space:]]+" (reason-re-grab (concat "::" reason-re-ident))) 1 font-lock-type-face) + + ;; TODO jsx attribs? + (, + (concat "<[/]?" (reason-re-grab reason-re-ident) "[^>]*" ">") + 1 font-lock-type-face))) + +(defun reason-mode-try-find-alternate-file (mod-name extension) + "Switch to the file given by MOD-NAME and EXTENSION." + (let* ((filename (concat mod-name extension)) + (buffer (get-file-buffer filename))) + (if buffer (switch-to-buffer buffer) + (find-file filename)))) + +(defun reason-mode-find-alternate-file () + "Switch to implementation/interface file." + (interactive) + (let ((name buffer-file-name)) + (when (string-match "\\`\\(.*\\)\\.re\\([il]\\)?\\'" name) + (let ((mod-name (match-string 1 name)) + (e (match-string 2 name))) + (cond + ((string= e "i") + (reason-mode-try-find-alternate-file mod-name ".re")) + (t + (reason-mode-try-find-alternate-file mod-name ".rei"))))))) + +(defun reason--syntax-propertize-multiline-string (end) + "Propertize Reason multiline string. +Argument END marks the end of the string." + (let ((ppss (syntax-ppss))) + (when (eq t (nth 3 ppss)) + (let ((key (save-excursion + (goto-char (nth 8 ppss)) + (and (looking-at "{\\([a-z]*\\)|") + (match-string 1))))) + (when (search-forward (format "|%s}" key) end 'move) + (put-text-property (1- (match-end 0)) (match-end 0) + 'syntax-table (string-to-syntax "|"))))))) + +(defun reason-syntax-propertize-function (start end) + "Propertize Reason function. +Argument START marks the beginning of the function. +Argument END marks the end of the function." + (goto-char start) + (reason--syntax-propertize-multiline-string end) + (funcall + (syntax-propertize-rules + (reason--char-literal-rx (1 "\"") (2 "\"")) + ;; multi line strings + ("\\({\\)[a-z]*|" + (1 (prog1 "|" + (goto-char (match-end 0)) + (reason--syntax-propertize-multiline-string end))))) + (point) end)) + +(defvar reason-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "\C-c\C-a" #'reason-mode-find-alternate-file) + (define-key map "\C-c\C-r" #'refmt-region-ocaml-to-reason) + (define-key map "\C-c\C-o" #'refmt-region-reason-to-ocaml) + map)) + +;;;###autoload +(define-derived-mode reason-mode prog-mode "Reason" + "Major mode for Reason code. + +\\{reason-mode-map}" + :group 'reason + :syntax-table reason-mode-syntax-table + :keymap reason-mode-map + + ;; Syntax + (setq-local syntax-propertize-function #'reason-syntax-propertize-function) + ;; Indentation + (setq-local indent-line-function 'reason-mode-indent-line) + ;; Fonts + (setq-local font-lock-defaults '(reason-font-lock-keywords)) + ;; Misc + (setq-local comment-start "/*") + (setq-local comment-end "*/") + (setq-local indent-tabs-mode nil) + ;; Allow paragraph fills for comments + (setq-local comment-start-skip "/\\*+[ \t]*") + (setq-local paragraph-start + (concat "^[ \t]*$\\|\\*)$\\|" page-delimiter)) + (setq-local paragraph-separate paragraph-start) + (setq-local require-final-newline t) + (setq-local normal-auto-fill-function nil) + (setq-local comment-multi-line t) + + (setq-local beginning-of-defun-function 'reason-beginning-of-defun) + (setq-local end-of-defun-function 'reason-end-of-defun) + (setq-local parse-sexp-lookup-properties t)) + +;;;###autoload +(add-to-list 'auto-mode-alist '("\\.rei?\\'" . reason-mode)) + +(defun reason-mode-reload () + "Reload Reason mode." + (interactive) + (unload-feature 'reason-mode) + (unload-feature 'reason-indent) + (unload-feature 'reason-interaction) + (require 'reason-mode) + (reason-mode)) + +(provide 'reason-mode) + +;;; reason-mode.el ends here diff --git a/emacs.d/vendor/refmt.el b/emacs.d/vendor/refmt.el new file mode 100644 index 000000000000..b9ea2b43f0ce --- /dev/null +++ b/emacs.d/vendor/refmt.el @@ -0,0 +1,231 @@ +;;; refmt.el --- utility functions to format reason code + +;; Copyright (c) 2014 The go-mode Authors. All rights reserved. +;; Portions Copyright (c) 2015-present, Facebook, Inc. All rights reserved. + +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: + +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above +;; copyright notice, this list of conditions and the following disclaimer +;; in the documentation and/or other materials provided with the +;; distribution. +;; * Neither the name of the copyright holder nor the names of its +;; contributors may be used to endorse or promote products derived from +;; this software without specific prior written permission. + +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.) + +;;; Commentary: +;; + +;;; Code: + +(require 'cl-lib) + +(defcustom refmt-command "refmt" + "The 'refmt' command." + :type 'string + :group 're-fmt) + +(defcustom refmt-show-errors 'buffer + "Where to display refmt error output. +It can either be displayed in its own buffer, in the echo area, or not at all. +Please note that Emacs outputs to the echo area when writing +files and will overwrite refmt's echo output if used from inside +a `before-save-hook'." + :type '(choice + (const :tag "Own buffer" buffer) + (const :tag "Echo area" echo) + (const :tag "None" nil)) + :group 're-fmt) + +(defcustom refmt-width-mode nil + "Specify width when formatting buffer contents." + :type '(choice + (const :tag "Window width" window) + (const :tag "Fill column" fill) + (const :tag "None" nil)) + :group 're-fmt) + +;;;###autoload +(defun refmt-before-save () + "Add this to .emacs to run refmt on the current buffer when saving: + (add-hook 'before-save-hook 'refmt-before-save)." + (interactive) + (when (eq major-mode 'reason-mode) (refmt))) + +(defun reason--goto-line (line) + (goto-char (point-min)) + (forward-line (1- line))) + +(defun reason--delete-whole-line (&optional arg) + "Delete the current line without putting it in the `kill-ring'. +Derived from function `kill-whole-line'. ARG is defined as for that +function." + (setq arg (or arg 1)) + (if (and (> arg 0) + (eobp) + (save-excursion (forward-visible-line 0) (eobp))) + (signal 'end-of-buffer nil)) + (if (and (< arg 0) + (bobp) + (save-excursion (end-of-visible-line) (bobp))) + (signal 'beginning-of-buffer nil)) + (cond ((zerop arg) + (delete-region (progn (forward-visible-line 0) (point)) + (progn (end-of-visible-line) (point)))) + ((< arg 0) + (delete-region (progn (end-of-visible-line) (point)) + (progn (forward-visible-line (1+ arg)) + (unless (bobp) + (backward-char)) + (point)))) + (t + (delete-region (progn (forward-visible-line 0) (point)) + (progn (forward-visible-line arg) (point)))))) + +(defun reason--apply-rcs-patch (patch-buffer &optional start-pos) + "Apply an RCS-formatted diff from PATCH-BUFFER to the current buffer." + (setq start-pos (or start-pos (point-min))) + (let ((first-line (line-number-at-pos start-pos)) + (target-buffer (current-buffer)) + ;; Relative offset between buffer line numbers and line numbers + ;; in patch. + ;; + ;; Line numbers in the patch are based on the source file, so + ;; we have to keep an offset when making changes to the + ;; buffer. + ;; + ;; Appending lines decrements the offset (possibly making it + ;; negative), deleting lines increments it. This order + ;; simplifies the forward-line invocations. + (line-offset 0)) + (save-excursion + (with-current-buffer patch-buffer + (goto-char (point-min)) + (while (not (eobp)) + (unless (looking-at "^\\([ad]\\)\\([0-9]+\\) \\([0-9]+\\)") + (error "invalid rcs patch or internal error in reason--apply-rcs-patch")) + (forward-line) + (let ((action (match-string 1)) + (from (string-to-number (match-string 2))) + (len (string-to-number (match-string 3)))) + (cond + ((equal action "a") + (let ((start (point))) + (forward-line len) + (let ((text (buffer-substring start (point)))) + (with-current-buffer target-buffer + (cl-decf line-offset len) + (goto-char start-pos) + (forward-line (- from len line-offset)) + (insert text))))) + ((equal action "d") + (with-current-buffer target-buffer + (reason--goto-line (- (1- (+ first-line from)) line-offset)) + (cl-incf line-offset len) + (reason--delete-whole-line len))) + (t + (error "invalid rcs patch or internal error in reason--apply-rcs-patch"))))))))) + +(defun refmt--process-errors (filename tmpfile errorfile errbuf) + (with-current-buffer errbuf + (if (eq refmt-show-errors 'echo) + (progn + (message "%s" (buffer-string)) + (refmt--kill-error-buffer errbuf)) + (insert-file-contents errorfile nil nil nil) + ;; Convert the refmt stderr to something understood by the compilation mode. + (goto-char (point-min)) + (insert "refmt errors:\n") + (while (search-forward-regexp (regexp-quote tmpfile) nil t) + (replace-match (file-name-nondirectory filename))) + (compilation-mode) + (display-buffer errbuf)))) + +(defun refmt--kill-error-buffer (errbuf) + (let ((win (get-buffer-window errbuf))) + (if win + (quit-window t win) + (with-current-buffer errbuf + (erase-buffer)) + (kill-buffer errbuf)))) + +(defun apply-refmt (&optional start end from to) + (setq start (or start (point-min)) + end (or end (point-max)) + from (or from "re") + to (or to "re")) + (let* ((ext (file-name-extension buffer-file-name t)) + (bufferfile (make-temp-file "refmt" nil ext)) + (outputfile (make-temp-file "refmt" nil ext)) + (errorfile (make-temp-file "refmt" nil ext)) + (errbuf (if refmt-show-errors (get-buffer-create "*Refmt Errors*"))) + (patchbuf (get-buffer-create "*Refmt patch*")) + (coding-system-for-read 'utf-8) + (coding-system-for-write 'utf-8) + (width-args + (cond + ((equal refmt-width-mode 'window) + (list "--print-width" (number-to-string (window-body-width)))) + ((equal refmt-width-mode 'fill) + (list "--print-width" (number-to-string fill-column))) + (t + '())))) + (unwind-protect + (save-restriction + (widen) + (write-region start end bufferfile) + (if errbuf + (with-current-buffer errbuf + (setq buffer-read-only nil) + (erase-buffer))) + (with-current-buffer patchbuf + (erase-buffer)) + (if (zerop (apply 'call-process + refmt-command nil (list (list :file outputfile) errorfile) + nil (append width-args (list "--parse" from "--print" to bufferfile)))) + (progn + (call-process-region start end "diff" nil patchbuf nil "-n" "-" + outputfile) + (reason--apply-rcs-patch patchbuf start) + (message "Applied refmt") + (if errbuf (refmt--kill-error-buffer errbuf))) + (message "Could not apply refmt") + (if errbuf + (refmt--process-errors (buffer-file-name) bufferfile errorfile errbuf))))) + (kill-buffer patchbuf) + (delete-file errorfile) + (delete-file bufferfile) + (delete-file outputfile))) + +(defun refmt () + "Format the current buffer according to the refmt tool." + (interactive) + (apply-refmt)) + +(defun refmt-region-ocaml-to-reason (start end) + (interactive "r") + (apply-refmt start end "ml")) + +(defun refmt-region-reason-to-ocaml (start end) + (interactive "r") + (apply-refmt start end "re" "ml")) + +(provide 'refmt) + +;;; refmt.el ends here diff --git a/emacs.d/vendor/slack-snippets.el b/emacs.d/vendor/slack-snippets.el new file mode 100644 index 000000000000..6bf933cfb86d --- /dev/null +++ b/emacs.d/vendor/slack-snippets.el @@ -0,0 +1,228 @@ +;;; private/grfn/slack-snippets.el -*- lexical-binding: t; -*- + +(require 's) +(require 'json) +(require 'dash) +(require 'dash-functional) +(require 'request) +(require 'subr-x) + +;;; +;;; Configuration +;;; + +(defvar slack/token nil + "Legacy (https://api.slack.com/custom-integrations/legacy-tokens) access token") + +(defvar slack/include-public-channels 't + "Whether or not to inclue public channels in the list of conversations") + +(defvar slack/include-private-channels 't + "Whether or not to inclue public channels in the list of conversations") + +(defvar slack/include-im 't + "Whether or not to inclue IMs (private messages) in the list of conversations") + +(defvar slack/include-mpim nil + "Whether or not to inclue multi-person IMs (multi-person private messages) in + the list of conversations") + +;;; +;;; Utilities +;;; + +(defmacro comment (&rest _body) + "Comment out one or more s-expressions" + nil) + +(defun ->list (vec) (append vec nil)) + +(defun json-truthy? (x) (and x (not (equal :json-false x)))) + +;;; +;;; Generic API integration +;;; + +(defvar slack/base-url "https://slack.com/api") + +(defun slack/get (path params &optional callback) + "params is an alist of query parameters" + (let* ((params-callback (if (functionp params) `(() . ,params) (cons params callback))) + (params (car params-callback)) (callback (cdr params-callback)) + (params (append `(("token" . ,slack/token)) params)) + (url (concat (file-name-as-directory slack/base-url) path))) + (request url + :type "GET" + :params params + :parser 'json-read + :success (cl-function + (lambda (&key data &allow-other-keys) + (funcall callback data)))))) + +(defun slack/post (path params &optional callback) + (let* ((params-callback (if (functionp params) `(() . ,params) (cons params callback))) + (params (car params-callback)) (callback (cdr params-callback)) + (url (concat (file-name-as-directory slack/base-url) path))) + (request url + :type "POST" + :data (json-encode params) + :headers `(("Content-Type" . "application/json") + ("Authorization" . ,(format "Bearer %s" slack/token))) + :success (cl-function + (lambda (&key data &allow-other-keys) + (funcall callback data)))))) + + +;;; +;;; Specific API endpoints +;;; + +;; Users + +(defun slack/users (cb) + "Returns users as (id . name) pairs" + (slack/get + "users.list" + (lambda (data) + (->> data + (assoc-default 'members) + ->list + (-map (lambda (user) + (cons (assoc-default 'id user) + (assoc-default 'real_name user)))) + (-filter #'cdr) + (funcall cb))))) + +(comment + (slack/get + "users.list" + (lambda (data) (setq response-data data))) + + (slack/users (lambda (data) (setq --users data))) + + ) + +;; Conversations + +(defun slack/conversation-types () + (->> + (list (when slack/include-public-channels "public_channel") + (when slack/include-private-channels "private_channel") + (when slack/include-im "im") + (when slack/include-mpim "mpim")) + (-filter #'identity) + (s-join ","))) + +(defun channel-label (chan users-alist) + (cond + ((json-truthy? (assoc-default 'is_channel chan)) + (format "#%s" (assoc-default 'name chan))) + ((json-truthy? (assoc-default 'is_im chan)) + (let ((user-id (assoc-default 'user chan))) + (format "Private message with %s" (assoc-default user-id users-alist)))) + ((json-truthy? (assoc-default 'is_mpim chan)) + (->> chan + (assoc-default 'purpose) + (assoc-default 'value))))) + +(defun slack/conversations (cb) + "Calls `cb' with (id . '((label . \"label\") '(topic . \"topic\") '(purpose . \"purpose\"))) pairs" + (slack/get + "conversations.list" + `(("types" . ,(slack/conversation-types)) + ("exclude-archived" . "true")) + (lambda (data) + (setq --data data) + (slack/users + (lambda (users) + (->> data + (assoc-default 'channels) + ->list + (-filter + (lambda (chan) (channel-label chan users))) + (-map + (lambda (chan) + (cons (assoc-default 'id chan) + `((label . ,(channel-label chan users)) + (topic . ,(->> chan + (assoc-default 'topic) + (assoc-default 'value))) + (purpose . ,(->> chan + (assoc-default 'purpose) + (assoc-default 'value))))))) + (funcall cb))))))) + +(comment + (slack/get + "conversations.list" + '(("types" . "public_channel,private_channel,im,mpim")) + (lambda (data) (setq response-data data))) + + (slack/get + "conversations.list" + '(("types" . "im")) + (lambda (data) (setq response-data data))) + + (slack/conversations + (lambda (convos) (setq --conversations convos))) + + ) + +;; Messages + +(cl-defun slack/post-message + (&key text channel-id (on-success #'identity)) + (slack/post "chat.postMessage" + `((text . ,text) + (channel . ,channel-id) + (as_user . t)) + on-success)) + +(comment + + (slack/post-message + :text "hi slackbot" + :channel-id slackbot-channel-id + :on-success (lambda (data) (setq resp data))) + + (-map (lambda (chan) (let ((label (assoc-default 'label (cdr chan))) + (id (car chan))) + (propertize label 'channel-id id))) + --conversations) + + ) + +;;; +;;; Posting code snippets to slack +;;; + +(defun prompt-for-channel (cb) + (slack/conversations + (lambda (conversations) + (setq testing (-map (lambda (chan) (let ((label (assoc-default 'label (cdr chan))) + (id (car chan))) + (propertize label 'channel-id id))) + conversations)) + (ivy-read + "Select channel: " + ;; TODO want to potentially use purpose / topic stuff here + (-map (lambda (chan) (let ((label (assoc-default 'label (cdr chan))) + (id (car chan))) + (propertize label 'channel-id id))) + conversations) + :history 'slack/channel-history + :action (lambda (selected) + (let ((channel-id (get-text-property 0 'channel-id selected))) + (funcall cb channel-id) + (message "Sent message to %s" selected)))))) + nil) + +(defun slack-send-code-snippet (&optional snippet-text) + (interactive) + (when-let ((snippet-text (or snippet-text + (buffer-substring-no-properties (mark) (point))))) + (prompt-for-channel + (lambda (channel-id) + (slack/post-message + :text (format "```\n%s```" snippet-text) + :channel-id channel-id))))) |