;; -*- geiser-scheme-implementation: guile -*-

;;; Implementation: Danny Milosavljevic <address@hidden>
;;; Based on: Implementation in Python by Vicent Marti.
;;; License: ISC, like the original generate.py in clar.

(use-modules (ice-9 ftw))
(use-modules (ice-9 regex))
(use-modules (ice-9 getopt-long))
(use-modules (ice-9 rdelim))
(use-modules (ice-9 match))
(use-modules (ice-9 textual-ports))
(use-modules (srfi srfi-1))

(define (render-callback cb)
  (if cb
      (string-append "    { \"" (assoc-ref cb "short-name") "\", &"
                     (assoc-ref cb "symbol") " }")
      "    { NULL, NULL }"))

(define (replace needle replacement haystack)
  "Replace all occurences of NEEDLE in HAYSTACK by REPLACEMENT.
NEEDLE is a regular expression."
  (regexp-substitute/global #f needle haystack 'pre replacement 'post))

(define (skip-comments* text)
  (call-with-input-string
   text
   (lambda (port)
     (let loop ((result '())
                (section #f))
       (define (consume-char)
         (cons (read-char port) result))
       (define (skip-char)
         (read-char port)
         result)
       (match section
        (#f
         (match (peek-char port)
          (#\/ (loop (consume-char) 'almost-in-block-comment))
          (#\" (loop (consume-char) 'in-string-literal))
          (#\' (loop (consume-char) 'in-character-literal))
          ((? eof-object?) result)
          (_ (loop (consume-char) section))))
        ('almost-in-block-comment
         (match (peek-char port)
          (#\* (loop (consume-char) 'in-block-comment))
          (#\/ (loop (consume-char) 'in-line-comment))
          ((? eof-object?) result)
          (_ (loop (consume-char) #f))))
        ('in-line-comment
         (match (peek-char port)
          (#\newline (loop (consume-char) #f))
          ((? eof-object?) result)
          (_ (loop (skip-char) section))))
        ('in-block-comment
         (match (peek-char port)
           (#\* (loop (skip-char) 'almost-out-of-block-comment))
           ((? eof-object?) result)
           (_ (loop (skip-char) section))))
        ('almost-out-of-block-comment
         (match (peek-char port)
           (#\/ (loop (cons (read-char port) (cons #\* result)) #f))
           (#\* (loop (skip-char) 'almost-out-of-block-comment))
           ((? eof-object?) result)
           (_ (loop (skip-char) 'in-block-comment))))
        ('in-string-literal
         (match (peek-char port)
           (#\\ (loop (consume-char) 'in-string-literal-escape))
           (#\" (loop (consume-char) #f))
           ((? eof-object?) result)
           (_ (loop (consume-char) section))))
        ('in-string-literal-escape
         (match (peek-char port)
           ((? eof-object?) result)
           (_ (loop (consume-char) 'in-string-literal))))
        ('in-character-literal
         (match (peek-char port)
           (#\\ (loop (consume-char) 'in-character-literal-escape))
           (#\' (loop (consume-char) #f))
           ((? eof-object?) result)
           (_ (loop (consume-char) section))))
        ('in-character-literal-escape
         (match (peek-char port)
           ((? eof-object?) result)
           (_ (loop (consume-char) 'in-character-literal)))))))))

(define (skip-comments text)
  (list->string (reverse (skip-comments* text))))

(define (maybe-only items)
  (match items
   ((a) a)
   (_ #f)))

(define (Module name path excludes)
  (let* ((clean-name (replace "_" "::" name))
         (enabled (not (any (lambda (exclude)
                              (string-prefix? exclude clean-name))
                            excludes))))
    (define (parse contents)
      (define (cons-match match prev)
        (cons
         `(("declaration" . ,(match:substring match 1))
           ("symbol" . ,(match:substring match 2))
           ("short-name" . ,(match:substring match 3)))
         prev))
      (let* ((contents (skip-comments contents))
             (entries (fold-matches (make-regexp
                                     (string-append "^(void\\s+(test_"
                                                    name
                                                    "__(\\w+))\\s*\\(\\s*void\\s*\\))\\s*\\{")
                                     regexp/newline)
                                    contents
                                    '()
                                    cons-match))
             (callbacks (filter (lambda (entry)
                                   (match (assoc-ref entry "short-name")
                                    ("initialize" #f)
                                    ("cleanup" #f)
                                    (_ #t)))
                                entries)))
        (if (> (length callbacks) 0)
            `(("name" . ,name)
              ("enabled" . ,(if enabled "1" "0"))
              ("clean-name" . ,clean-name)
              ("initialize" . ,(maybe-only (filter-map (lambda (entry)
                                                      (match (assoc-ref entry "short-name")
                                                       ("initialize" entry)
                                                       (_ #f)))
                                                     entries)))
              ("cleanup" . ,(maybe-only (filter-map (lambda (entry)
                                                   (match (assoc-ref entry "short-name")
                                                    ("cleanup" entry)
                                                    (_ #f)))
                                                  entries)))
              ("callbacks" . ,callbacks))
            #f)))

    (define (refresh path)
      (and (file-exists? path)
           (parse (call-with-input-file path get-string-all))))
    (refresh path)))

(define (generate-TestSuite path output excludes)
    (define (load)
        (define enter? (const #t))
        (define (leaf file stat result)
          (let* ((module-root (string-drop (dirname file)
                                           (string-length path)))
                 (module-root (filter-map (match-lambda
                                           ("" #f)
                                           (a a))
                                          (string-split module-root #\/))))
            (define (make-module path)
              (let* ((name (string-join (append module-root (list (string-drop-right (basename path) (string-length ".c")))) "_"))
                     (name (replace "-" "_" name)))
                (Module name path excludes)))
            (if (string-suffix? ".c" file)
                (let ((module (make-module file)))
                  (if module
                      (cons module result)
                      result))
                result)))
        (define (down dir stat result)
          result)
        (define (up file state result)
          result)
        (define skip (const #f))
        (define error (const #f)) ; FIXME
        (file-system-fold enter? leaf down up skip error '() path))

    (define (CallbacksTemplate module)
      (string-append "static const struct clar_func _clar_cb_"
                     (assoc-ref module "name") "[] = {\n"
                     (string-join (map render-callback
                                       (assoc-ref module "callbacks"))
                                  ",\n")
                     "\n};\n"))

    (define (DeclarationTemplate module)
      (string-append (string-join (map (lambda (cb)
                                         (string-append "extern "
                                                        (assoc-ref cb "declaration")
                                                        ";"))
                                       (assoc-ref module "callbacks"))
                                  "\n")
                     "\n"
                     (if (assoc-ref module "initialize")
                         (string-append "extern " (assoc-ref (assoc-ref module "initialize") "declaration") ";\n")
                         "")
                     (if (assoc-ref module "cleanup")
                         (string-append "extern " (assoc-ref (assoc-ref module "cleanup") "declaration") ";\n")
                         "")))

    (define (InfoTemplate module)
      (string-append "
    {
        \"" (assoc-ref module "clean-name") "\",
    " (render-callback (assoc-ref module "initialize")) ",
    " (render-callback (assoc-ref module "cleanup")) ",
        _clar_cb_" (assoc-ref module "name") ", "
        (number->string (length (assoc-ref module "callbacks")))
        ", " (assoc-ref module "enabled") "
    }"))

    (define (Write data)
      (define (name< module-a module-b)
        (string<? (assoc-ref module-a "name")
                  (assoc-ref module-b "name")))
      (define modules (sort (load) name<))

      (define (suite-count)
        (length modules))

      (define (callback-count)
        (fold + 0 (map (lambda (entry)
                         (length (assoc-ref entry "callbacks")))
                         modules)))

      (define (display-x value)
        (display value data))

      (for-each (compose display-x DeclarationTemplate) modules)
      (for-each (compose display-x CallbacksTemplate) modules)

      (display-x "static struct clar_suite _clar_suites[] = {")
      (display-x (string-join (map InfoTemplate modules) ","))
      (display-x "\n};\n")

      (let ((suite-count-str (number->string (suite-count)))
            (callback-count-str (number->string (callback-count))))
        (display-x "static const size_t _clar_suite_count = ")
        (display-x suite-count-str)
        (display-x ";\n")

        (display-x "static const size_t _clar_callback_count = ")
        (display-x callback-count-str)
        (display-x ";\n")

        (display (string-append "Written `clar.suite` ("
                                callback-count-str
                                " tests in "
                                suite-count-str
                                " suites)"))
        (newline))
      #t)

    (call-with-output-file (string-append output "/clar.suite") Write))

;;; main

(define (main)
  (define option-spec
    '((force (single-char #\f) (value #f))
      (exclude (single-char #\x) (value #t))
      (output (single-char #\o) (value #t))
      (help  (single-char #\h) (value #f))))

  (define options (getopt-long (command-line) option-spec #:stop-at-first-non-option #t))
  (define args (reverse (option-ref options '() '())))
  (when (> (length args) 1)
    (display "More than one path given\n")
    (exit 1))

  (if (< (length args) 1)
      (set! args '(".")))

  (let* ((path (car args))
         (output (option-ref options 'output path))
         (excluded (filter-map (match-lambda
                                (('exclude . value) value)
                                (_ #f))
                               options)))
    (generate-TestSuite path output excluded)))

(main)