#!/usr/bin/env guile
# -*- scheme -*-

!#

;; Copyright (C) 2023 Matthew Wette
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public License
;; along with this library; if not, see <http://www.gnu.org/licenses/>.


;;; Commentary:
;; Usage: compile-ffi [ARGS]
;; Type `compile-ffi --help' for help.

;;; Code:

(include "gread.scm") ;; or (use-modules (guix gexp)), to define #~ etc

(define (sf fmt . args) (apply simple-format #t fmt args))
(use-modules (ice-9 pretty-print))
(define pp pretty-print)

(use-modules (ice-9 ftw))
(use-modules (ice-9 match))
(use-modules ((srfi srfi-1) #:select (fold)))

(define (spec-path spec seed)
  (cons (if (pair? (car spec)) (car spec) spec) seed))

(define (parse-module-forms forms seed)
  (let loop ((il seed) (fl forms))
    (if (null? fl) il
        (match fl
          (`(#:use-module ,spec . ,rest)
           (loop (spec-path spec il) rest))
          (`(#:autoload ,mod ,syms . ,rest)
           (loop il rest))
          (`(,key ,val . ,rest) (loop il rest))))))

(define (read-module-file file seed)
  (unless (access? file R_OK)
    (error "not found: ~S" file))
  (call-with-input-file file
    (lambda (iport)
      (let ((env (make-fresh-user-module)))
        (let loop ((spec #f) (imps '()) (exp (read iport)))
          (if (eof-object? exp)
              (if spec (acons spec imps seed) seed)
              (match exp
                (`(define-module ,spec . ,forms)
                 (loop spec (parse-module-forms forms imps) (read iport)))
                (`(use-modules . ,forms)
                 (loop spec (fold spec-path imps forms) (read iport)))
                (any (loop spec imps (read iport))))))))))

(define* (check-tree node #:optional (cwd #f) (seed '()))
  (if (string? node)
      (read-module-file (string-append cwd "/" node) seed)
      (let ((nwd (if cwd (string-append cwd "/" (car node)) (car node))))
        (fold (lambda (nd sd) (check-tree nd nwd sd)) seed (cdr node)))))

(define* (ft->sft ftree #:optional (seed '()))
  (match ftree
    ((name stat)
     (if (string-suffix? ".scm" name) (cons name seed) seed))
    ((name stat children ...)
     (cons (cons name (fold ft->sft '() children)) seed))))

(define* (check-module spec dict #:optional (seed '()))
  (let loop ((cycl '()) (path '()) (seen '()) (curr (assoc-ref dict spec)))
    (if (null? curr)
        cycl
        (let ((dep (car curr)) (rest (cdr curr)))
          (cond
           ((equal? dep path) (loop (cons (cons dep path) cycl) path seen rest))
           ((member dep seen) (loop cycl path seen rest))
           (else
            (let ((cycl (loop cycl (cons dep path) (cons dep seen)
                              (or (assoc-ref dict dep) '())))
                  (seen (if (member dep seen) seen (cons dep seen))))
              (loop cycl path seen rest))))))))

(let* ((dir "guix/gnu/packages")
       (dir "nyacc/released/nyacc-1.08/module")
       (stree (cons dir (cdar (ft->sft (file-system-tree dir)))))
       (pdict (check-tree stree)))
  ;;(pp stree)
  (pp pdict)
  ;;(check-module '(gnu packages cross-base) pdict)
  #t)

;; --- last line ---