Skip to content

Commit 0d53bf9

Browse files
committed
Add idris-start-idris2-project which uses idris2 --init to generate new ipkg file.
Why: Idris2 does better job to create the ipkg file than us.
1 parent 09de86a commit 0d53bf9

File tree

2 files changed

+154
-0
lines changed

2 files changed

+154
-0
lines changed

idris-commands.el

+83
Original file line numberDiff line numberDiff line change
@@ -1244,6 +1244,89 @@ of the term to replace."
12441244
(find-file (car files)))
12451245
(t (find-file (completing-read "Package file: " files nil t))))))
12461246

1247+
(defun idris-start-idris2-project ()
1248+
"Interactively create a new Idris2 project with ipkg file and first module."
1249+
(interactive)
1250+
(cl-flet ((project-name ()
1251+
(let ((project-name (string-trim (read-string "Project name: "))))
1252+
(when (string-match-p "[^a-zA-Z0-9_ ]" project-name)
1253+
(user-error "Project name should consist only of letters, numbers, spaces and underscores"))
1254+
(when (string= "" project-name)
1255+
(user-error "Project name can not be empty"))
1256+
project-name))
1257+
(project-directory (default-filename)
1258+
(let ((dir (read-directory-name "Create in: " nil default-filename nil default-filename)))
1259+
(when (string= "" dir)
1260+
(user-error "Project directory can not be empty"))
1261+
(when (file-exists-p dir)
1262+
(user-error "%s already exists" dir))
1263+
dir)))
1264+
(let* ((project-name (project-name))
1265+
(default-filename (downcase (replace-regexp-in-string "[^a-zA-Z0-9_-]" "-" project-name)))
1266+
(package-name default-filename)
1267+
(create-in (project-directory default-filename))
1268+
(src-dir (string-trim (read-string "Source directory (src): " nil nil "src")))
1269+
(authors (string-trim (read-string (format "Authors (%s): " (user-full-name)) nil nil (user-full-name))))
1270+
(options (string-trim (read-string "Options: ")))
1271+
(module-name-suggestion (replace-regexp-in-string "[^a-zA-Z0-9]+" "." (capitalize project-name)))
1272+
(first-mod (string-trim (read-string
1273+
(format "First module name (%s): " module-name-suggestion)
1274+
nil nil module-name-suggestion)))
1275+
(ipkg-file (file-truename (concat (file-name-as-directory create-in)
1276+
(concat default-filename ".ipkg"))))
1277+
(output-buffer (generate-new-buffer "*Idris Script Output*"))
1278+
(input-buffer (generate-new-buffer "*Idris Script Input*")))
1279+
1280+
(make-directory (concat (file-name-as-directory create-in) src-dir) t)
1281+
(with-current-buffer input-buffer
1282+
(insert package-name) (newline)
1283+
(insert authors) (newline)
1284+
(insert options) (newline)
1285+
(insert src-dir) (newline)
1286+
1287+
(call-process-region (point-min) (point-max)
1288+
idris-interpreter-path
1289+
nil
1290+
output-buffer
1291+
nil
1292+
"--init"
1293+
ipkg-file))
1294+
(let ((output (with-current-buffer output-buffer
1295+
(buffer-string))))
1296+
(when (string-match-p "error" output)
1297+
(message "Idris: %s" output)))
1298+
1299+
(kill-buffer output-buffer)
1300+
(kill-buffer input-buffer)
1301+
1302+
;; Decorate the generated ipkg file
1303+
(when (file-exists-p ipkg-file)
1304+
(save-excursion
1305+
(find-file ipkg-file)
1306+
(goto-char (point-min))
1307+
(insert "-- " project-name) (newline) (newline)
1308+
(when (re-search-forward "^-- version =" nil t)
1309+
(replace-match "version = 0.1.0"))
1310+
(when (and (not (string= first-mod ""))
1311+
(re-search-forward "^-- modules =" nil t))
1312+
(replace-match "modules = ")
1313+
(insert first-mod))
1314+
(save-buffer)
1315+
1316+
;; Create Idris file in the source directory of the project
1317+
;; Default directory is the project directry
1318+
(when (not (string= first-mod ""))
1319+
(let* ((mod-path (reverse (split-string first-mod "\\.+")))
1320+
(mod-dir (mapconcat #'file-name-as-directory
1321+
(cons src-dir (reverse (cdr mod-path)))
1322+
""))
1323+
(mod-filename (concat mod-dir (car mod-path) ".idr")))
1324+
(make-directory mod-dir t)
1325+
(pop-to-buffer (find-file-noselect mod-filename))
1326+
(insert "module " first-mod) (newline) (newline)
1327+
(insert "%default total") (newline)
1328+
(save-buffer))))))))
1329+
12471330
(defun idris-start-project ()
12481331
"Interactively create a new Idris project, complete with ipkg file."
12491332
(interactive)

test/idris-commands-test.el

+71
Original file line numberDiff line numberDiff line change
@@ -313,6 +313,77 @@ myReverse xs = revAcc [] xs where
313313
(delete-directory mock-directory-name t)
314314
(idris-quit))))
315315

