krz/orgstar

Tangle with Lisp header values and -l coderef formats !134

merged merged by cmc on 2026-10-07 06:01 UTC · krz/orgstar:tangle-lisp-headers into main

2 files changed, +104 −12

Layout: unified · split

Sources/OrgCore/Compute/Tangle.swift +59 −11
@@ -3,8 +3,8 @@ import Foundation
3// `org-babel-tangle` (Org 9.8.7 ob-tangle.el): source blocks written to the files their 3// `org-babel-tangle` (Org 9.8.7 ob-tangle.el): source blocks written to the files their
4// `:tangle` names, with `:noweb`, `:padline`, `:shebang`, `:mkdirp`, `:tangle-mode`, 4// `:tangle` names, with `:noweb`, `:padline`, `:shebang`, `:mkdirp`, `:tangle-mode`,
5// `:prologue` and `:epilogue`, `:var` for shells, Python and Emacs Lisp, and `:comments` for 5// `:prologue` and `:epilogue`, `:var` for shells, Python and Emacs Lisp, and `:comments` for
6// languages whose comment syntax is known. Header values Org would evaluate as Lisp aren't 6// languages whose comment syntax is known. Header values written as Lisp are evaluated with
7// supported. 7// the file's name and folder; other Lisp is refused.
8 8
9public enum Tangle { 9public enum Tangle {
10 /// All blocks (C-c C-v t), the block at an offset (C-u C-c C-v t), or the blocks going to 10 /// All blocks (C-c C-v t), the block at an offset (C-u C-c C-v t), or the blocks going to
@@ -65,15 +65,15 @@ public enum Tangle {
65 switch scope { 65 switch scope {
66 case .block(let offset): 66 case .block(let offset):
67 guard let block = block(at: offset, in: model) else { throw Babel.Failure.message("Point is not in a source code block") } 67 guard let block = block(at: offset, in: model) else { throw Babel.Failure.message("Point is not in a source code block") }
68 try add(block, try params(block, model: model, text: ns), counter: 1) 68 try add(block, try params(block, model: model, text: ns, path: path), counter: 1)
69 case .all, .target: 69 case .all, .target:
70 var target: String? 70 var target: String?
71 if case .target(let offset) = scope { 71 if case .target(let offset) = scope {
72 guard let block = block(at: offset, in: model) else { throw Babel.Failure.message("Point is not in a source code block") } 72 guard let block = block(at: offset, in: model) else { throw Babel.Failure.message("Point is not in a source code block") }
73 target = try params(block, model: model, text: ns).single[":tangle"] ?? "no" 73 target = try params(block, model: model, text: ns, path: path).single[":tangle"] ?? "no"
74 } 74 }
75 for block in model.srcBlocks where !excluded(block, model: model) { 75 for block in model.srcBlocks where !excluded(block, model: model) {
76 let params = try params(block, model: model, text: ns) 76 let params = try params(block, model: model, text: ns, path: path)
77 let tangle = params.single[":tangle"] ?? "no" 77 let tangle = params.single[":tangle"] ?? "no"
78 if tangle == "no" || (block.language == nil && tangle == "yes") { continue } 78 if tangle == "no" || (block.language == nil && tangle == "yes") { continue }
79 if let target, target != tangle { continue } 79 if let target, target != tangle { continue }
@@ -126,14 +126,58 @@ public enum Tangle {
126 } 126 }
127 } 127 }
128 128
129 static func params(_ block: SrcBlockInfo, model: DocumentModel, text: NSString) throws -> Babel.Params { 129 static func params(_ block: SrcBlockInfo, model: DocumentModel, text: NSString, path: String) throws -> Babel.Params {
130 let params = try Babel.Params(block: block, model: model, text: text) 130 var params = try Babel.Params(block: block, model: model, text: text)
131 for (key, value) in params.single where value.hasPrefix("(") && key != ":tangle-mode" { 131 for (key, value) in params.single where value.hasPrefix("(") && key != ":tangle-mode" {
132 throw Babel.Failure.message("\(key) \(value) is Lisp to evaluate, which tangling doesn't support yet; nothing was tangled.") 132 params.single[key] = try evaluate(value, key: key, path: path)
133 } 133 }
134 return params 134 return params
135 } 135 }
136 136
137 /// `org-babel-read` of a header value written as Lisp, with what a file's buffer knows:
138 /// `buffer-file-name`, `default-directory` and `system-type`.
139 static func evaluate(_ value: String, key: String, path: String) throws -> String {
140 let refusal = Babel.Failure.message("\(key) \(value) is Lisp tangling can't evaluate yet; nothing was tangled.")
141 let lisp = Elisp()
142 let directory = (path as NSString).deletingLastPathComponent + "/"
143 lisp.set("buffer-file-name", .string(path))
144 lisp.set("default-directory", .string(directory))
145 lisp.set("system-type", .symbol("darwin"))
146 func string(_ args: [Sexp], _ i: Int) throws -> String { try Elisp.string(args[i]) }
147 lisp.define("expand-file-name") { lisp, args in
148 try Elisp.arity(args, 1...2, "expand-file-name")
149 let base = args.count > 1 && !Elisp.isNil(args[1]) ? try string(args, 1) : (try Elisp.string(lisp.value("default-directory")))
150 return .string(expand(try string(args, 0), in: (base as NSString).expandingTildeInPath))
151 }
152 lisp.define("file-name-directory") { _, args in
153 try Elisp.arity(args, 1...1, "file-name-directory")
154 let name = try string(args, 0)
155 guard let slash = name.lastIndex(of: "/") else { return .nil }
156 return .string(String(name[...slash]))
157 }
158 lisp.define("file-name-nondirectory") { _, args in
159 try Elisp.arity(args, 1...1, "file-name-nondirectory")
160 let name = try string(args, 0)
161 return .string(name.lastIndex(of: "/").map { String(name[name.index(after: $0)...]) } ?? name)
162 }
163 lisp.define("file-name-sans-extension") { _, args in
164 try Elisp.arity(args, 1...1, "file-name-sans-extension")
165 return .string((try string(args, 0) as NSString).deletingPathExtension)
166 }
167 lisp.define("file-name-as-directory") { _, args in
168 try Elisp.arity(args, 1...1, "file-name-as-directory")
169 let name = try string(args, 0)
170 return .string(name.hasSuffix("/") ? name : name + "/")
171 }
172 guard let form = try? LispReader.readFirst(value).sexp, let result = try? lisp.eval(form), !Elisp.isNil(result) else { throw refusal }
173 switch result {
174 case .string(let s): return s
175 case .symbol(let s): return s
176 case .integer, .float: return Elisp.printed(result)
177 default: throw refusal
178 }
179 }
180
137 /// `org-babel-effective-tangled-filename`. 181 /// `org-babel-effective-tangled-filename`.
138 static func fileName(path: String, language: String?, tangle: String) throws -> String? { 182 static func fileName(path: String, language: String?, tangle: String) throws -> String? {
139 let directory = (path as NSString).deletingLastPathComponent 183 let directory = (path as NSString).deletingLastPathComponent
@@ -172,10 +216,14 @@ public enum Tangle {
172 body = try expandBody(body, language: block.language ?? "", params: params, model: model, text: text) 216 body = try expandBody(body, language: block.language ?? "", params: params, model: model, text: text)
173 } 217 }
174 // `(string-match "-r" extra)`. 218 // `(string-match "-r" extra)`.
175 if block.switches.joined(separator: " ").contains("-r") { 219 let switches = block.switches.joined(separator: " ")
176 if block.switches.contains("-l") { throw Babel.Failure.message("-l coderef formats aren't supported yet; nothing was tangled.") } 220 if switches.contains("-r") {
221 // `org-src-coderef-regexp` of `-l "FORMAT"`, or of `org-coderef-label-format`.
222 let format = switches.firstMatch(of: /-l +"([^"\n]+)"/).map { String($0.1) } ?? "(ref:%s)"
223 let pattern = "[ \\t]*" + NSRegularExpression.escapedPattern(for: format)
224 .replacingOccurrences(of: "%s", with: "[-a-zA-Z0-9_][-a-zA-Z0-9_ ]*") + "[ \\t]*$"
177 body = body.components(separatedBy: "\n") 225 body = body.components(separatedBy: "\n")
178 .map { $0.replacingOccurrences(of: "[ \\t]*\\(ref:[-a-zA-Z0-9_][-a-zA-Z0-9_ ]*\\)[ \\t]*$", with: "", options: .regularExpression) } 226 .map { $0.replacingOccurrences(of: pattern, with: "", options: .regularExpression) }
179 .joined(separator: "\n") 227 .joined(separator: "\n")
180 } 228 }
181 let preserve = block.switches.contains("-i") 229 let preserve = block.switches.contains("-i")
Tests/OrgCoreTests/TangleTests.swift +45 −1
@@ -207,8 +207,52 @@ struct TangleTests {
207 #expect(Self.describe(ours, root: "/oracle") == theirs.text, "ours:\n\(Self.describe(ours, root: "/oracle"))\nemacs:\n\(theirs.text)\n\(theirs.error)") 207 #expect(Self.describe(ours, root: "/oracle") == theirs.text, "ours:\n\(Self.describe(ours, root: "/oracle"))\nemacs:\n\(theirs.text)\n\(theirs.error)")
208 } 208 }
209 209
210 static let lisp = """
211 #+begin_src sh :tangle (concat "joined" ".sh")
212 echo joined
213 #+end_src
214 #+begin_src sh :tangle (if (eq system-type 'darwin) "mac.sh" "other.sh")
215 echo mac
216 #+end_src
217 #+begin_src sh :tangle (concat (file-name-directory buffer-file-name) "beside.sh")
218 echo beside
219 #+end_src
220 #+begin_src sh :tangle (expand-file-name "sub/deep.sh") :mkdirp yes
221 echo deep
222 #+end_src
223 #+begin_src sh :tangle (file-name-sans-extension (file-name-nondirectory buffer-file-name))
224 echo named after the file
225 #+end_src
226 #+begin_src python -r -l "#(ref:%s)" :tangle refs.py
227 x = 1 #(ref:one)
228 y = 2 (ref:kept)
229 #+end_src
230 #+begin_src python -r :tangle refs.py
231 z = 3 (ref:gone)
232 #+end_src
233 """ + "\n"
234
235 @Test func evaluatesLispHeadersLikeOrg() throws {
236 let form = """
237 (let* ((dir (file-truename (make-temp-file "orgstar-tangle" t)))
238 (src (expand-file-name "notes.org" dir))
239 (text (buffer-string)) out)
240 (require 'ob-shell) (require 'ob-python)
241 (with-temp-file src (insert text))
242 (with-current-buffer (find-file-noselect src)
243 (let ((files (org-babel-tangle)))
244 (setq out (mapconcat (lambda (f) (format "== %s %o\\n%s" (file-relative-name f dir) (file-modes f)
245 (with-temp-buffer (insert-file-contents f) (buffer-string))))
246 (sort (copy-sequence files) #'string<) ""))))
247 (erase-buffer) (insert out))
248 """
249 let theirs = try EmacsOracle.run([EmacsOracle.Case(text: Self.lisp, point: 1, form: form)])[0]
250 let ours = try Tangle.run(text: Self.lisp, path: "/oracle/notes.org").get()
251 #expect(Self.describe(ours, root: "/oracle") == theirs.text, "ours:\n\(Self.describe(ours, root: "/oracle"))\nemacs:\n\(theirs.text)\n\(theirs.error)")
252 }
253
210 @Test func refusesWhatItCantDo() { 254 @Test func refusesWhatItCantDo() {
211 for (language, header) in [("haskell", ":comments link"), ("sh", ":tangle (concat \"a\" \".sh\")"), ("sh", ":tangle-mode go+q")] { 255 for (language, header) in [("haskell", ":comments link"), ("sh", ":tangle (concat user-emacs-directory \"a.sh\")"), ("sh", ":tangle-mode go+q")] {
212 let text = "#+begin_src \(language) :tangle yes \(header)\necho\n#+end_src\n" 256 let text = "#+begin_src \(language) :tangle yes \(header)\necho\n#+end_src\n"
213 guard case .failure = Tangle.run(text: text, path: "/x/a.org") else { Issue.record("tangled with \(header)"); continue } 257 guard case .failure = Tangle.run(text: text, path: "/x/a.org") else { Issue.record("tangled with \(header)"); continue }
214 } 258 }