#!/bin/sh
exec ${GUILE-guile} -e '(guile-baux k2c)' -s $0 "$@" # -*-scheme -*-
!#
;;; k2c --- translate konstant (flocking or peerless) spec to C code

;; Copyright (C) 2003-2005, 2007, 2008, 2011, 2013 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 program.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;; Usage: k2c [OPTIONS] KSPEC
;;
;; Write C fragment to stdout derived from the constants scanned from
;; the header as specified in file KSPEC.  OPTIONS are zero or more of:
;;
;;  -o, --output FILE    -- write to FILE instead of stdout
;;  -I, --include DIR    -- look in DIR instead of /usr/include
;;
;; If output FILE is specified, as a side effect, k2c also writes
;; to FILE.list (thus producing two files) the form:
;;  ((NAME COUNT TYPE) SYMBOL ...)
;;
;; The KSPEC file contents are Scheme forms in the following format:
;; First is the symbol NICK, used to form C identifiers.  Next is the
;; string PRETTY, used in the external representation of the symbol
;; set object: "SDL PRETTY symbols".  The rest of the forms are
;; alternating keywords and values.  These configure how k2c scans
;; for entries.  Entries are extracted by regular expression matching
;; of lines (or a region) in a file.
;;
;; Currently, these keywords are recognized:
;;
;;  #:direct ALIST       -- don't scan; use ALIST directly
;;  #:infile RELPATH     -- which header to scan (string)
;;  #:region (BEG END)   -- only scan lines inside BEG-END regexps (strings)
;;  #:symrgx SYMRGX      -- symbolic regular expression with
;;                          first subexpression the key (see below)
;;  #:kxform SCHEME      -- how to transform the key
;;  #:v2mask FORMAT-STR  -- convert the value into a mask with FORMAT-STR
;;
;; If #:direct is specified, ALIST has the form:
;;  ((INTEGER . SYMBOL) ...)
;; and no other processing is done (aside from output, obviously).
;; Otherwise...
;;
;; Both #:infile and #:symrgx are required; #:region is optional.
;; SYMRGX is a list whose elements are strings, symbols and a single
;; sublist whose single string element is the one to match the key.
;; A string element expands to itself.  A symbol expands like so:
;;
;;  def     "#define"
;;  ws      "[ \t]+"
;;  ws?     "[ \t]*"
;;  x       "0x[[:xdigit:]]+"
;;  =       equivalent to (ws? "=" ws?)
;;
;; Any other symbol is converted to a string via `symbol->string'.
;; The resulting list is prefixed with "^" and then concatenated to
;; form the (string) regexp.  Because the form:
;;
;;   (def ws (STRING) ws x)
;;
;; is very common, SYMRGX recognizes (#t STRING) as equivalent.
;;
;; If #:kxform is unspecified, the key is used as-is.
;; Otherwise, it is a list of elements that specify how to
;; transform the key, one of:
;;
;;  downcase
;;  upcase
;;  hyphen
;;  N
;;  ("RX" REPLACEMENT[...])
;;
;; The first two transforms are self-explanatory.  The ‘hyphen’
;; transform converts ‘_’ (underscore) to ‘-’ (hyphen).  The
;; N (an integer) transform discards N chars from the beginning
;; if N is positive, -N chars from the end if N is negative.
;; The last transform essentially does ‘s/RX/REPLACEMENT/g’
;; with REPLACEMENT one or more strings (used literally) and
;; integers (indicating a submatch; 0 means the entire match).
;;
;; If #:v2mask is unspecified, the value is used as-is.
;; Otherwise, it is a string with a single "~A" that specifies
;; how the value is to be made into a "mask", usually by applying
;; a C macro or some expression that involves the C ‘<<’ operator.
;; For example: "(1 << (~A))" is the classic bit pos to mask op.

;;; Code:

(define-module (guile-baux k2c)
  #:export (main)
  #:use-module ((guile-baux common) #:select (fs fse die check-hv qop<-args))
  #:use-module ((guile-baux forms-from) #:select (forms<-file
                                                  forms<-port))
  #:use-module ((guile-baux temporary-file) #:select (unique-i/o-file-port))
  #:use-module ((guile-baux pascal-pool) #:select (pascal-pool))
  #:use-module ((srfi srfi-13) #:select (string-join
                                         string-take-right
                                         string-drop-right
                                         string-concatenate))
  #:autoload (ice-9 pretty-print) (pretty-print)
  #:use-module ((ice-9 rdelim) #:select (read-line))
  #:use-module ((ice-9 regex) #:select (match:substring
                                        regexp-substitute/global))
  #:use-module ((ice-9 popen) #:select (open-output-pipe
                                        open-input-pipe
                                        close-pipe)))

(define (rx<-symbolic symbolic-regexp)

  (define (flatten ls)
    (string-concatenate (map defrag ls)))

  (define (defrag x)
    (cond ((symbol? x) (case x
                         ((def) "#define")
                         ((ws) "[ \t]+")
                         ((ws?) "[ \t]*")
                         ((x) "0x[[:xdigit:]]+")
                         ((=) (flatten '(ws? "=" ws?)))
                         (else (symbol->string x))))
          ((pair? x) (fs "(~A)" (car x)))
          ((string? x) x)
          (else (error "bad symbolic-regexp fragment:" x))))

  (flatten (cons "^" (if (eq? #t (car symbolic-regexp))
                         `(def ws ,(cdr symbolic-regexp) ws x)
                         symbolic-regexp))))

