#!/bin/sh
exec ${GUILE-guile} -e '(ttn-do gxferm)' -s $0 "$@" # -*- scheme -*-
!#
;;; gxferm --- guile extensibility for easiest rule making

;; Copyright (C) 2007, 2009, 2010, 2011 Thien-Thi Nguyen
;;
;; This file is part of ttn-do, released 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.  There is NO WARRANTY.  See file COPYING for details.

;;; Commentary:

;; Usage: gxferm [--output FILENAME] CONFIG...
;;
;; Preprocess CONFIG... to create properly formatted ferm(1) input.
;; Write output to standard output (or FILENAME, if specified).
;;
;; CONFIG... names input files containing Scheme forms to be processed, in
;; order.  This table maps Scheme forms to "normal ferm input expressions":
;;
;;
;;  (define SYMBOL 'VALUE)                def $VAR = EXPR;
;;   ;; note quote ^
;;
;;
;;  ,SYMBOL                               $VAR
;;
;;
;;  (+ (A B C)                            A B C {
;;     (= D E F)                            D E F;
;;     (= G H I))                           G H I;
;;                                        }
;;
;;
;;  (define-macro (SIMPLE A1 A2)          def &SIMPLE (A1, A2) =
;;    (X Y ,A1 Z ,A2))                      X Y $A1 Z $A2;
;;
;;
;;  ,(SIMPLE P1 P2)                       &SIMPLE (P1, P2)
;;   ;; forms may follow, .e.g:
;;   ;; (= ,(SIMPLE (P1 P2)) DROP)
;;
;;
;;  (define-macro (BLOCK A1 A2)           def &BLOCK (A1, A2) = {
;;    (+ (J K)                              J K {
;;       (= W ,A1 X)                          W $A1 X;
;;       (= Y ,A2 Z)))                        Y $A3 Z;
;;                                          }
;;                                        }
;;
;;
;;  ,(BLOCK P1 P2)                        &BLOCK (P1, P2);
;;   ;; must conclude a chain, .e.g:
;;   ;; (+ () ,(BLOCK P1 P2))
;;
;;
;; Unrecognized forms produce a "WARNING: UNRECOGNIZED" to stderr.
;; A ‘+’ or ‘=’ form may be "commented out" by one or two single quotes.
;; One will produce a "WARNING: IGNORING" (to stderr); two, nothing.

;;; Code:

(define-module (ttn-do gxferm)
  #:export (main)
  #:use-module ((srfi srfi-13) #:select (string-map))
  #:use-module ((ttn-do zzz 0gx forms-from) #:select (forms<-file))
  #:use-module ((ttn-do zzz banalities) #:select (check-hv
                                                  qop<-args))
  #:use-module ((ttn-do zzz personally) #:select (accumulator
                                                  FE fs fse make-fso)))

(define (dash-to-underscore symbol)
  (define (down c)
    (case c
      ((#\-) #\_)
      (else c)))
  (string->symbol (string-map down (symbol->string symbol))))

(define (feed outfile inputs)
  (let ((output (accumulator)))

    (define (out! x)
      (output x))

    (define (quote? x)
      (and (pair? x)
           (= 2 (length x))
           (eq? 'quote (car x))))

    (define (remove-quote x)
      (if (quote? x)
          (cadr x)
          x))

    (define (func-xrep symbol)
      (symbol-append '& (dash-to-underscore symbol)))

    (define (var-xrep symbol)
      (symbol-append '$ (dash-to-underscore symbol)))

    (define (csep ls)
      (with-output-to-string
        (lambda ()
          (display "(")
          (display (car ls))
          (let loop ((ls (cdr ls)))
            (or (null? ls)
                (begin
                  (display ", ")
                  (display (car ls))
                  (loop (cdr ls)))))
          (display ")"))))

    (define (integrate form)
      (define (warn type)
        (fse "WARNING: ~A: ~S~%" type form))
      (case (car form)
        ((define-macro)
         (out! `(def ,(func-xrep (caadr form))
                     ,(csep (map var-xrep (cdadr form)))
                     =))
         (if (eq? '+ (caaddr form))
             (integrate (caddr form))
             (begin
               (out! (map remove-quote (caddr form)))
               (out! ";"))))
        ((define)
         (out! `(def ,(var-xrep (cadr form))
                     =
                     ,@(map remove-quote (cddr form))))
         (out! ";"))
        ((+)
         (out! (cadr form))
         (out! " {")
         (FE (cddr form) integrate)
         (out! "}"))
        ((=)
         (out! (cdr form))
         (out! ";"))
        ((unquote)
         (if (not (pair? (cadr form)))
             (warn "UNRECOGNIZED")
             (let ((name (caadr form))
                   (args (cdadr form)))
               (out! `(,(func-xrep name)
                       ,(csep args)))
               (out! ";"))))
        ((quote)
         (or (quote? (cadr form))       ; two quotes: silent
             (warn "IGNORING")))
        (else
         (warn "UNRECOGNIZED"))))

    (define (process filename)
      (FE (forms<-file filename)
          integrate))

    (define (spew port)
      (define (resolve x)
        (define (car-is? maybe)
          (eq? maybe (car x)))
        (cond ((not (pair? x)) x)
              ((car-is? 'unquote)
               (if (symbol? (cadr x))
                   (var-xrep (cadr x))
                   (let ((name (caadr x))
                         (args (cdadr x)))
                     (fs "~A ~A"
                         (func-xrep name)
                         (csep args)))))
              (else (map resolve x))))
        (FE (output)
            (let ((! (make-fso port)))
              (lambda (sexp)
                (cond ((string? sexp)
                       (! "~A~%" sexp))
                      (else
                       (FE sexp
                           (lambda (elem)
                             (! " ~A" (resolve elem))))))))))

    ;; do it!
    (FE inputs process)
    (let ((port (cond (outfile => open-output-file)
                      (else (current-output-port)))))
      (spew port)
      (close-port port))))

(define (main/qop qop)
  (feed (qop 'output)
        (qop '())))

(define (main args)
  (check-hv args '((package . "ttn-do")
                   (version . "2.0")
                   (help . commentary)))
  (main/qop
   (qop<-args
    args '((output (value #t) (single-char #\o))))))

;;; gxferm ends here