blob: 683548733f1f48684f0b6fb1b4361a4e04fc836c (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
|
;;; my-project.el -- Project related extensions for emacs core -*- lexical-binding: t -*-
;; Copyright (C) 2023 Free Software Foundation.
;; Author: Yuchen Pei <id@ypei.org>
;; Package-Requires: ((emacs "28.2"))
;; This file is part of dotfiles.
;; dotfiles is free software: you can redistribute it and/or modify it under
;; the terms of the GNU Affero General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; dotfiles is distributed in the hope that it will be useful, but WITHOUT
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Affero General
;; Public License for more details.
;; You should have received a copy of the GNU Affero General Public
;; License along with dotfiles. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;; Project related extensions for emacs core.
;;; Code:
(defvar my-projects-root-dirs nil
"List of directories to look for projects. Each element in the form
of (tag . path). One of the tags should be \"3p\" which is a default
target for cloning a project")
(defun my-get-list-of-projects ()
(flatten-list
(mapcar (lambda (pair)
(mapcar
(lambda (dir-name) (format "%s(%s)" dir-name (car pair)))
(directory-files
(cdr pair) nil directory-files-no-dot-files-regexp)))
my-projects-root-dirs)))
(defun my-project-guess-project-name ()
(file-name-nondirectory (directory-file-name
(project-root (project-current)))))
(defvar my-licenses nil
"List of licenses in the form of (licence-id . license-text-file)")
(defun my-project-copy-license-file-to-project (license)
(interactive (list (completing-read "License to copy to project root: "
(mapcar 'car my-licenses))))
(let ((from (alist-get (intern license) my-licenses))
(to (concat (project-root (project-current))
"COPYING." license)))
(copy-file from to)
(message "Copied license of %s to %s" license to)))
(defun my-project-remember-all-projects ()
"Remember all projects under `my-projects-root-dirs'."
(pcase-dolist (`(_ . ,dir) my-projects-root-dirs)
(project-remember-projects-under dir)))
;; Override project-remember-projects-under The original function is
;; buggy: it does not look for projects in surdirs unless recursive.
(defun my-project-remember-projects-under (dir &optional recursive)
"Index all projects below a directory DIR.
If RECURSIVE is non-nil, recurse into all subdirectories to find
more projects. After finishing, a message is printed summarizing
the progress. The function returns the number of detected
projects."
(interactive "DDirectory: \nP")
(project--ensure-read-project-list)
(let ((queue (directory-files
dir
t
directory-files-no-dot-files-regexp))
(count 0)
(known (make-hash-table
:size (* 2 (length project--list))
:test #'equal )))
(dolist (project (mapcar #'car project--list))
(puthash project t known))
(while queue
(when-let ((subdir (pop queue))
((file-directory-p subdir)))
(when-let ((project (project--find-in-directory subdir))
(project-root (project-root project))
((not (gethash project-root known))))
(project-remember-project project t)
(puthash project-root t known)
(message "Found %s..." project-root)
(setq count (1+ count)))
(when (and recursive (file-directory-p subdir))
(setq queue
(nconc
(directory-files
subdir t directory-files-no-dot-files-regexp t)
queue)))))
(unless (eq recursive 'in-progress)
(if (zerop count)
(message "No projects were found")
(project--write-project-list)
(message "%d project%s were found"
count (if (= count 1) "" "s"))))
count))
;; FIXME: do we really need this or does the project package already
;; do so?
(defun my-project-read-project ()
(let ((key-val
(completing-read "Choose projects: "
(my-get-list-of-projects) nil t)))
(string-match "^\\(.*\\)(\\(.*\\))$" key-val)
(cons (match-string 2 key-val) (match-string 1 key-val))))
(defun my-project-get-project-directory (pair)
(concat
(alist-get (car pair) my-projects-root-dirs nil nil 'string=)
"/" (cdr pair)))
(defun my-project-read-project-root ()
(my-project-get-project-directory (my-project-read-project)))
(defun my-project-shell-at (arg)
(interactive "P")
(if arg (project-shell)
(my-shell-with-directory (my-project-read-project-root))))
(defun my-project-dired-at (arg)
(interactive "P")
(if arg (project-dired)
(dired (my-project-read-project-root))))
(defun my-project-rgrep-at (arg)
(interactive "P")
(if arg (project-query-replace-regexp)
(my-rgrep-at-directory (my-project-read-project-root))))
(defun my-project-org-set-local-source ()
(interactive)
(org-set-property "Local-source" (my-project-read-project-root)))
(defun my-project-code-stats ()
(interactive)
(switch-to-buffer-other-window (get-buffer-create "*cloc*"))
(erase-buffer)
(my-with-default-directory (my-project-read-project-root)
(message default-directory)
(insert default-directory "\n")
(call-process "cloc" nil "*cloc*" nil "HEAD" "--quiet")))
(provide 'my-project)
;;; my-project.el ends here
|
