cl-micropm

commit 437e6e2403e624f5615504e7bf8db931c7eb97eb
parent 387ce830d557c63792ae823c0dd4a8e847aaa9c2
Author: Risto Stevcev <me@risto.codes>
Date:   Thu, 31 Aug 2023 22:08:14 +0200

Refactored and cleaned up code

Diffstat:
M
cl-micropm.lisp
 | 
66
++++++++++++++++++++++++++++++++++++++++++++++++------------------

1 file changed, 48 insertions(+), 18 deletions(-)
diff --git a/cl-micropm.lisp b/cl-micropm.lisp
@@ -3,19 +3,39 @@
 
 (in-package :micropm)
 
+(require 'asdf)
+
 (defvar *lisp-systems-dir* #P"./lisp-systems/")
 
 (defvar *quicklisp-projects-dir*
   (uiop:merge-pathnames* #P"quicklisp-projects/projects/" (uiop:getcwd)))
 
-(defun init (system-name)
-  ;; Add quicklisp-projects submodule
+(defun setup (system-name &key (ignore-error t))
+  "Sets up micropm and the project's dependencies"
+  ;; Quicklisp sources (obtained from the quicklisp-projects repo)
+  (unless (uiop:directory-exists-p *quicklisp-projects-dir*)
+    (add-quicklisp-projects-submodule))
+
+  ;; Quicklisp systems index (obtained from a generated file from Dockerfile)
+  (unless (boundp '*systems-alist*)
+    (generate-quicklisp-index))
+
+  ;; Clone the dependencies listed in the system
   (add-local-project-to-asdf)
   (loop for i in (locate-dependencies system-name) do
-    (print i)))
+    (if ignore-error
+        (ignore-errors (clone-dependencies system-name *systems-alist* :include-system t))
+        (clone-dependencies system-name *systems-alist* :include-system t))))
 
 #+nil(init "micropm")
 
+(defun setup-asdf-registry ()
+  "Initializes the ASDF registry with the existing dependencies in *lisp-systems-dir*"
+  (setf asdf:*central-registry* (cons (uiop:getcwd) (list-lisp-systems-paths))))
+
+(defun add-quicklisp-projects-submodule ()
+  (uiop:run-program "git submodule add https://github.com/quicklisp/quicklisp-projects.git"))
+
 (defun add-local-project-to-asdf ()
   "Configures ASDF to find the project in the current working directory"
   (when (not (find-if (lambda (e) (equal e (uiop:getcwd))) asdf:*central-registry*))
@@ -115,19 +135,23 @@ RUN sbcl --non-interactive \\
 
 (defun micropm::get-deps (system alist)
   "Recursively finds all of the dependencies for the system"
-  (let ((dependencies (rest (assoc system alist))))
+  (let* ((system-name (intern (string-upcase system)))
+         (dependencies
+          (rest (assoc-if (lambda (x) (equal system-name x)) alist))))
     (if dependencies
-        (let ((list (mapcan (lambda (x) (cons system (micropm::get-deps x alist))) dependencies)))
+        (let ((list (mapcan (lambda (x) (cons system-name (micropm::get-deps x alist)))
+                            dependencies)))
           (remove-duplicates list))
-        (list system))))
+        (list system-name))))
 
 (defun get-dependencies (system systems-alist)
-  (loop for x in (get-deps system systems-alist)
-        when (not (member x `(,system uiop asdf))) collect x))
+  (let ((system-name (intern (string-upcase system))))
+    (loop for x in (get-deps system-name systems-alist)
+          when (not (member x `(,system-name uiop asdf))) collect x)))
 
 #+nil(get-dependencies 'cffi *systems-alist*)
 
-(defconstant +source-types+
+#+nil(defconstant +source-types+
   '(branched-git
     cvs
     darcs
@@ -145,25 +169,27 @@ RUN sbcl --non-interactive \\
     tagged-git))
 
 (defun get-source-type (source)
-  (read-from-string (first source)))
+  (first source))
 
 (defun ediware-p (source)
   "Git source: https://github.com/edicl/"
-  (equal (get-source-type source) 'ediware-http))
+  (equal (get-source-type source) "ediware-http"))
 
 (defun kmr-p (source)
   "Git source: http://git.kpe.io/"
-  (equal (get-source-type source) 'kmr-git))
+  (equal (get-source-type source) "kmr-git"))
 
 (defun http-get-source-p (source)
-  (member (get-source-type source) '(http https single-file)))
+  (member-if (lambda (x) (equal (get-source-type source) x))
+             '("http" "https" "single-file")))
 
 (defun git-clone-source-p (source)
-  (member (get-source-type source)
-          '(git latest-github-release latest-github-tag latest-gitlab-release)))
+  (member-if (lambda (x) (equal (get-source-type source) x))
+             '("git" "latest-github-release" "latest-github-tag" "latest-gitlab-release")))
 
 (defun git-clone-tagged-source-p (source)
-  (member (get-source-type source) '(branched-git tagged-git)))
+  (member-if (lambda (x) (equal (get-source-type source) x))
+             '("branched-git" "tagged-git")))
 
 (defun clone-dependency (system-name source &key (clone nil))
   (let ((url (second source))
@@ -179,12 +205,16 @@ RUN sbcl --non-interactive \\
          (uiop:run-program (format nil "git ~a ~a#~a ~a" git-cmd url tag dir) :output t)))
       (t (error (format nil "Unimplemented for source: ~a" source))))))
 
-(defun clone-dependencies (system systems-alist &key (clone nil))
+(defun clone-dependencies (system systems-alist &key (include-system t) (clone nil))
   (let ((dependencies (get-dependencies system systems-alist)))
     (loop for system-name in dependencies do
       (setf system-name (string-downcase system-name))
       (clone-dependency system-name
                         (first (fetch-system-quicklisp-source system-name))
+                        :clone clone))
+    (when include-system
+      (clone-dependency system
+                        (first (fetch-system-quicklisp-source system))
                         :clone clone))))
 
 (defun add-dependency (system-name)
@@ -197,7 +227,7 @@ RUN sbcl --non-interactive \\
 
 (defun list-lisp-systems-paths ()
   "Lists the paths of the dependencies in lisp-systems"
-  (let ((dir (uiop:merge-pathnames* (uiop:getcwd) *lisp-systems-dir*)))
+  (let ((dir (uiop:merge-pathnames* *lisp-systems-dir* (uiop:getcwd))))
     (uiop:subdirectories dir)))
 
 #+nil(push