blob: 0453f1d9abe9ea2d79dab69d3a88ade863895162 (
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
|
;;; hcel-haddorg.el --- jumping between hcel and org generated from haddorg. -*- lexical-binding: t; -*-
;; Copyright (C) 2022 Free Software Foundation, Inc.
;;
;; This file is part of hcel.
;;
;; hcel 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.
;;
;; hcel 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 hcel. If not, see <https://www.gnu.org/licenses/>.
(require 'hcel-source)
(require 'hcel-client)
(require 'hcel-utils)
(require 'json)
(require 'org)
(defcustom hcel-haddorg-dir nil
"Directory of haddorg org files."
:group 'hcel :type '(string))
(defcustom hcel-haddorg-lax-version t
"If non-nil, match highest version if no exact match found.
Say we have ghc-8.6.5.org and ghc-9.2.2.org. If the definition
is in ghc-8.10.1, hcel will attempt to look up in ghc-9.2.2.org."
:group 'hcel :type '(string))
(defun hcel-haddorg-to-hcel-definition ()
(interactive)
(save-excursion
(org-back-to-heading t)
(let* ((id (org-entry-get (point) "CUSTOM_ID"))
(splitted (split-string id "/"))
(module-name (car splitted))
(entity (if (equal "v" (cadr splitted)) "Val" "Typ"))
(name (caddr splitted))
(package) (package-id))
(goto-char (point-min))
(setq package (org-entry-get (point) "ITEM"))
(setq package-id
(hcel-parse-package-id
(progn
(string-match "^\\(.*?\\)\\(:.*\\)?$" package)
(match-string 1 package))
"-"))
(hcel-load-module-location-info
(alist-get 'location
(hcel-api-definition-site
package-id "lib" module-name entity name))))))
(defun hcel-identifier-at-point-to-haddorg ()
(interactive)
(when-let* ((internal-id (hcel-text-property-near-point 'internal-id))
(identifier (alist-get (intern internal-id) hcel-identifiers))
(exported (alist-get 'isExported identifier))
(external-id (alist-get 'externalId identifier)))
(if (and (eq exported json-false)
;; FIXME: Hacky. ExactLocation implies identifier is declared in
;; the current module.
(equal (alist-get 'tag (alist-get 'locationInfo identifier))
"ExactLocation"))
(message "%s is not exported." (hcel-occ-symbol-at-point))
(let* ((splitted (split-string external-id "|"))
(package-id (car splitted))
(module-name (cadr splitted))
(entity (cond ((equal (caddr splitted) "Typ") "t")
((equal (caddr splitted) "Val") "v")
(t nil)))
(name (cadddr splitted))
(file-name (hcel-haddorg-fuzzy-version-match package-id))
(custom-id (concat module-name "/" entity "/" name)))
(if file-name
(org-link-open-from-string
(format "[[file:%s::#%s]]" file-name custom-id))
(message "Cannot find org file for %s" package-id))))))
(defun hcel-haddorg-fuzzy-version-match (package-id)
(let ((exact-match
(expand-file-name (format "%s/%s.org" hcel-haddorg-dir package-id))))
(cond ((file-exists-p exact-match) exact-match)
(hcel-haddorg-lax-version
(when-let
((files
(sort (directory-files
hcel-haddorg-dir t
(format "^%s\\(-[0-9.]+\\)?\\.org$"
(alist-get
'name (hcel-parse-package-id package-id "-"))))
(lambda (x y)
(string> (file-name-base x)
(file-name-base y))))))
(message
"Cannot find org file for %s, opening instead that of the highest available version %s."
package-id (file-name-base (car files)))
(car files)))
(t nil))))
(provide 'hcel-haddorg)
;;; hcel-haddorg.el ends here.
|
