;; -*- 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 (> (length cb) 0)
      (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)
  (replace (string-append "//.*?$|"
                          "/[*].*?[*]/|"
                          "'([.]|[^'])*'|"
                          "\"([.]|[^\"])*")
           "" 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 (string-append "^(void\\s+(test_"
                                                   name
                                                   "__(\\w+))\\s*\(\\s*void\\s*\\))\\s*\\{")
                                    contents
                                    '()
                                    cons-match))
             (callbacks (filter (lambda (entry)
                                   (match (assoc-ref entry "short-name")
                                    (("initialize" value) #f)
                                    (("cleanup" value) #f)
                                    (a #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" value) value)
                                                       ((_ value) #f)))
                                                    entries)))
              ("cleanup" (maybe-only (filter-map (lambda (entry)
                                                   (match (assoc-ref entry "short-name")
                                                    (("cleanup" value) value)
                                                    ((_ value) #f)))
                                                 entries)))
              ("callbacks" callbacks))
            #f)))

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

(define (generate-TestSuite path output excludes)
    (define (load)
        (define enter? (const #t))
        (define (leaf file stat result)
          (let* ((module-root (string-drop 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)))
            (write file)
            (write module-root)
            (newline)
            (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
        (write "fold")
        (newline)
        (file-system-fold enter? leaf down up skip error '() path))

    (define (CallbacksTemplate module)
      (string-append "static const struct clar_func _clar_cb_" 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") ", "
            (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)
                         (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")

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

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

      (display (string-append "Written `clar.suite` (" callback-count " tests in " suite-count " suites"))
      #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)