koga

#!/usr/bin/env -S sbcl --script

#-(or ccl ecl sbcl) (error "Booting Clasp from implementation ~a is not currently supported." (lisp-implementation-type))

#+sbcl
(progn
  (in-package "SB-IMPL")
  (sb-ext:without-package-locks
    (let ((old (fdefinition 'sb-impl::make-fd-stream)))
      (defun sb-impl::make-fd-stream (fd &rest rest)
        (apply old fd :auto-close nil rest)))))

(require "asdf")

(defparameter *git* nil)

(defun check-repo (&key directory repository &allow-other-keys)
  (format t "~:[Did not find~;Found~] ~A clone in ~A, assuming everything is okay.~%"
          (probe-file directory) repository directory))

(defun sync-repo (help deep-clean &key directory repository branch commit &allow-other-keys
                  &aux (exists (probe-file directory)))
  (unless (and help exists)
    (cond ((and exists (not deep-clean))
           (format t "Fetching ~A~%" repository)
           (uiop:run-program (list *git* "fetch" "--quiet")
                             :output :interactive
                             :error-output :output
                             :directory directory))
         (t
          (when (and deep-clean exists)
            (format t "Removing existing directory ~A~%" directory)
            (uiop:delete-directory-tree exists :validate t))
          (format t "Cloning ~A~%" repository)
          (uiop:run-program (list *git* "clone" repository (namestring directory))
                            :output :interactive
                            :error-output :output)))
    (when (or commit branch)
      (format t "Checking out ~A from ~A~%" (or commit branch) repository)
      (uiop:run-program (list *git* "checkout" "--quiet" (or commit branch))
                        :output :interactive
                        :error-output :output
                        :directory directory))
    (when (and branch (not commit))
      (format t "Fast forwarding to origin/~A from ~A~%" branch repository)
      (uiop:run-program (list *git* "merge" "--ff-only" (format nil "origin/~A" branch))
                        :output :interactive
                        :error-output :output
                        :directory directory))))

(defun split-keywords (value)
  (if (stringp value)
      (loop with end = (length value)
            for left = 0 then (1+ right)
            for right = (or (position #\, value :start left) end)
            collect (intern (string-upcase (subseq value left right)) "KEYWORD")
            until (>= right end))
      value))

(defun parse-keyword (value)
  (intern (string-upcase value) "KEYWORD"))

(defparameter +option-parsers+
  (list :extensions #'split-keywords
        :skip-sync #'split-keywords
        :jobs #'parse-integer
        :build-mode #'parse-keyword
        :build-path #'parse-namestring))

(defun parse-string-option (arg start eq-pos)
  (let ((name (intern (string-upcase (subseq arg start eq-pos))
                      "KEYWORD")))
    (list name (funcall (getf +option-parsers+
                               name
                               #'identity)
                        (subseq arg (1+ eq-pos))))))

(defun parse-boolean-option (arg start)
  (if (and (>= (length arg) (+ 3 start))
           (char= #\n (char arg start))
           (char= #\o (char arg (1+ start)))
           (char= #\- (char arg (+ 2 start))))
    (list (intern (string-upcase (subseq arg (+ 3 start))) "KEYWORD")
          nil)
    (list (intern (string-upcase (subseq arg start)) "KEYWORD")
          t)))

(defun parse-command-line-arguments ()
  (loop for arg in (uiop:command-line-arguments)
        for start = (position-if (lambda (x)
                                   (not (char= #\- x)))
                                 arg)
        for eq-pos = (position #\= arg)
        when eq-pos
          append (parse-string-option arg start eq-pos)
        else
          append (parse-boolean-option arg start)))

(let* ((initargs (nconc (parse-command-line-arguments)
                        (ignore-errors (uiop:read-file-form #P"config.sexp"))
                        (ignore-errors (uiop:read-file-form #P"version.sexp"))))
       (*git* (getf initargs :git "git"))
       (build (uiop:ensure-directory-pathname (getf initargs :build-path "build/")))
       (extensions (getf initargs :extensions))
       (skip-sync (getf initargs :skip-sync))
       (help (getf initargs :help)))
  (when (and (not help)
             (or (getf initargs :clean)
                 (getf initargs :deep-clean)))
    (format t "Cleaning up previous build~%~%")
    (uiop:delete-directory-tree build
                                :validate t
                                :if-does-not-exist :ignore))
  ;; Get all the external dependencies
  (unless help
    (format t "Synchronizing external repositories~%~%"))
  (loop with deep-clean = (getf initargs :deep-clean)
        for source in (loop for path in (directory #P"repos*.sexp")
                            nconc (uiop:read-file-form path))
        for name = (getf source :name)
        for extension = (getf source :extension)
        if (or (eq t skip-sync)
               (member name skip-sync))
          do (apply #'check-repo source)
        else if (or (not extension)
                    (member extension extensions))
          do (apply #'sync-repo help deep-clean source)
        unless help
          do (terpri))
  ;; Do the absolute minimum to inform ASDF about the location of systems
  ;; in order to find the clasp root and the desired build directory.
  ;; Exclude our clone of ASDF so the host uses their own potentially
  ;; customized version.
  (asdf:initialize-source-registry
    `(:source-registry (:also-exclude "asdf")
                       (:tree ,(uiop:getcwd))
                       :inherit-configuration))
  (asdf:load-system :koga)
  (apply #'uiop:symbol-call "KOGA"
                            (cond (help "HELP")
                                  ((getf initargs :archive) "ARCHIVE")
                                  (t "SETUP"))
                            initargs))