git.fiddlerwoaroof.com
porcelain.lisp
991d0162
 (in-package :fwoar.cl-git)
 
e24e2318
 ;; TODO: Update the code so this uses an object instead of a path.
 (defvar *git-repository*)
 (setf (documentation '*git-repository* 'variable)
       "The git repository path for porcelain commands to operate on.")
 
991d0162
 (defvar *git-encoding* :utf-8
   "The encoding to use when parsing git objects")
 
e623be68
 (defun git:in-repository (root)
   (setf *git-repository*
216c17e7
         (ensure-repository
          (truename root))))
e623be68
 
c672c979
 (defun git:repository ()
   *git-repository*)
 
b7df27f1
 (defmacro git:with-repository ((root) &body body)
216c17e7
   `(let ((*git-repository* (ensure-repository ,root)))
b7df27f1
      ,@body))
 
ad9b8a82
 (defun git:show-repository ()
   *git-repository*)
 
821ddf96
 (defun in-git-package (symbol)
   (intern (symbol-name symbol)
           :git))
 
71da880a
 (defun handle-list (_1)
   (case (in-git-package (car _1))
     (git::unwrap `(uiop:nest (car)
                              (mapcar ,@(cdr _1))))
     (t (cons (in-git-package (car _1))
              (cdr _1)))))
 
69664515
 (defun git::resolve-refish (it)
   (flet ((hash-p (it)
            (and (> (length it) 32)
                 (every (serapeum:op
                          (digit-char-p _1 16))
                        it))))
     (cond
       ((let ((it "master"))
          (block is-branch
            (mapc (fw.lu:destructuring-lambda ((name hash))
                    (when (equal it name)
                      (return-from is-branch
                        (ensure-ref hash))))
                  (branches *git-repository*))
            nil)))
       ((hash-p it) (ensure-ref it)))))
 
0b3ed859
 (defmacro git:git (&rest commands)
   `(uiop:nest ,@(reverse
69664515
                  (funcall (data-lens:<>1
                            (data-lens:over (serapeum:op
                                              (typecase _1
                                                (string `(identity ,_1))
                                                (list (handle-list _1)))))
                            (data-lens:transform-head (serapeum:op
                                                        (etypecase _1
                                                          (string `(resolve-refish ,_1))
                                                          (t _1)))))
                           commands))))
71da880a
 
b7df27f1
 (defun git::ensure-ref (it)
   (ensure-ref it))
 
69664515
 (defun git::decode (it)
   (babel:octets-to-string it :encoding *git-encoding*))
 
821ddf96
 (defun git::<<= (fun &rest args)
   (apply #'mapcan fun args))
 
b7df27f1
 (defmacro git::map (fun list)
   (alexandria:once-only (list)
     (alexandria:with-gensyms (it)
       `(mapcar ,(if (consp fun)
                     `(lambda (,it)
                        (,(in-git-package (car fun))
                         ,@(cdr fun)
                         ,it))
                     `',(in-git-package fun))
                ,list))))
 
 (defmacro git::juxt (&rest args)
   (let ((funs (butlast args))
         (arg (car (last args))))
     (alexandria:once-only (arg)
       `(list ,@(mapcar (lambda (f)
                          `(,@(alexandria:ensure-list f) ,arg))
                        funs)))))
 
71da880a
 (defmacro git::pipe (&rest funs)
   (let ((funs (reverse (butlast funs)))
         (var (car (last funs))))
     `(uiop:nest ,@(mapcar (lambda (it)
                             (if (consp it)
                                 `(,(in-git-package (car it)) ,@(cdr it))
                                 `(,(in-git-package it))))
                           funs)
                 ,var)))
 
b7df27f1
 (defun git::filter (fun &rest args)
   (apply #'remove-if-not fun args))
 
 (defun git::object (thing)
   (extract-object thing))
0c24c8f9
 
e623be68
 (defun git:show (object)
69664515
   (extract-object object))
e623be68
 
5cb25684
 (defun git:contents (object)
   (git:show object))
 
b7df27f1
 (defun git:component (&rest args)
   (let ((component-list (butlast args))
         (target (car (last args))))
     (fwoar.cl-git::component component-list target)))
 
 (defun git:tree (commit-object)
   (component :tree
              commit-object))
5cb25684
 
 (defun git::filter-tree (name-pattern tree)
   #+lispworks
   (declare (notinline serapeum:string-prefix-p))
1869d7ea
   (let* ((tree-entries (component :entries tree))
          (scanner (cl-ppcre:create-scanner name-pattern)))
5cb25684
     (remove-if-not (serapeum:op
1869d7ea
                      (cl-ppcre:scan scanner _))
                    tree-entries
                    :key #'te-name)))
5cb25684
 
821ddf96
 (defun git:branch (&optional (branch :master))
0b3ed859
   #+lispworks
   (declare (notinline serapeum:assocadr))
216c17e7
   (let ((branches (branches *git-repository*)))
     (ref *git-repository*
b7df27f1
          (serapeum:assocadr (etypecase branch
                               (string branch)
                               (keyword (string-downcase branch)))
                             branches
                             :test 'equal))))
e623be68
 
 (defun git:branches ()
216c17e7
   (branches *git-repository*))
e623be68
 
71da880a
 (defun git::parents (commit)
9d3dfa0d
   (alexandria:mappend (data-lens:<>1 (data-lens:over 'ensure-ref)
                                      #'cdr)
                       (component :parents commit)))
e623be68
 (defun git:commit-parents (commit)
71da880a
   (git::parents commit))
961c04e3
 
2d105ecd
 (defun git:rev-list (ref-id &optional (limit nil limit-p))
961c04e3
   "Return the commits reachable from the ref."
2d105ecd
   (when limit-p
     (rotatef ref-id limit))
   (labels ((iterate (queue accum &optional (count 0))
              (if (or (when limit-p
                        (= limit count))
                      (null queue))
961c04e3
                  accum
9d3dfa0d
                  (destructuring-bind (next . rest) queue
                    (iterate (append rest
                                     (git::parents next))
2d105ecd
                      (cons next accum)
                      (1+ count))))))
9235611e
     (iterate (list (ensure-ref ref-id))
       ())))