git.fiddlerwoaroof.com
Raw Blame History
(in-package :fwoar.git-systems)

(defmacro new (class &rest initializer-syms)
  `(make-instance ,class
                  ,@(mapcan (lambda (_1)
                              (list (alexandria:make-keyword _1)
                                    _1))
                            initializer-syms)))


(defclass spec ()
  ((%name :reader name :initarg :name :initform (error "need a dep name")
          :documentation "name of directory for specced dependency")))

(defclass git-spec (spec)
  ((%url :reader url :initarg :url :initform (error "need a git url"))
   (%ref :reader ref :initarg :ref :initform (error "need a git ref"))))
(defun git-spec (name url ref)
  (new 'git-spec name url ref))

(defgeneric ensure-dep (spec base)
  (:method ((spec git-spec) base)
    (let ((target-dir (merge-pathnames (make-pathname :directory (list :relative (name spec)))
                                       base)))
      (if (probe-file target-dir)
          (legit:fetch target-dir)
          (progn (ensure-directories-exist target-dir)
                 (legit:clone (url spec) target-dir)))
      (legit:checkout target-dir (ref spec))
      target-dir)))

(defmacro define-system-dependencies (system &body dep-specs)
  (flet ((make-dep-spec (spec)
           (ecase (car spec)
             (:git `(git-spec ,@(cdr spec))))))
    `(let* ((deps (list ,@(mapcar #'make-dep-spec dep-specs)))
            (target-dir (asdf:system-relative-pathname ,system "deps/"))
            (source-registry `(:source-registry :inherit-configuration
                                                (:tree ,target-dir))))
       (mapc (lambda (dep)
               (ensure-dep dep target-dir))
             deps)
       source-registry)))

(defmacro define-dir-deps ((&optional (dir *default-pathname-defaults*)) &body dep-specs)
  (flet ((make-dep-spec (spec)
           (ecase (car spec)
             (:git `(git-spec ,@(cdr spec))))))
    `(let* ((deps (list ,@(mapcar #'make-dep-spec dep-specs)))
            (target-dir (merge-pathnames (make-pathname :directory (list :relative "deps"))
                                         ,dir))
            (source-registry `(:source-registry :inherit-configuration
                                                (:tree ,target-dir))))
       (mapc (lambda (dep)
               (ensure-dep dep target-dir))
             deps)
       source-registry)))



(defmacro define-local-projects (&body dep-specs)
  (flet ((make-dep-spec (spec)
           (ecase (car spec)
             (:git `(git-spec ,@(cdr spec))))))
    `(let* ((deps (list ,@(mapcar #'make-dep-spec dep-specs)))
            (target-dir (merge-pathnames (make-pathname :directory (list :relative "quicklisp" "local-projects"))
                                         (user-homedir-pathname))))
       (mapcar (lambda (dep)
                 (ensure-dep dep target-dir))
               deps))))

#+(or)
(progn
  ;; sample ussage
  (defun initialize ()
    (asdf:initialize-source-registry
     (define-system-dependencies :git-systems
       (:git "fwoar-lisputils" "https://github.com/fiddlerwoaroof/fwoar.lisputils.git" "751faf8a933f1a7a023945b544f0f1b563964391")
       (:git "cl-git" "https://github.com/fiddlerwoaroof/cl-git.git" "master"))))
  )