[PATCH] Implement doctest utility as guild script

[PATCH] Implement doctest utility as guild script

[KAction]

From: Dmitry Bogatov <KAction@gnu.org>

Syntax:

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

Signed-off-by: Dmitry Bogatov <KAction@gnu.org>
---
 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 <KAction@gnu.org>
+
+(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 <KAction@gnu.org>
+
+(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 <KAction@gnu.org>
+
+(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 <KAction@gnu.org>
+
+(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.

Re: [PATCH] Implement doctest utility as guild script

[Ludovic Courtès]

Hi,

Thanks for the patch.

KAction@gnu.org skribis:

> +(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)))

I share Ian Price’s concerns regarding the fundamental idea behind
doctest.  Namely, writing code in strings means that syntax errors can
only be detected very late, and that the code in there cannot easily
refer to anything outside; furthermore, that pollutes docstrings, whose
goal is to provide a help string for users.

This could be partly addressed by writing sexps instead of strings,
though you would still not have compiler warnings & co.

So I’m not enthusiastic about encouraging this mechanism by
incorporating into Guile.

Thoughts?

Thanks,
Ludo’.

Re: [PATCH] Implement doctest utility as guild script

[Dmitry Bogatov]

[-- Attachment #1: Type: text/plain, Size: 1063 bytes --]


Ludovic Courtès <ludo@gnu.org> writes:

> I share Ian Price’s concerns regarding the fundamental idea behind
> doctest.  Namely, writing code in strings means that syntax errors can
> only be detected very late, and that the code in there cannot easily
> refer to anything outside;
What do you mean outside? I think it encourages pure function.

Am I understand right, that you would like to check such tests on
`make all`, and not on `make check`?

> furthermore, that pollutes docstrings, whose
> goal is to provide a help string for users.
Definitely right. At current state. But it is possible to separate
actual english documentation string and doctests. Displaying them
in (help function-name) may be turned off or, imho (since I like examples
in documentation), better, made optional.

--
Best regards, Dmitry Bogatov <KAction@gnu.org>,
Free Software supporter and netiquette guardian.
	git clone git://kaction.name/rc-files.git --depth 1
	GPG: 54B7F00D
Html mail and proprietary format attachments are forwarded to /dev/null.

[-- Attachment #2: Type: application/pgp-signature, Size: 835 bytes --]

Re: [PATCH] Implement doctest utility as guild script

[Ludovic Courtès]

Dmitry Bogatov <KAction@gnu.org> skribis:

> Ludovic Courtès <ludo@gnu.org> writes:
>
>> I share Ian Price’s concerns regarding the fundamental idea behind
>> doctest.  Namely, writing code in strings means that syntax errors can
>> only be detected very late, and that the code in there cannot easily
>> refer to anything outside;
> What do you mean outside? I think it encourages pure function.

I meant that sometimes you want to factorize helpers for the test suite
as separate procedures/macros, and it may be tricky to use them from
within the docstring.

>> furthermore, that pollutes docstrings, whose
>> goal is to provide a help string for users.
> Definitely right. At current state. But it is possible to separate
> actual english documentation string and doctests. Displaying them
> in (help function-name) may be turned off or, imho (since I like examples
> in documentation), better, made optional.

OK, but that’s not supported yet.  :-)

Thanks,
Ludo’.