[PATCH] Implement doctest utility as guild script

[KAction]

From: Dmitry Bogatov <address@hidden>

Syntax:

+++ (some-expression)
--- read-representation-of-expected-value
--- another-one-if-multiple-values-returned

Signed-off-by: Dmitry Bogatov <address@hidden>
---
 module/scripts/doctest.scm           |  73 ++++++++++++++++++++
 module/scripts/doctest/docstring.scm | 110 ++++++++++++++++++++++++++++++
 module/scripts/doctest/evaluate.scm  |  82 +++++++++++++++++++++++
 module/scripts/doctest/util.scm      | 125 +++++++++++++++++++++++++++++++++++
 4 files changed, 390 insertions(+)
 create mode 100644 module/scripts/doctest.scm
 create mode 100644 module/scripts/doctest/docstring.scm
 create mode 100644 module/scripts/doctest/evaluate.scm
 create mode 100644 module/scripts/doctest/util.scm

diff --git a/module/scripts/doctest.scm b/module/scripts/doctest.scm
new file mode 100644
index 0000000..40e08ea
--- /dev/null
+++ b/module/scripts/doctest.scm
@@ -0,0 +1,73 @@
+;;; Doctest --- Check function usage examples in docstring.
+
+;; Copyright 2013 Dmitry Bogatov
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public License
+;; as published by the Free Software Foundation; either version 3, or
+;; (at your option) any later version.
+;;
+;; This program 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
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this software; see the file COPYING.LESSER.  If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Dmitry Bogatove <address@hidden>
+
+(define-module (scripts doctest)
+    #:export (doctest))
+(use-modules (ice-9 getopt-long))
+(use-modules (ice-9 match))
+(use-modules (ice-9 receive))
+(use-modules (srfi srfi-1))
+(use-modules (srfi srfi-9))
+(use-modules (srfi srfi-26))
+(use-modules (oop goops))
+(use-modules (scripts doctest util))
+(use-modules (scripts doctest evaluate))
+(define +submodules-prefix+ '(scripts doctest))
+(define +submodules-list+ '((util) (docstring) (evaluate)))
+(define +help-message+
+    "
+        GNU Guile utility to check tests specified in
+        documentation string.
+
+        Usage: doctest [OPTIONS] '(module submodule)' <modules>
+        Options description:
+            -h, --help     Print this help message and exit
+
+    ")
+(define %summary "Check tests in documentation strings in module")
+
+(define (command-line->modules args)
+    "
+        Parse command line arguments, perform required actions
+        and return non-options arguments.
+    "
+    (let* ((options (getopt-long args
+                                 '((help    (single-char #\h) (value #f))
+                                   (verbose (single-char #\v) (value #f)))))
+           (help-asked (option-ref options 'help #f))
+           (modules-strings (option-ref options '() '())))
+        (when help-asked
+              (display (docstring->text +help-message+))
+              (exit))
+        (if (null? (option-ref options '() '()))
+            (map (cute append +submodules-prefix+ <>) +submodules-list+)
+            modules-strings)))
+
+(define (doctest . args)
+    ;; Since (getopt-long) ignores first element of args, we fake it.
+    (for [module-name in (command-line->modules (cons #f args))]
+         (define module (sexp->module module-name))
+         (if module
+             (begin (format #t "Resolved module ~a\n"
+                            module-name)
+                    (module-run-doctests module))
+             (format #t "Failed to resovle ~a\n" module-name))))
+(define main doctest)
diff --git a/module/scripts/doctest/docstring.scm 
b/module/scripts/doctest/docstring.scm
new file mode 100644
index 0000000..ca137a7
--- /dev/null
+++ b/module/scripts/doctest/docstring.scm
@@ -0,0 +1,110 @@
+;;; Doctest --- Check function usage examples in docstring.
+
+;; Copyright 2013 Dmitry Bogatov
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public License
+;; as published by the Free Software Foundation; either version 3, or
+;; (at your option) any later version.
+;;
+;; This program 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
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this software; see the file COPYING.LESSER.  If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Dmitry Bogatove <address@hidden>
+
+(define-module (scripts doctest docstring)
+    #:export (docstring->text docstring->doctests min*))
+(use-modules (srfi srfi-1))
+(use-modules (scripts doctest util))
+
+(define (min* lst)
+    "
+        Find minimum non-negative integers LST, where
+        0 is considered to be more then any positive number.
+
+        +++ (min* '(1 0 2))
+        --- 1
+    "
+    (fold (lambda (n seed)
+             (cond
+              ((zero? n) seed)
+              ((zero? seed) n)
+              (else (min seed n))))
+         0 lst))
+
+(define (substring-safe str index)
+    "
+        Return substring of STR, starting at INDEX,
+        or empty string, if STR is too short.
+
+        +++ (substring-safe \"1234\" 3)
+        --- \"4\"
+        +++ (substring-safe \"1234\" 6)
+        --- \"\"
+    "
+    (if (< (string-length str) index)
+       (string)
+       (substring str index)))
+
+(define (count-leading-whitespaces str)
+    "
+        Return count of leading whitespaces in STR.
+
+        +++ (count-leading-whitespaces \"   str\")
+        --- 3
+    "
+    (length (take-while char-whitespace? (string->list str))))
+
+(define (docstring->string-list docstring)
+    "
+        Transformate docstring to allow pretty printing in source
+        and in documentation.
+
+        Algorithm of transformation:
+        1. Split docstring on list of string by newlines.
+        2. Disregard string, consising of whitespaces only
+           at begin and end of list.
+        3. Calculate minimal number of starting spaces in
+           all non-empty strings.
+        4. Reduce number of starting spaces in all non-empty
+           strings by minimum, calculated at step 3.
+
+        All whitespaces treated equally, using tabulation
+        is discouraged.
+    "
+    (define string-list (drop-around string-blank?
+                                    (string-split docstring #\newline)))
+    (define whitespace-count (min* (map count-leading-whitespaces 
string-list)))
+    (map (lambda (str) (substring-safe str whitespace-count)) string-list)
+)
+
+(define (doctest? str) (prefix-of? "+++" str))
+(define (expectation? str) (prefix-of? "---" str))
+(define (line->sexp line) (read (open-input-string (substring line 3))))
+(define (docstring->doctests docstring)
+    "
+        Return list of doctests in DOCSTRING.
+
+        Exceptions are not supported yet.
+    "
+    (map (lambda (group)
+            (map line->sexp
+                 (cons (car group)
+                       (take-while expectation?
+                                   (cdr group)))))
+        (group-by doctest?
+                  (docstring->string-list docstring))))
+
+(define (docstring->text docstring)
+    "
+        Convert docstring to text, suitable for printing
+        by stripping leading whitespaces.
+    "
+    (string-join (docstring->string-list) "\n"))
diff --git a/module/scripts/doctest/evaluate.scm 
b/module/scripts/doctest/evaluate.scm
new file mode 100644
index 0000000..a3d8052
--- /dev/null
+++ b/module/scripts/doctest/evaluate.scm
@@ -0,0 +1,82 @@
+;;; Doctest --- Check function usage examples in docstring.
+
+;; Copyright 2013 Dmitry Bogatov
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public License
+;; as published by the Free Software Foundation; either version 3, or
+;; (at your option) any later version.
+;;
+;; This program 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
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this software; see the file COPYING.LESSER.  If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Dmitry Bogatove <address@hidden>
+
+(define-module (scripts doctest evaluate)
+    #:export (sexp->module module-run-doctests run-doctests))
+(use-modules (ice-9 match))
+(use-modules (scripts doctest util))
+(use-modules (scripts doctest docstring))
+
+(define (sexp->module sexp)
+    "
+       Return module, associated in SEXP, #f otherwise.
+        If SEXP is string, read from before.
+    "
+    (if (string? sexp)
+       (sexp->module (read (open-input-string sexp)))
+       (and (list? sexp)
+            (not (null? sexp))
+            (resolve-module sexp #:ensure #f))))
+
+(define (values->string objs)
+    (define (show obj) (format #f "~a" obj))
+    (match objs
+          ([] "*unspecified*")
+          ([single] (format #f "~a" single))
+          ([val ...] (format #f "(values ~a)"
+                             (string-join (map show val))))))
+
+(define* (run-doctests tests #:key context)
+    (define len (length tests))
+    (when context
+         (set-current-module context))
+    (for [(index . (test . expects)) as _ in (enumerate tests #:init 1)]
+        (define (display-expectations test expects)
+            (format #t "Error when evaluating ~a" test)
+            (format #t "\n    Expected: ~a" (values->string expects)))
+        (format #t "\n  [~a/~a]..." index  len)
+        (catch #t
+               (begin-proc
+                (call-with-values (begin-proc (eval test (current-module)))
+                    (lambda ( . results)
+                        (if (equal? results expects)
+                            (format #t "ok")
+                            (begin (display-expectations test expects)
+                                   (format #t "\n    Received: ~a"
+                                           (values->string results)))))))
+               (lambda ( . args)
+                   (display-expectations test expects)
+                   (format #t "\n    Caught: ~a" args)))))
+
+(define (module-run-doctests module)
+    (set-current-module module)
+    (for [(name => var) in (module-obarray (current-module))]
+        (define value (variable-ref var))
+        (when [procedure? value]
+              (let* ((docstring (procedure-documentation value))
+                     (tests (and (string? docstring)
+                                 (docstring->doctests docstring))))
+                  (format #t " Tesing ~a... " name)
+                  (cond
+                   [(not docstring) (display "undocumented\n")]
+                   [(null? tests)   (display "no tests\n")]
+                   [else            (run-doctests tests)
+                                    (newline)])))))
diff --git a/module/scripts/doctest/util.scm b/module/scripts/doctest/util.scm
new file mode 100644
index 0000000..84e3e4f
--- /dev/null
+++ b/module/scripts/doctest/util.scm
@@ -0,0 +1,125 @@
+;;; Doctest --- Check function usage examples in docstring.
+
+;; Copyright 2013 Dmitry Bogatov
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public License
+;; as published by the Free Software Foundation; either version 3, or
+;; (at your option) any later version.
+;;
+;; This program 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
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this software; see the file COPYING.LESSER.  If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Dmitry Bogatove <address@hidden>
+
+(define-module (scripts doctest util)
+    #:export ( &not
+              begin-proc
+              drop-around
+              enumerate
+              for
+              group-by
+              prefix-of?
+              string-blank? ))
+(use-modules (ice-9 match))
+(use-modules (srfi srfi-1))
+
+(define-syntax for
+    (syntax-rules (in => as)
+       ([_ ((key => value) in hash) exp ...]
+        [hash-for-each (lambda (key value) exp ...) hash])
+       ([_ (pattern as var in list) exp ...]
+        [for-each (lambda (var) (match var (pattern exp ...))) list])
+       ([_ (var in list) exp ...]
+        [for-each (lambda (var) exp ...) list])))
+
+(define (&not pred)
+    "
+        Return negation of predicate PRED.
+
+        +++ ((&not even?) 2)
+        --- #f
+    "
+    (lambda (x) (not (pred x))))
+
+
+(define (string-forall? pred str)
+    "
+        Return #t if STR is empty or every char satisfy PRED.
+
+        +++ (string-forall? char-whitespace? \"string\")
+        --- #f
+        +++ (string-forall? char-numeric? \"123\")
+        --- #t
+        +++ (string-forall? char-numeric? \"\")
+        --- #t
+    "
+    (every pred (string->list str)))
+
+(define (string-blank? str) (string-forall? char-whitespace? str))
+
+
+
+(define (group-by header? lst)
+    "
+        Return list of sublists in LST, car of which satisfy HEADER?
+        and no other elements satisfy it.
+        +++ (group-by even? '(2 1 5 0 1 8))
+        --- ((2 1 5) (0 1) (8))
+    "
+    (map reverse
+        (cdr (reverse
+              (fold (lambda (el accum)
+                        (match accum
+                               [[cur-group . groups]
+                                (if (header? el)
+                                    (cons (list el)
+                                          (cons cur-group
+                                                groups))
+                                    (cons (cons el cur-group)
+                                          groups))]))
+                    (cons '() '())
+                    (drop-while (lambda (x) (not (header? x))) lst))))))
+
+
+
+(define-syntax begin-proc
+    (syntax-rules ()
+       ([_ form ...]
+        [lambda () form ...])))
+
+(define* (enumerate lst #:key (step 1) (init 0))
+    "
+        Return list of pairs (INDEX . ELEMENT), where
+        INDEX starts at INIT and gets incremented by STEP.
+
+        +++ (enumerate '(foo bar baz))
+        --- ((0 . foo) (1 . bar) (2 . baz))
+        +++ (enumerate '(foo bar baz) #:step -1 #:init 3)
+        --- ((3 . foo) (2 . bar) (1 . baz))
+    "
+    (reverse
+     (fold (lambda (el seed)
+              (let ((index (if (null? seed) init
+                               (+ step (caar seed)))))
+                  (cons (cons index el) seed)))
+          '() lst)))
+
+(define (prefix-of? prefix str)
+    (and (>= (string-length str) (string-length prefix))
+        (equal? prefix (substring str 0 (string-length prefix)))))
+
+(define (drop-around pred lst)
+    "
+        Remove starting and trailing elements of LST,
+        satifsfying PRED.
+    "
+    (define (drop-prefix l) (drop-while pred l))
+    (drop-prefix (reverse (drop-prefix (reverse lst)))))
-- 
Recipients list generated via git-blame. Tell me, if you object.