(define (scan-file filename symrgx region)
  (let* ((rv '())
         (p (open-input-file filename))
         (rx (make-regexp (rx<-symbolic symrgx)))
         (beg-rx (and region (make-regexp (car region))))
         (end-rx (and region (make-regexp (cadr region))))
         (in? #f))
    (let loop ((line (read-line p)))
      (or (eof-object? line)
          (number? in?)
          (begin
            (cond ((and end-rx in? (regexp-exec end-rx line))
                   (set! in? 0))
                  ((and beg-rx (not in?) (regexp-exec beg-rx line))
                   (set! in? #t))
                  ((and (or (and beg-rx in?)
                            (not beg-rx))
                        (regexp-exec rx line))
                   => (lambda (m)
                        (set! rv (cons (string->symbol
                                        (match:substring m 1))
                                       rv)))))
            (loop (read-line p)))))
    (close-port p)
    (reverse! rv)))

(define (C-program type header found qspec)

  (define pretty
    (cond
     ((qspec #:kxform)
      => (lambda (xelems)

           (define (change! old . new)
             (lambda (s)
               (apply regexp-substitute/global #f old s
                      `(pre ,@new post))))

           (define (xform x)
             (cond ((integer? x)
                    (if (positive? x)
                        (lambda (s)
                          (substring s x))
                        (lambda (s)
                          (string-drop-right s (- x)))))
                   ((pair? x)
                    (apply change! x))
                   (else
                    (case x
                      ((downcase) string-downcase)
                      ((upcase) string-upcase)
                      ((hyphen) (xform '("_" "-")))
                      (else (fse "WARNING: unrecognized ~S element: ~S"
                                 #:kxform x)
                            identity)))))

           (let ((changes (map xform xelems)))
             (lambda (symbol)
               (let ((s (symbol->string symbol)))
                 (for-each (lambda (x!)
                             (set! s (x! s)))
                           changes)
                 (string->symbol s))))))
     (else
      identity)))

  (define actual
    (cond ((qspec #:v2mask)
           => (lambda (fmt)
                (lambda (s)
                  (fs fmt s))))
          (else
           identity)))

  (define (line s)
    (fs "printf (\"(~A\t. \\\"~A\\\")\\n\", ~A);"
        (case type
          ((flocking) "#x%08lx")
          ((peerless) "%ld"))
        (pretty s)
        (actual s)))

  (string-join
   `("#include <stdio.h>"
     ,(fs "#include <~A>" header)
     "int main (void)"
     "{"
     ,@(map line found)
     "return 0;"
     "}")
   "\n" 'suffix))

(define (typical-sort type ls)
  (let ((more (case type
                ((flocking) >)
                ((peerless) <))))
    (sort ls (lambda (a b)
               (more (car a) (car b))))))

(define (sorted type who header found qspec)
  (let* ((p (unique-i/o-file-port (fs "./~A.vals-" (basename who))))
         (exe (port-filename p))
         (rv #f))
    (close-port p)
    (let ((p (open-output-pipe (fs "gcc -o ~A -x c -pipe -" exe))))
      (display (C-program type header found qspec) p)
      (close-pipe p))
    (let ((p (open-input-pipe exe)))
      (set! rv (typical-sort type (forms<-port p)))
      (close-pipe p))
    (delete-file exe)
    rv))

(define (comprehend ls)
  (let ((classic (iota (length ls))))
    (cond ((equal? ls classic)
           'classic)
          ((equal? ls (map (let ((first (car ls)))
                             (lambda (n)
                               (+ first n)))
                           classic))
           'offset)
          (else
           #f))))

(define (generate nick pretty type linear)

  (define (spew s)
    (display s)
    (force-output))

  (define (join how . ls)
    (let ((sep (if (pair? how) (car how) how))
          (grammar (if (pair? how) (cdr how) 'infix)))
      (string-join ls sep grammar)))

  (let* ((numbers (map car linear))
         (comp (case type
                 ((flocking) #f)
                 ((peerless) (comprehend numbers))))
         (len (length linear)))

    (or (eq? 'classic comp)
        (spew (fs "static ~Along ~A_values[] = {~%  ~A~%};~%~%"
                  (case type
                    ((flocking) "unsigned ")
                    ((peerless) ""))
                  nick
                  (string-join
                   (map (lambda (n)
                          (case type
                            ((flocking) (fs "0x~A" (number->string n 16)))
                            ((peerless) (fs "~A" n))))
                        (case comp
                          ((offset) (list (car numbers)))
                          (else numbers)))
                   ",\n  "))))
    (spew (pascal-pool (map cdr linear)
                       'uint8_t (fs "~A_names" nick)
                       'essential
                       'numeric))
    (spew "\n")
    (spew (join '("\n" . suffix)
                (fs "static ~A = {"
                    (fs (case type
                          ((flocking) "flagstash_t ~A_flagstash")
                          ((peerless) "kp_t ~A_kp"))
                        nick))
                (let ((elems
                       (list (fs "  .ss = { ~A }"
                                 (join ", "
                                       (fs ".count = ~A" len)
                                       (fs ".pool = ~A_names" nick)
                                       (fs ".name = ~S" pretty)))
                             (fs ".val = ~A"
                                 (case comp
                                   ((classic) 'NULL)
                                   (else (fs "~A_values" nick)))))))

                  (define (boolean sym)
                    (fs ".~A = ~A" sym (if (eq? comp sym)
                                           'true
                                           'false)))

                  (case type
                    ((peerless)
                     (append! elems (list (boolean 'classic)
                                          (boolean 'offset)))))

                  (apply join ",\n  " elems))
                "};"))))

(define (k2c/qop qop)
  (let* ((specfile (if (null? (qop '()))
                       (die #f "missing input file")
                       (car (qop '()))))
         (type (case (string->symbol (string-take-right specfile 3))
                 ((.kf) 'flocking)
                 ((.kp) 'peerless)
                 (else (die #f "unrecognized extension: ~A" specfile))))
         (partial (forms<-file specfile)))

    (define qspec
      (let ((plist (cddr partial)))
        ;; qspec
        (lambda (kw)
          (and=> (memq kw plist) cadr))))

    (define (directly raw)
      (typical-sort type (map cons
                              (map car raw)
                              (map symbol->string
                                   (map cdr raw)))))

    (define (from-file header)
      (sorted type specfile header
              (scan-file header
                         (qspec #:symrgx)
                         (qspec #:region))
              qspec))

    (let ((linear (cond ((qspec #:direct)
                         => directly)
                        (else
                         (from-file (in-vicinity (or (qop 'include)
                                                     "/usr/include")
                                                 (qspec #:infile)))))))

      (define (btw!)
        (let ((head (list (string->symbol (cadr partial))
                          (length linear)
                          (case type
                            ((peerless) 'enums)
                            ((flocking) 'flags))))
              (tail (map (lambda (pair)
                           (string->symbol (cdr pair)))
                         (sort linear (lambda (a b)
                                        ;; nb: ‘type’ independent
                                        (< (car a)
                                           (car b)))))))
          (pretty-print (cons head tail))))

      (define (gen!)
        (generate (car partial) (cadr partial)
                  type linear))

      (or (qop 'output (lambda (filename)
                         (with-output-to-file
                             (fs "~A.list" filename)
                           btw!)
                         (with-output-to-file filename gen!)))
          (gen!)))))

(define (main args)
  (check-hv args '((package . "Guile-SDL")
                   (version . "2.0")
                   ;; 2.0 -- rename from fs2c
                   ;;        handle both peerless and flocking
                   ;;        add #:direct support
                   ;;        generate .list if writing to file
                   ;; 1.0 -- initial release
                   ;; Note: This is based on fspec2c 1.2 from
                   ;; Guile 1.4.x, but significantly stripped
                   ;; down and specialized for Guile-SDL.
                   (help . commentary)))
  (k2c/qop
   (qop<-args args '((output  (single-char #\o) (value #t))
                     (include (single-char #\I) (value #t))))))

;;; k2c ends here
