;; -*- 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 (rxegexp-substitute/global flags port regexp string . items)

  ;; If `port' is #f, send output to a string.
  (if (not port)
      (call-with-output-string
       (lambda (p)
         (apply regexp-substitute/global flags p regexp string items)))

      ;; Walk the set of non-overlapping, maximal matches.
      (let next-match ((matches (list-matches regexp string flags))
                       (start 0))
        (if (null? matches)
            (display (substring string start) port)
            (let ((m (car matches)))

              ;; Process all of the items for this match.  Don't use
              ;; for-each, because we need to make sure 'post at the
              ;; end of the item list is a tail call.
              (let next-item ((items items))

                (define (do-item item)
                  (cond
                   ((string? item)    (display item port))
                   ((integer? item)   (display (match:substring m item) port))
                   ((procedure? item) (display (item m) port))
                   ((eq? item 'pre)
                    (display
                     (substring string start (match:start m))
                     port))
                   ((eq? item 'post)
                    (next-match (cdr matches) (match:end m)))
                   (else (error 'wrong-type-arg item))))

                (if (pair? items)
                    (if (null? (cdr items))
                        (do-item (car items)) ; This is a tail call.
                        (begin
                          (do-item (car items)) ; This is not.
                          (next-item (cdr items)))))))))))

(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)
  (replace (string-append "//[^\n]*?|"
                          "/[*].*?[*]/|"
                          "'([.]|[^'])*?'|"
                          "\"([.]|[^\"])*?\"")
           "" text))

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

(define (Module name path excludes)
  (write name)
  (write path)
  (newline)
  (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* ((contents2 (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)))
        (write callbacks)
        (newline)
        (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)