#!/bin/sh
exec ${GUILE-guile} -e "(cov scan)" -s $0 "$@" # -*-scheme-*-
!#
;;; scan --- Scan /usr/include/SDL/*.h and ../*/*.c for interface elements

;; Copyright (C) 2005, 2007-2009, 2013 Thien-Thi Nguyen
;;
;; This 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 software 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 <https://www.gnu.org/licenses/>.

;;; Commentary:

;; Usage: scan [-o OUTFILE] [--coverage API-FILE | --api HEADER ...]
;;
;; Write to OUTFILE text db tables of either the SDL API (if given
;; args `--api HEADER...') or the Guile-SDL coverage of the SDL API
;; (if given args `--coverage API-FILE').  Use stdout if `-o OUTFILE'
;; is omitted.
;;
;; The HEADER scanning selects symbols following the "DECLSPEC.*SDLCALL"
;; regular expression.  The API-FILE scanning selects files from a hardcoded
;; list that mention each interface element.
;;
;; TODO:
;; - Improve scan methods from "proof-of-concept" grade to "useful".

;;; Code:

(define-module (cov scan)
  #:export (main)
  #:use-module ((guile-baux common) #:select (check-hv qop<-args fs fso))
  #:use-module ((srfi srfi-1) #:select (append-map!
                                        filter!))
  #:use-module ((srfi srfi-11) #:select (let-values))
  #:use-module ((srfi srfi-13) #:select (string-suffix?))
  #:use-module ((ice-9 rdelim) #:select (read-delimited!))
  #:use-module ((ice-9 regex) #:select (fold-matches
                                        match:substring))
  #:autoload (guile-baux text-db-table) (read-text-db-table-records))

(define (interesting regexp sel)

  (define (string<-file filename)
    (let ((buf (make-string (stat:size (stat filename))))
          (port (open-input-file filename)))
      (let loop ((start 0))
        (and=> (read-delimited! "" buf port 'concat start)
               (lambda (count)
                 (loop (+ start count)))))
      (close-port port)
      buf))

  (define (accumulate-unique-symbols m acc)
    (let ((sym (string->symbol (match:substring m sel))))
      (if (memq sym acc)
          acc
          (cons sym acc))))

  (let ((rx (make-regexp regexp)))
    ;; rv
    (lambda (filename)
      (fold-matches rx (string<-file filename)
                    '() accumulate-unique-symbols))))

(define (write-tdt-head . field-names)
  (fso ";;; ~A -*-scheme-*-~%" (port-filename (current-output-port)))
  (fso "~A~%~A~%"
       "(text-db-table-config"
       "  (delim . \"\\n\")")
  (fso "  ~S)~%" (cons 'fields (map (lambda (name)
                                      (list name 'sexp))
                                    field-names))))

(define (write-api headers)

  (define declared (interesting "SDLCALL ([A-Z][A-Za-z0-9_]+)"
                                1))

  (define (scan-header filename)
    (map (lambda (name)
           (list name filename))
         (declared filename)))

  ;; output
  (write-tdt-head #:name #:source)
  (for-each (lambda (x)
              (apply fso "~S ~S~%" x))
            (append-map! scan-header headers)))

(define *implementation-root* (in-vicinity (dirname (car (command-line)))
                                           "../src"))

(define (implementation-files)

  (define (sane-readdir stream)
    (let ((x (readdir stream)))
      (and (not (eof-object? x))
           x)))

  (define (directory-files dir)
    (let ((stream (opendir dir)))
      (let loop ((acc '()))
        (cond ((sane-readdir stream)
               => (lambda (filename)
                    (loop (cons filename acc))))
              (else
               (closedir stream)
               acc)))))

  (let ((dir *implementation-root*))

    (define (bin filename)
      (or (member filename '("." ".."))
          (let ((full (in-vicinity dir filename)))
            (or
             ;; single dir since 2008-04, no recursion necessary
             (file-is-directory? full)
             ;; only C !
             (not (string-suffix? ".c" full))
             ;; foo.c generated from foo.fs
             (file-exists? (fs "~A.fs" (in-vicinity
                                        (dirname full)
                                        (basename full ".c"))))
             ;; ok
             full))))

    (filter! string? (map bin (directory-files dir)))))

(define (write-coverage api-filename)

  (define (api)
    (map (lambda (ent)
           (assq-ref ent #:name))
         (read-text-db-table-records api-filename)))

  (define (reality)
    (let ((cut (1+ (string-length *implementation-root*)))
          (filenames (implementation-files)))

      (define (presentable filename)
        (substring filename cut))

      (define mentioned (interesting "[A-Z][A-Za-z]+_[A-Za-z0-9_]+"
                                     0))

      (values (map presentable filenames)
              (map mentioned filenames))))

  (let-values (((filenames mentioned) (reality)))

    (define (search name)
      (delq! #f (map (lambda (filename mentioned)
                       (and (memq name mentioned)
                            filename))
                     filenames
                     mentioned)))

    ;; output
    (write-tdt-head #:name #:files)
    (for-each (lambda (name)
                (fso "~S ~S~%" name (search name)))
              (api))))

(define (scan/qop qop)
  (or (qop 'api) (qop 'coverage)
      (error "must specify one of: --api --coverage (try --help)"))
  (with-output-to-port (or (qop 'output open-output-file)
                           (current-output-port))
    (lambda ()
      (cond ((qop 'api) (write-api (qop '())))
            ((qop 'coverage write-coverage)))))
  #t)

(define (main args)
  (check-hv args '((package . "Guile-SDL")
                   (version . "0.1")
                   (help . commentary)))
  (exit
   (scan/qop
    (qop<-args
     args `((api)
            (coverage (value #t) (predicate ,file-exists?))
            (output (value #t) (single-char #\o)))))))

;;; scan ends here
