<commit_before>;;;; update-report.lisp

(defpackage #:update-report
  (:use #:cl)
  (:export #:dist-update-report)
  (:shadowing-import-from
   #:ql-dist
   #:name
   #:update-release-differences
   #:find-release
   #:relative-to
   #:system-files
   #:ensure-installed))

(in-package #:update-report)

(defvar *project-base* #p"~/src/quicklisp-projects/")

(defun project-source-file (project)
  (let ((file
         (merge-pathnames (make-pathname :directory
                                         (list :relative "projects" project)
                                         :name "source"
                                         :type "txt")
                          *project-base*)))
    (truename file)))

(defun project-info (project)
  (let ((file (project-source-file project)))
    (with-open-file (stream file)
      (let ((raw-info (read-line stream)))
        (destructuring-bind (type location &rest extra)
            (ql-util:split-spaces raw-info)
          (list* :type type :location location
                 (when extra
                   (list :extra extra))))))))

(defparameter *guess-website-patterns*
  '(("//github.com/(.*)\\.git" "https://github.com/" 0 "/")
    ("(https://gitlab.common-lisp.net/.*)\.git$")
    ("//mr.gy/(.*?)/(.*?)/" "http://mr.gy/" 0 "/" 1 "/")
    ("(http://(.*?).googlecode.com/)" 0)
    ("//common-lisp.net/projects/(.*?)/" "http://common-lisp.net/projects/" 0)
    ("https://www.lrde.epita.fr/~didier/software/lisp/"
     "https://www.lrde.epita.fr/~didier/software/lisp/")
    ("http://git.code.sf.net/p/(.*?)/code"
     "http://" 0 ".sourceforge.net")
    ("mini-cas" "http://git.tentpost.com/?p=lisp/mini-cas.git;a=summary")
    ("^(.*bitbucket.*)$" 0)
    ("(http://wcp.sdf-eu.org/software/)" 0)
    ("(http://people.csail.mit.edu/devon/lisp/)" 0)
    ("^(http://dwim.hu/live/.*)$" 0)
    ("^.*(repo.or.cz)/(.*?\\.git)$" "http://" 0 "/w/" 1)))

(defun substitute-if-matches (regex target substitution)
  (multiple-value-bind (start end anchor-starts anchor-ends)
      (ppcre:scan regex target)
    (labels ((anchor-substring (index)
               (subseq target
                       (aref anchor-starts index)
                       (aref anchor-ends index)))
             (maybe-substitute (object)
               (etypecase object
                 (string object)
                 (integer (anchor-substring object)))))
      (when (and start end)
        (format nil "~{~A~}" (mapcar #'maybe-substitute substitution))))))

(defun guess-website-by-location-pattern (location)
  (dolist (spec *guess-website-patterns*)
    (destructuring-bind (regex . substitution)
        spec
      (let ((substitution (substitute-if-matches regex
                                                 location
                                                 substitution)))
        (when substitution
          (return substitution))))))

(defun guess-website (project)
  (let ((info (project-info project)))
    (destructuring-bind (&key type location extra)
        info
      (declare (ignore type extra))
      (or (guess-website-by-location-pattern location)
          (error "Cannot guess website for ~A from ~S"
                 project
                 info)))))

(defun defsystem-form-info (defsystem)
  (list :name (string-downcase (second defsystem))
        :license (or (getf defsystem :license)
                     (getf defsystem :licence))
        :description (getf defsystem :description)
        :homepage (getf defsystem :homepage)
        :author (getf defsystem :author)
        :version (getf defsystem :version)))

(defun read-sharpdot-expression (stream character argument)
  (declare (ignore character argument))
  (let ((form (read stream)))
    (prin1-to-string form)))

(defun make-sharpdot-readtable ()
  (let ((readtable (copy-readtable nil)))
    (set-dispatch-macro-character #\# #\.
                                  #'read-sharpdot-expression
                                  readtable)
    readtable))

(defparameter *sharpdot-readtable* (make-sharpdot-readtable))

(defun system-file-info (system-file)
  "Read SYSTEM-FILE and look for a DEFSYSTEM form matching its
  pathname-name. Return the interesting properties of the
  form (license, description, perhaps more) as a plist."
  (with-open-file (stream system-file)
    (let* ((*load-truename* (truename system-file))
           (*load-pathname* *load-truename*)
           (*read-eval* nil)
           (*readtable* *sharpdot-readtable*)
           (*default-pathname-defaults*
            (make-pathname :name nil :type nil :version nil
                           :defaults *load-truename*))
           (cffi-grovel-p (find-package '#:cffi-grovel)))
      (unless cffi-grovel-p
        (let ((package (make-package '#:cffi-grovel)))
          (let ((symbol (intern "GROVEL-FILE" package)))
            (export symbol package))))
      (unwind-protect
           (handler-case
               (loop with file-name = (pathname-name system-file)
                     for form = (read stream nil stream)
                     until (eq form stream)
                     when (and (consp form)
                               (string-equal (first form) "DEFSYSTEM")
                               (string-equal (second form) file-name))
                     return (defsystem-form-info form))
             (sb-int:simple-reader-error () nil))
        (unless cffi-grovel-p
          (delete-package '#:cffi-grovel))))))

(defun test-system-p (pathname)
  (and (not (equal "should-test" (pathname-name pathname)))
       (search "-test" (namestring pathname))))

(defun project-system-files (project)
  (let ((release (find-release project)))
    (unless release (error "Could not find a release for ~A" project))
    (ensure-installed release)
    (loop for file in (system-files release)
          unless (test-system-p file)
          collect (truename (relative-to release file)))))

(defun primary-system-file (project)
  (let ((system-files (project-system-files project)))
    (cond ((null (rest system-files))
           (first system-files))
          ((find project (project-system-files project)
                 :test 'string-equal
                 :key 'pathname-name))
          (t
           nil))))

(defvar *test-new-releases*
  '("chirp" "cl-flowd" "defvariant" "delta-debug" "random"))

(defun flatten-string (string)
  "Return STRING with all newlines and other whitespace converted to
  spaces."
  (ppcre:regex-replace-all "\\s+" string " "))

(defun cliki-encode (string)
  (setf string (substitute #\_ #\Space string))
  (drakma:url-encode string :utf-8))
<commit_msg>Update heuristic for searching for primary system files.<commit_after>;;;; update-report.lisp

(defpackage #:update-report
  (:use #:cl)
  (:export #:dist-update-report)
  (:shadowing-import-from
   #:ql-dist
   #:name
   #:update-release-differences
   #:find-release
   #:relative-to
   #:system-files
   #:ensure-installed))

(in-package #:update-report)

(defvar *project-base* #p"~/src/quicklisp-projects/")

(defun project-source-file (project)
  (let ((file
         (merge-pathnames (make-pathname :directory
                                         (list :relative "projects" project)
                                         :name "source"
                                         :type "txt")
                          *project-base*)))
    (truename file)))

(defun project-info (project)
  (let ((file (project-source-file project)))
    (with-open-file (stream file)
      (let ((raw-info (read-line stream)))
        (destructuring-bind (type location &rest extra)
            (ql-util:split-spaces raw-info)
          (list* :type type :location location
                 (when extra
                   (list :extra extra))))))))

(defparameter *guess-website-patterns*
  '(("//github.com/(.*)\\.git" "https://github.com/" 0 "/")
    ("(https://gitlab.common-lisp.net/.*)\.git$")
    ("(https://gitlab.com/.*)\.git$")
    ("//mr.gy/(.*?)/(.*?)/" "http://mr.gy/" 0 "/" 1 "/")
    ("(http://(.*?).googlecode.com/)" 0)
    ("//common-lisp.net/projects/(.*?)/" "http://common-lisp.net/projects/" 0)
    ("https://www.lrde.epita.fr/~didier/software/lisp/"
     "https://www.lrde.epita.fr/~didier/software/lisp/")
    ("http://git.code.sf.net/p/(.*?)/code"
     "http://" 0 ".sourceforge.net")
    ("mini-cas" "http://git.tentpost.com/?p=lisp/mini-cas.git;a=summary")
    ("^(.*bitbucket.*)$" 0)
    ("(http://wcp.sdf-eu.org/software/)" 0)
    ("(http://people.csail.mit.edu/devon/lisp/)" 0)
    ("^(http://dwim.hu/live/.*)$" 0)
    ("^http://git.axity.net/axion/AGM.git$" "agm")
    ("^http://nst.maraist.org/download/(.*?)-latest.tar.gz$" 0)
    ("^.*(repo.or.cz)/(.*?\\.git)$" "http://" 0 "/w/" 1)))

(defun substitute-if-matches (regex target substitution)
  (multiple-value-bind (start end anchor-starts anchor-ends)
      (ppcre:scan regex target)
    (labels ((anchor-substring (index)
               (subseq target
                       (aref anchor-starts index)
                       (aref anchor-ends index)))
             (maybe-substitute (object)
               (etypecase object
                 (string object)
                 (integer (anchor-substring object)))))
      (when (and start end)
        (format nil "~{~A~}" (mapcar #'maybe-substitute substitution))))))

(defun guess-website-by-location-pattern (location)
  (dolist (spec *guess-website-patterns*)
    (destructuring-bind (regex . substitution)
        spec
      (let ((substitution (substitute-if-matches regex
                                                 location
                                                 substitution)))
        (when substitution
          (return substitution))))))

(defun guess-website (project)
  (let ((info (project-info project)))
    (destructuring-bind (&key type location extra)
        info
      (declare (ignore type extra))
      (or (guess-website-by-location-pattern location)
          (error "Cannot guess website for ~A from ~S"
                 project
                 info)))))

(defun defsystem-form-info (defsystem)
  (list :name (string-downcase (second defsystem))
        :license (or (getf defsystem :license)
                     (getf defsystem :licence))
        :description (getf defsystem :description)
        :homepage (getf defsystem :homepage)
        :author (getf defsystem :author)
        :version (getf defsystem :version)))

(defun read-sharpdot-expression (stream character argument)
  (declare (ignore character argument))
  (let ((form (read stream)))
    (prin1-to-string form)))

(defun make-sharpdot-readtable ()
  (let ((readtable (copy-readtable nil)))
    (set-dispatch-macro-character #\# #\.
                                  #'read-sharpdot-expression
                                  readtable)
    readtable))

(defparameter *sharpdot-readtable* (make-sharpdot-readtable))

(defun system-file-info (system-file)
  "Read SYSTEM-FILE and look for a DEFSYSTEM form matching its
  pathname-name. Return the interesting properties of the
  form (license, description, perhaps more) as a plist."
  (with-open-file (stream system-file)
    (let* ((*load-truename* (truename system-file))
           (*load-pathname* *load-truename*)
           (*read-eval* nil)
           (*readtable* *sharpdot-readtable*)
           (*default-pathname-defaults*
            (make-pathname :name nil :type nil :version nil
                           :defaults *load-truename*))
           (cffi-grovel-p (find-package '#:cffi-grovel)))
      (unless cffi-grovel-p
        (let ((package (make-package '#:cffi-grovel)))
          (let ((symbol (intern "GROVEL-FILE" package)))
            (export symbol package))))
      (unwind-protect
           (handler-case
               (loop with file-name = (pathname-name system-file)
                     for form = (read stream nil stream)
                     until (eq form stream)
                     when (and (consp form)
                               (string-equal (first form) "DEFSYSTEM")
                               (string-equal (second form) file-name))
                     return (defsystem-form-info form))
             (sb-int:simple-reader-error (c)
               (warn "reader error ~A" c)
               (values nil c)))
        (unless cffi-grovel-p
          (delete-package '#:cffi-grovel))))))

(defun test-system-p (pathname)
  (and (not (equal "should-test" (pathname-name pathname)))
       (search "-test" (namestring pathname))))

(defun shortest-by-namestring (pathnames)
  (first (sort (copy-seq pathnames) #'<
               :key (lambda (pathname) (length (namestring pathname))))))

(defun strip-prefix (prefix string)
  (if (eql 0 (search prefix string :end2 (length prefix)))
      (subseq string (length prefix))
      string))

(defun normalize-for-comparison (name)
  (strip-prefix "cl-" name))

(defun applicable-system-name (project name)
  "Return true if NAME is applicable to PROJECT. Works by normalizing
  each before checking anything."
  (search (normalize-for-comparison project)
          (normalize-for-comparison name)))

(defun project-system-files (project)
  (let ((release (find-release project)))
    (unless release (error "Could not find a release for ~A" project))
    (ensure-installed release)
    (loop for file in (system-files release)
          unless (or (test-system-p file)
                     (not (applicable-system-name project
                                                  (pathname-name file))))
          collect (truename (relative-to release file)))))

(defun primary-system-file (project)
  (let ((system-files (project-system-files project)))
    (cond ((null (rest system-files))
           (first system-files))
          ((find project (project-system-files project)
                 :test 'string-equal
                 :key 'pathname-name))
          (t
           (shortest-by-namestring system-files)))))

(defvar *test-new-releases*
  '("chirp" "cl-flowd" "defvariant" "delta-debug" "random"))

(defun flatten-string (string)
  "Return STRING with all newlines and other whitespace converted to
  spaces."
  (ppcre:regex-replace-all "\\s+" string " "))

(defun cliki-encode (string)
  (setf string (substitute #\_ #\Space string))
  (drakma:url-encode string :utf-8))

{'fraction_non_alphanumeric': 0.15469613259668508, 'fraction_numerical': 0.002167983775089167, 'mean_word_length': 2.134590092064884, 'pattern_counts': {'":': 0, '<': 4, '<?xml version=': 0, '>': 3, 'https://': 9, 'lorem ipsum': 0, 'www.': 4, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 27, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '2180579', 'n_tokens_mistral': 4457, 'n_tokens_neox': 4261, 'n_words': 1032}