;;;
;;; extract - filter bilingual texinfo document
;;;
;;;  Copyright(C) 2001-2003 by Shiro Kawai (shiro@acm.org)
;;;
;;;  Permission to use, copy, modify, distribute this software and
;;;  accompanying documentation for any purpose is hereby granted,
;;;  provided that existing copyright notices are retained in all
;;;  copies and that this notice is included verbatim in all
;;;  distributions.
;;;  This software is provided as is, without express or implied
;;;  warranty.  In no circumstances the author(s) shall be liable
;;;  for any damages arising out of the use of this software.
;;;
;;;  $Id: extract,v 1.5 2006/11/09 23:56:20 shirok Exp $
;;;

(use gauche.parseopt)
(use gauche.charconv)
(use srfi-1)
(use srfi-13)
(use file.util)

(define *outfile* #f)
(define *lang* 'en)
(define *version*
  (string-trim-both (file->string (or (find (cut sys-access <> R_OK)
                                            '("../VERSION"
                                              "./VERSION"))
                                      (error "No VERSION file?")))))
(define *node-table* '())
(define *header-table* '())

(define (scan-nodes)
  (let ((current-node #f)
        (current-header #f))
    (port-for-each
     (lambda (line)
       (rxmatch-case line
         (#/^@node\s+([^,]+)/ (#f node)
          (set! current-node (string-trim-right node)))
         (#/^@(chapter|(sub)*section|appendix\w*)\s+(.*)/ (#f #f #f header)
          (set! current-header (string-trim-right header)))
         (#/^@c NODE\s+([^,]*)(,(.*))?/ (#f jnode #f jheader)
          (let* ((jn (string-trim-right jnode))
                 (jh (if jheader (string-trim-both jheader) jn)))
            (push! *node-table* (cons current-node jn))
            (push! *header-table* (cons current-header jh))))
         (#/^@include\s+(\S+)/ (#f file)
           (with-input-from-file file (cut scan-nodes) :encoding 'euc-jp))
         ))
     read-line)))

(define (filter pattern-in pattern-out)
  (define (in line)
    (rxmatch-case line
      (test eof-object?)
      (pattern-in () (in (read-line)))
      (pattern-out () (out (read-line)))
      (#/^@include\s+(\S+)/ (#f file)
        (with-input-from-file file (cut filter pattern-in pattern-out)
                              :encoding 'euc-jp)
        (in (read-line)))
      (#/^@c COMMON$/ () (in (read-line)))
      (test (lambda _ (eq? *lang* 'en))
            (display (regexp-replace-all #/@VERSION@/ line *version*))
            (newline) (in (read-line)))
      (#/^@node\s+(.*)$/ (#f nodedesc)
        (process-node nodedesc) (in (read-line)))
      (#/^@(chapter|(sub)*section|appendix\w*)\s+(.*)/ (#f cmd #f header)
        (process-header cmd header) (in (read-line)))
      (#/^\* ([^:]+)::(.*)?/ (#f node desc)
        (process-menu node #f desc) (in (read-line)))
      (#/^\* ([^:]+):\s+([^)]+\))\.(.*)?/ (#f tag node desc)
        (process-menu node tag desc) (in (read-line)))
      (else (display
             (regexp-replace-all #/@VERSION@/
              (regexp-replace-all #/(@x?ref)\{([^\}]+)\}/ line process-ref)
              *version*))
            (newline)
            (in (read-line)))))

  (define (out line)
    (rxmatch-case line
      (test eof-object?)
      (pattern-in ()  (in (read-line)))
      (#/^@c COMMON$/ () (in (read-line)))
      (else (out (read-line)))))

  (in (read-line)))

(define (process-node nodedesc)
  (display "@node ")
  (display
   (string-join
    (map (lambda (name)
           (cond ((assoc (string-trim-both name) *node-table*) => cdr)
                 (else name)))
         (string-split nodedesc #\,))
    ", "))
  (newline))

(define (process-header cmd header)
  (format #t "@~a ~a\n"
          cmd
          (cond ((assoc (string-trim-both header) *header-table*) => cdr)
                (else header))))

(define (process-menu node tag desc)
  (if tag
    (format #t "* ~a: ~a.  ~a\n"
            tag
            (cond ((assoc (string-trim-both node) *node-table*) => cdr)
                  (else node))
            (string-trim-both (or desc "")))
    (format #t "* ~a::  ~a\n"
            (cond ((assoc (string-trim-both node) *node-table*) => cdr)
                  (else node))
            (string-trim-both (or desc "")))))

(define (process-ref match)
  (let ((cmd  (rxmatch-substring match 1))
        (node (rxmatch-substring match 2)))
    (format #f "~a{~a}"
            cmd
            (cond ((assoc (string-trim-both node) *node-table*) => cdr)
                  (else node)))))

(define (usage)
  (display "Usage: extract [-en|-jp][-o outfile] infile\n")
  (exit 1))

(define (main args)
  (let ((a (parse-options (cdr args)
             (("o=s" (outfile) (set! *outfile* outfile))
              ("en"  () (set! *lang* 'en))
              ("jp"  () (set! *lang* 'jp))
              (else _ (usage))))))

    (define (do-it)
      (case *lang*
        ((en) (filter #/^@c EN$/ #/^@c JP$/))
        ((jp) (filter #/^@c JP$/ #/^@c EN$/))))

    (define outenc (if (eq? *lang* 'jp) 'euc-jp 'utf8))
    
    (unless (= (length a) 1) (usage))

    (when (eq? *lang* 'jp)
      (with-input-from-file (car a) scan-nodes :encoding 'euc-jp))
    
    (with-input-from-file (car a)
      (lambda ()
        (if *outfile*
          (with-output-to-file *outfile* do-it :encoding outenc)
          (let1 out (open-output-conversion-port
                     (current-output-port) outenc)
            (with-output-to-port out do-it)
            (close-output-port out))))
      :encoding 'euc-jp)
    0))

;; Local variables:
;; mode: Scheme
;; end:
