#!/bin/sh
exec ${GUILE-guile} -e '(ttn-do generate-C-symbol-set)' -s $0 "$@" # -*-scheme-*-
!#
;;; generate-C-symbol-set

;; Copyright (C) 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: generate-C-symbol-set [options] SYMBOL...
;;
;; Options are:
;; -p, --pool-name NAME      -- use NAME instead of ‘symbolpool’
;; -b, --byte-type TYPE      -- use TYPE instead of ‘uint8_t’
;; -g, --global              -- omit "static"
;; -z, --zero                -- produce NUL-terminated entries
;;
;; Write to stdout a C data structure representing a symbol pool
;; with symbols SYMBOL...  For example:
;;
;;   $ generate-C-symbol-set \
;;     Author Date Id
;;   static const uint8_t symbolpool[16] =
;;   {
;;     3 /* count */,
;;     6,'A','u','t','h','o','r',
;;     4,'D','a','t','e',
;;     2,'I','d'
;;   };
;;
;; A more complicated example, using all the switches:
;;
;;   $ generate-C-symbol-set -b BYTE -p keywords -g -z \
;;     Author Date Id
;;   const BYTE keywords[19] =
;;   {
;;     3 /* count */,
;;     6,'A','u','t','h','o','r','\0',
;;     4,'D','a','t','e','\0',
;;     2,'I','d','\0'
;;   };
;;
;; Note that with ‘--zero’, the pool (sub)strings are C-compatible.

;;; Code:

(define-module (ttn-do generate-C-symbol-set)
  #:export (generate-C-symbol-set
            main)
  #:use-module ((ttn-do zzz banalities) #:select (check-hv
                                                  qop<-args))
  #:use-module ((ttn-do zzz personally) #:select (accumulator
                                                  FE))
  #:use-module ((ttn-do zzz publishing) #:select (flatten-to :LF)))

(define :EQUAL " = ")

;; Return a string tree representing the C code for the symbol set
;; @var{ls} (a list of strings), customized by @code{configuration}
;; (an alist).  Recognized @code{configuration} keys (symbols) are:
;; @code{zero}, @code{global}, @code{byte-type} and @code{pool-name}.
;; Values are boolean for @code{zero} and @code{global}, and string
;; for the others.
;;
;; You can use @code{flatten} (@pxref{zzz publishing}), to render
;; this tree.  (This is what the shell command does.)
;;
(define (generate-C-symbol-set configuration ls)
  (define (cfg x)
    (assq-ref configuration x))
  (let ((acc (accumulator))
        (count 0))
    (define (acc! x)
      (set! count (1+ count))
      (acc x))
    (FE ls (lambda (name)
             (let* ((exploded (string->list name))
                    (len (length exploded)))
               (or (< 0 len 256)
                   (error "uncool symbol:" name))
               (acc! len)
               (FE exploded acc!)
               (and (cfg 'zero) (acc! #\nul)))))
    (list
     (if (cfg 'global) "" "static ")
     "const " (cfg 'byte-type) " " (cfg 'pool-name)
     "[" (number->string (1+ count)) "]" :EQUAL :LF
     "{" :LF
     "  " (number->string (length ls)) " /* count */"
     (map (lambda (x)
            (list ","
                  (cond ((number? x)
                         (list :LF "  " (number->string x)))
                        ((char=? #\nul x)
                         "'\\0'")
                        ((or (char-numeric? x)
                             (char-alphabetic? x)
                             (eq? #\- x))
                         (simple-format #f "'~A'" x))
                        (else
                         (number->string (char->integer x))))))
          (acc))
     :LF
     "};"
     :LF)))

(define (main/qop qop)
  (flatten-to (current-output-port)
              (generate-C-symbol-set
               `((pool-name . ,(or (qop 'pool-name) "symbolpool"))
                 (byte-type . ,(or (qop 'byte-type) "uint8_t"))
                 (global    . ,(qop 'global))
                 (zero      . ,(qop 'zero)))
               (qop '()))))

(define (main args)
  (check-hv args '((package . "ttn-do")
                   ;; 1.0 -- initial release
                   (version . "1.1")
                   (help . commentary)))
  (main/qop
   (qop<-args
    args '((pool-name (single-char #\p) (value #t))
           (byte-type (single-char #\b) (value #t))
           (global (single-char #\g))
           (zero (single-char #\z))))))

;;; generate-C-symbol-set ends here