#!/bin/sh
exec ${GUILE-guile} --debug -e '(guile-baux pie)' -s $0 "$@" # -*- scheme -*-
!#
(debug-enable 'backtrace 'backwards 'frameloc)
;;; pie --- Manipulate pre-inst environment

;; Copyright (C) 2011 Thien-Thi Nguyen
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 3, or
;; (at your option) any later version.
;;
;; This program 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
;; General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this software; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Commentary:

;; Usage: pie [options] stem
;;
;; Create STEM.mmi from STEM.exports and STEM.la.
;;
;; Options:
;;  -v, --verbose     -- display progress to stderr

;;; Code:

(define-module (guile-baux pie)
  #:export (main)
  #:use-module
  ((guile-baux common) #:select (fs fso fse die check-hv qop<-args))
  #:use-module
  ((guile-baux forms-from) #:select (forms<-file))
  #:use-module
  ((guile-baux alist-from-plist) #:select (alist<-plist))
  #:use-module
  ((srfi srfi-13) #:select (string-prefix?
                            string-tokenize
                            string-join))
  #:use-module
  ((srfi srfi-14) #:select (char-set:graphic))
  #:use-module
  ((ice-9 rdelim) #:select (read-line)))

(define verbose? #f)

(define (bail s . args)
  (apply die #f (string-append "pie: " s) args))

(define (read-mmi filename)
  (let ((raw (forms<-file filename)))
    (or (and (pair? raw) (eq? 'module-meta-info (car raw)))
        (bail "~A: bad module-meta-info" filename))
    (alist<-plist (cdr raw))))

(define (mash module-name)
  (let loop ((acc '()) (ls (map symbol->string module-name)))
    (if (null? ls)
        (reverse! acc)
        (let ((s (car ls)))
          (cond ((string-index s #\-)
                 => (lambda (pos)
                      (loop (cons (substring s 0 pos) acc)
                            (cons (substring s (1+ pos)) (cdr ls)))))
                (else
                 (loop (cons s acc) (cdr ls))))))))

(define (expand one)
  (define (x key)
    (assq-ref one key))
  (let ((on-disk (x #:on-disk))
        (name (x #:name))
        (method (x #:load-method)))
    (define (bad-method!)
      (bail "bad load-method: ~S" method))
    (cond ((symbol? method)
           (case method
             ((load) (cons name on-disk))
             (else (bad-method!))))
          ((pair? method)
           (case (car method)
             ((scm_init_module)
              (cons* name (car method)
                     (cond ((cadr method) => symbol->string)
                           (else (string-join `("scm_init"
                                                ,@(mash name)
                                                "module")
                                              "_")))
                     (map car (or (x #:imports) '()))
                     (in-vicinity (dirname on-disk)
                                  (fs ".libs/~A" (caddr method)))))
             (else (bad-method!))))
          (else (bad-method!)))))

(define (compose-module-catalog ls)
  (let ((const '((**catfmtv** . #(1))
                 (**exclude**)))
        (forms (map expand (map read-mmi ls)))
        (p (open-output-file ".module-catalog")))
    (display "(" p)
    (newline p)
    (for-each (lambda (x)
                (write x p)
                (newline p))
              (append const forms))
    (display ")" p)
    (newline p)
    (close-port p)))

(define (main/qop qop)
  (compose-module-catalog (qop '()))
  (with-output-to-file (qop 'touch)
    (lambda ()
      (let ((now (current-time)))
        (fso "~A (~A)~%"
             now (strftime "%Y-%m-%d %T %z" (localtime now)))))))

(define (main args)
  (check-hv args '((package . "Guile-BAUX")
                   (version . "0.0")
                   (help . commentary)))
  (main/qop
   (qop<-args args '((verbose (single-char #\v))
                     (touch (single-char #\t) (value #t) (required? #t)))))
  #t)

;;; pie ends here
