Lisp repos dataset

repo-stats.csv

repo-stats.lisp

(defpackage #:snippets/repo-stats
  (:use #:cl)
  (:import-from
   #:com.gigamonkeys.json
   #:parse-json)
  (:import-from
   #:sb-ext
   #:run-program)
  (:export
   #:walk
   #:csv))

(in-package #:snippets/repo-stats)

(defvar *repo-filespec*
  "/home/death/quicklisp/third-party/*")

(defstruct repo
  name
  author
  loc
  systems
  deps)

(defun walk ()
  (let* ((dirs (directory *repo-filespec*))
         (repos (make-hash-table :test 'equalp))
         (n (length dirs)))
    (format t "Scanning ~D directories.~%" n)
    (loop for i upfrom 0
          for dir in dirs
          do (let ((*default-pathname-defaults* dir)
                   (name (car (last (pathname-directory dir)))))
               (setf (gethash name repos)
                     (make-repo :name name
                                :author (author)
                                :loc (loc)
                                :systems (systems)
                                :deps (deps)))
               (when (zerop (mod i (truncate n 20)))
                 (write-char #\.)
                 (force-output))))
    repos))

(defun author ()
  (with-input-from-string (in (git "remote" "-v"))
    (let ((line (read-line in nil nil)))
      (cond ((null line) :na)
            ((search "fatal:" line) :na)
            ((between line "github.com/" "/"))
            ((between line "gitlab.common-lisp.net/" "/"))
            ((between line "gitlab.com/" "/"))
            ((between line "notabug.org/" "/"))
            ((between line "bitbucket.org/" "/"))
            ((search "adeht" line) :na)
            ((search ":death" line) :na)
            ((search "kpe.io" line) "kpe")
            ((search "lichteblau.com" line) "lichteblau")
            (t :na)))))

(defun loc ()
  (let ((json (parse-json
               (string-trim '(#\Space #\Newline)
                            (run "cloc" "." "--json")))))
    (loop for (key1 val1) on json by #'cddr
          when (equal key1 "Lisp")
          do (loop for (key2 val2) on val1 by #'cddr
                   when (equal key2 "code")
                   do (return-from loc val2))))
  0)

(defun between (string prefix suffix)
  (let ((pos (search prefix string)))
    (when pos
      (let ((pos2 (search suffix string :start2 (+ pos (length prefix)))))
        (when pos2
          (subseq string (+ pos (length prefix)) pos2))))))

(defun git (&rest args)
  (apply #'run "git" args))

(defun systems ()
  (mapcar #'dep-name (asd-items "defsystem ")))

(defun deps ()
  (mapcar #'dep-name (apply #'append (asd-items ":depends-on"))))

(defun asd-items (indicator)
  (let ((asd-files (directory (merge-pathnames "**/*.asd")))
        (result '()))
    (dolist (asd-file asd-files)
      (push (ignore-errors (asd-items-1 asd-file indicator)) result))
    (apply #'append result)))

(defun asd-items-1 (asd-file indicator)
  (with-open-file (stream asd-file :direction :input)
    (loop with pos = 0
          with depth = 0
          with in-string = nil
          with items = '()
          for line = (read-line stream nil nil)
          while line
          do (dotimes (i (length line))
               (let ((char (char line i)))
                 (cond ((char= char #\")
                        (cond ((not in-string)
                               (setf in-string t))
                              ((and (plusp i) (char= (char line (1- i)) #\\)))
                              (in-string
                               (setf in-string nil))))
                       ((char= char #\()
                        (unless in-string
                          (incf depth)))
                       ((char= char #\))
                        (unless in-string
                          (decf depth)
                          (when (minusp depth)
                            (warn "~S: Negative depth in line ~S; setting to zero." asd-file line)
                            (setf depth 0))))
                       ((char= char (char indicator 0))
                        (when (and (not in-string)
                                   (= depth 1))
                          (let ((m (mismatch line indicator :start1 i)))
                            (when (or (not m) (= m (+ i (length indicator))))
                              (when (or (zerop i) (find (char line (1- i)) '(#\Space #\( #\Tab #\:)))
                                (let ((old-pos (file-position stream)))
                                  (file-position stream (+ pos i (length indicator)))
                                  (push (read stream) items)
                                  (file-position stream old-pos)))))))
                       ((char= char #\;)
                        (unless in-string
                          (return))))))
             (setf pos (file-position stream))
          finally (return items))))

(defun run (program &rest args)
  (with-output-to-string (out)
    (run-program program
                 args
                 :search t
                 :directory *default-pathname-defaults*
                 :output out
                 :error :output
                 :wait t)))

(defun csv (repos &key warnings)
  (cond ((not warnings)
         (handler-bind ((warning #'muffle-warning))
           (csv repos :warnings t)))
        (t
         (format t "name,author,loc,ndeps,ndepstr,ndeprepos,ndeprepostr,cost,costtr~%")
         (let ((index (systems-index repos)))
           (loop for repo being each hash-value of repos
                 do (format t "~A,~A,~A,~A,~A,~A,~A,~A,~A~%"
                            (csv-field (repo-name repo))
                            (csv-field (repo-author repo))
                            (repo-loc repo)
                            (length (repo-deps repo))
                            (length (tr-deps repo index))
                            (length (deps-as-repos repo index))
                            (length (tr-deps-as-repos repo index))
                            (cost repo index)
                            (tr-cost repo index)))))))

(defun csv-field (x)
  (cond ((not (stringp x)) "N/A")
        ((find #\, x) (format nil "~S" x))
        (t x)))

(defun systems-index (repos)
  (let ((systems (make-hash-table :test 'equalp)))
    (loop for repo being each hash-value of repos
          do (dolist (system (repo-systems repo))
               (setf (gethash system systems) repo)))
    systems))

(defun tr-deps (repo index)
  (let ((visited (make-hash-table :test 'equalp))
        (agenda (repo-deps repo)))
    (loop while agenda
          do (let ((dep (pop agenda)))
               (unless (gethash dep visited)
                 (setf (gethash dep visited) t)
                 (let ((dep-repo (gethash dep index)))
                   (if (null dep-repo)
                       (warn "~S: Can't find dep repo for dep ~S." (repo-name repo) dep)
                       (progn
                         ;; (format t "Adding ~S from ~A.~%"
                         ;;         (repo-deps dep-repo)
                         ;;         (repo-name dep-repo))
                         (setf agenda (append (repo-deps dep-repo) agenda))))))))
    (loop for dep being each hash-key of visited
          collect dep)))

(defun dep-name (dep)
  (etypecase dep
    (string dep)
    (symbol (string dep))
    ((cons (eql :version) t) (dep-name (second dep)))
    ((cons (eql :feature) t) (dep-name (third dep)))
    ((cons (eql :require) t) (dep-name (second dep)))))

(defun cost (repo index)
  (let ((L (or (repo-loc repo) 0))
        (Lj 1000)
        (D (length (deps-as-repos repo index))))
    (float (max 0.0 (- D (/ L Lj))))))

(defun tr-cost (repo index)
  (let ((L (or (repo-loc repo) 0))
        (Lj 1000)
        (D (length (tr-deps-as-repos repo index))))
    (float (max 0.0 (- D (/ L Lj))))))

(defun deps-as-repos (repo index)
  (remove repo
          (remove-duplicates
           (mapcar (lambda (dep) (or (gethash dep index) dep))
                   (repo-deps repo))
           :test #'equalp)))

(defun tr-deps-as-repos (repo index)
  (remove repo
          (remove-duplicates
           (mapcar (lambda (dep) (or (gethash dep index) dep))
                   (tr-deps repo index))
           :test #'equalp)))