On Wed, 20 Feb 2019 23:08:57 +0100 Danny Milosavljevic <dan...@scratchpost.org> wrote:
> First somewhat working version attached... > > It finds 1387 tests in 328 suites. > > The original finds 2611 tests in 349 suites. > > That's because skip-comments is somehow broken. Another example is tests/repo/pathspec.c where the vast majority of the file is missing. In any case, leaving the call of skip-comments off, it finds 2611 tests in 349 suites (see attachment). So either we find the problem in skip-comments, or we leave it off. In both cases, this can be used in order to generate the test metadata for libgit2 now.
;; -*- geiser-scheme-implementation: guile -*-
;;; Implementation: Danny Milosavljevic <dan...@scratchpost.org>
;;; 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)
pgpfvjyD_2nmX.pgp
Description: OpenPGP digital signature
