(use-modules (ice-9 match)
             (srfi srfi-1)
             (test-subject game))

(define (root-module)
  (resolve-module '() #f #f #:ensure #f))

(define (loaded-modules)
  (define (scan-submodules module)
    (hash-fold (lambda (k m memo)
                 (if (module-filename m)
                     (cons (module-filename m)
                           (append (scan-submodules m)
                                   memo))
                     (append (scan-submodules m) memo)))
               '()
               (module-submodules module)))
  (delete-duplicates (cons* "ice-9/eval.scm"
                            "ice-9/i18n.scm"
                            "ice-9/posix.scm"
                            "ice-9/psyntax-pp.scm"
                            "ice-9/quasisyntax.scm"
                            "ice-9/match.upstream.scm"
                            "ice-9/networking.scm"
                            "ice-9/r6rs-libraries.scm"
                            "ice-9/r7rs-libraries.scm"
                            (scan-submodules (root-module)))
                     string=?))

(define (in-load-path path file-name)
  (let loop ((path path))
    (match path
      (() #f)
      ((dir . rest)
       (let ((f (string-append dir "/" file-name)))
         (if (file-exists? f)
             f
             (loop rest)))))))

(define (scm->go file-name)
  (string-append (substring file-name 0 (- (string-length file-name) 4)) ".go"))

(define (shake-tree)
  (map (lambda (f)
         (list f
               (in-load-path %load-path f)
               (in-load-path %load-compiled-path
                             (scm->go f))))
       (sort (loaded-modules) string<)))

;; Snarfed from Guix
(define (mkdir-p dir)
  "Create directory DIR and all its ancestors."
  (define absolute?
    (string-prefix? "/" dir))

  (define not-slash
    (char-set-complement (char-set #\/)))

  (let loop ((components (string-tokenize dir not-slash))
             (root       (if absolute?
                             ""
                             ".")))
    (match components
      ((head tail ...)
       (let ((path (string-append root "/" head)))
         (catch 'system-error
           (lambda ()
             (mkdir path)
             (loop tail path))
           (lambda args
             (if (= EEXIST (system-error-errno args))
                 (loop tail path)
                 (apply throw args))))))
      (() #t))))

(define (install-modules spec prefix)
  (let ((v (string-append (major-version) ".0")))
    (for-each (match-lambda
                ((suffix source compiled)
                 (let ((scm-dest (string-append prefix "/share/guile/" v "/"
                                                suffix))
                       (go-dest (string-append prefix "/lib/guile/" v "/ccache/"
                                               (scm->go suffix))))
                   (mkdir-p (dirname scm-dest))
                   (mkdir-p (dirname go-dest))
                   (display (string-append "copy " source " to " scm-dest))
                   (newline)
                   (copy-file source scm-dest)
                   (when compiled
                     (display (string-append "copy " compiled " to " go-dest))
                     (newline)
                     (copy-file compiled go-dest)))))
              spec)))

(install-modules (shake-tree) "/home/dthompson/Code/bundle2/the-test-subject")