#!/usr/bin/guile \
-e "(scripts merge-module-catalogs)" -s
!#
;;; merge-module-catalogs --- Merge multiple module catalogs into one

;;	Copyright (C) 2003,2004 Free Software Foundation, Inc.
;;
;; 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 2, 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.
;;
;; As a special exception, the Free Software Foundation gives permission
;; for additional uses of the text contained in its release of GUILE.
;;
;; The exception is that, if you link the GUILE library with other files
;; to produce an executable, this does not by itself cause the
;; resulting executable to be covered by the GNU General Public License.
;; Your use of that executable is in no way restricted on account of
;; linking the GUILE library code into it.
;;
;; This exception does not however invalidate any other reasons why
;; the executable file might be covered by the GNU General Public License.
;;
;; This exception applies only to the code released by the
;; Free Software Foundation under the name GUILE.  If you copy
;; code from other Free Software Foundation releases into a copy of
;; GUILE, as the General Public License permits, the exception does
;; not apply to the code that you add in this way.  To avoid misleading
;; anyone as to the status of such modified files, you must delete
;; this exception notice from them.
;;
;; If you write modifications of your own for GUILE, it is your choice
;; whether to permit this exception to apply to your modifications.
;; If you do not wish that, delete this exception notice.

;;; Author: Thien-Thi Nguyen <ttn@gnu.org>

;;; Commentary:

;; Usage: merge-module-catalogs [OPTIONS] CATALOG...
;;
;; Write to stdout the result of merging CATALOG... module catalog files.
;; If there are module name collisions, report them and do not produce
;; a merged catalog.  Options include:
;;
;;  -o, --output FILE      -- write result to FILE instead of stdout
;;  -d, --deps FILE        -- write dependency makefile frag to FILE
;;  -c, --collision POLICY -- use POLICY for handling collisions:
;;                              first -- first seen overrides (no error)
;;                              last  -- last seen overrides (no error)
;;                              error -- signal error [default]
;;
;; Files are processed in the order given.  The --deps option is only
;; valid if --output is also given.

;;; Code:

(define-module (scripts merge-module-catalogs)
  #:autoload (scripts PROGRAM) (HVQC-MAIN)
  #:export (main))

(define (hash-cat ht file)
  (let ((bad '())
        (cat (read (open-input-file file))))
    (and=> (assq-ref cat '**catfmtv**)
           (lambda (catfmtv)
             (or (and (vector? catfmtv)
                      (let ((v (vector-ref catfmtv 0)))
                        (case v
                          ((1) #t)
                          (else #f))))
                 (error "bad catalog format:" file))))
    (for-each (lambda (ent)
                (cond ((list? (car ent))
                       (let ((name (car ent))
                             (info (cdr ent)))
                         (cond ((hash-get-handle ht name)
                                => (lambda (already)
                                     (set! bad (acons already info bad))))
                               (else
                                (hash-set! ht name info)))))))
              cat)
    (reverse bad)))

(define (merge ofile dfile policy files)
  (let ((ht (make-hash-table #:size 113))
        (collisions '())
        (file? (string? ofile)))
    (set! collisions (apply append (map (lambda (file)
                                          (hash-cat ht file))
                                        files)))
    (case policy
      ((first)
       (simple-format #t "Collisions detected (policy `first'): ~A\n"
                      (length collisions))
       (for-each (lambda (c)
                   (let ((name (caar c))
                         (prev (cdar c))
                         (last (cdr c)))
                     (simple-format #t "~A\n ~S\n ~S\n" name prev last)))
                 collisions)
       (set! collisions '()))
      ((last)
       (simple-format #t "Collisions detected (policy `last'): ~A\n"
                      (length collisions))
       (for-each (lambda (c)
                   (let ((name (caar c))
                         (prev (cdar c))
                         (last (cdr c)))
                     (simple-format #t "~A\n ~S\n ~S\n" name prev last)
                     (let ((handle (hash-get-handle ht name)))
                       (set-cdr! handle last))))
                 collisions)
       (set! collisions '()))
      ((error)
       #t)
      (else
       (error "unknown policy:" policy)))
    (cond ((null? collisions)
           (let ((p (if file?
                        (open-output-file ofile)
                        (current-output-port)))
                 (d (and file? dfile (open-output-file dfile))))
             (simple-format d "~A : \\\n" ofile)
             (and file? (simple-format p ";;; ~A\n" ofile))
             (simple-format p ";;; generated ~A UTC -- do not edit!\n\n"
                            (strftime "%Y-%m-%d %H:%M:%S" (gmtime (current-time))))
             (simple-format p "(\n")
             (simple-format file? "Writing ~A (~A entries)~A "
                            ofile (hash-fold (lambda (k v a)
                                               (let ((new (cons k v)))
                                                 (simple-format p " ~S\n" new)
                                                 (simple-format d " ~A \\\n"
                                                                (cdr (last-pair new))))
                                               (1+ a))
                                             0 ht)
                            (if d (simple-format #f ",\n  ~A (deps)\n " dfile) ""))
             (simple-format p ")\n")
             (and file? (simple-format p "\n;;; ~A ends here\n" ofile))
             (and file? (close-port p))
             (and d (begin (simple-format d " # elephant\n")) (close-port d))
             (simple-format file? "=> Done.\n")))
          (else
           (simple-format #t "Collisions detected:\n")
           (for-each (lambda (c) (simple-format #t " ~S\n" c)) collisions)
           (simple-format #t " => Not writing ~A\n" ofile)))))

(define (main args)
  (HVQC-MAIN args (lambda (qop)
                    (merge (qop 'output)
                           (qop 'deps)
                           (or (qop 'collision) 'error)
                           (qop '()))
                    #t)
             '(usage . commentary)
             '(package . "Guile")
             '(option-spec (output    (single-char #\o) (value #t))
                           (deps      (single-char #\d) (value #t))
                           (collision (single-char #\c) (value #t)))))

;;; merge-module-catalogs ends here