316+
(defmacro idris-generate-mock-read (clauses &optional default)
317+
"Generate a function with cond expression from CLAUSES and optional DEFAULT."
318+
`(lambda (prompt &optional &rest _)
319+
(cond
320+
,@(mapcar (lambda (clause)
321+
`((string-match-p ,(if (symbolp (car clause))
322+
;; Convert symbol to string and
323+
;; remove leading colon and
324+
;; replace dashes with a space
325+
(replace-regexp-in-string
326+
"^\\:" ""
327+
(replace-regexp-in-string "-" " " (symbol-name (car clause))))
328+
(car clause))
329+
prompt)
330+
,(cdr clause)))
331+
clauses)
332+
(t (or ,default "")))))
333+
334+
(ert-deftest idris-start-idris2-project ()
335+
"Test `idris-start-idris2-project' creating a project."
336+
337+
(skip-unless (string-match-p "idris2$" idris-interpreter-path))
338+
(cl-flet ((read-string-stub (idris-generate-mock-read ((:project-name . "Idris2 Test Project")
339+
(:author . "Joe Doe")
340+
(:source-dir . "mysrc")
341+
(:options . "--inc")
342+
(:first-module . "Idris2.Test.Project"))))
343+
(read-dir-stub
344+
(idris-generate-mock-read
345+
((:create-in . (idris-file-name-concat "test-data" "idris2-test-project"))))))
346+
(advice-add 'read-string :override #'read-string-stub)
347+
(advice-add 'read-directory-name :override #'read-dir-stub)
348+
(unwind-protect
349+
(progn
350+
(save-excursion
351+
(idris-start-idris2-project))
352+
353+
(let* ((ipkg-file-path (idris-file-name-concat "test-data"
354+
"idris2-test-project"
355+
"idris2-test-project.ipkg"))
356+
(ipkg-buffer (find-file-noselect ipkg-file-path))
357+
(ipkg-content (with-current-buffer ipkg-buffer
358+
(buffer-substring-no-properties (point-min) (point-max)))))
359+
360+
(should (string-match-p "^-- Idris2 Test Project" ipkg-content))
361+
(should (string-match-p "^package idris2-test-project" ipkg-content))
362+
(should (string-match-p "^version = 0.1.0" ipkg-content))
363+
(should (string-match-p "^authors = \"Joe Doe\"" ipkg-content))
364+
(should (string-match-p "^opts = \"--inc\"" ipkg-content))
365+
(should (string-match-p "^sourcedir = \"mysrc\"" ipkg-content))
366+
(kill-buffer ipkg-buffer))
367+
368+
(let* ((first-mod-file-path (idris-file-name-concat "test-data"
369+
"idris2-test-project"
370+
"mysrc"
371+
"Idris2"
372+
"Test"
373+
"Project.idr"))
374+
(first-mod-buffer (find-file-noselect first-mod-file-path))
375+
(first-mod-content (with-current-buffer first-mod-buffer
376+
(buffer-substring-no-properties (point-min) (point-max)))))
377+
378+
(should (string-match-p "^module Idris2.Test.Project" first-mod-content))
379+
(should (string-match-p "^%default total" first-mod-content))
380+
(kill-buffer first-mod-buffer))
381+
382+
(delete-directory (idris-file-name-concat "test-data" "idris2-test-project") t))
383+
384+
(advice-remove 'read-string #'read-string-stub)
385+
(advice-remove 'read-directory-name #'read-dir-stub))))
386+
316387
;; Tests by Yasuhiko Watanabe
317388
;; https://github.com/idris-hackers/idris-mode/pull/537/files
318389
(idris-ert-command-action "test-data/CaseSplit.idr" idris-case-split idris-test-eq-buffer)

0 commit comments

Comments
 (0)