Add coverage, get to near 100

diff --git a/.candle b/.candle
index 5ba07cc780d6853588b8447a03c525e3fcd49de3..579c2096b3abca3b521f46bc46f5868a5bf57cdb 100644 (file)
--- a/.candle
+++ b/.candle
@@ -1,8 +1,29 @@
-(:packages :sheep :sheep-test :wolf)
+(:packages :sheep :sheep-test :wolf :sb-cover)

 (:name :sheep
  :tasks
  ((:name :test :directions
    (sheep-test:run-all-tests))
 (:name :sheep
  :tasks
  ((:name :test :directions
    (sheep-test:run-all-tests))

+  (:name :coverage :directions
+   (progn
+    (let
+     ((coverage nil)
+      (*error-output* (make-broadcast-stream))
+      (*standard-output* (make-broadcast-stream)))
+     (declaim (optimize sb-cover:store-coverage-data))
+     (asdf:load-system :sheep :force t)
+     (sheep-test:run-all-tests)
+     (setf coverage
+      (apply #'+
+       (mapcar
+        (lambda (coverage-item) (length (remove t (cdr coverage-item) :key #'cdr)))
+        (sb-cover:save-coverage))))
+     (declaim (optimize (sb-cover:store-coverage-data 0)))
+     (asdf:load-system :sheep :force t)
+     ; 34 here is the number of unexecuted forms/branches due to
+     ; error checking that can get triggered during mistakes in development,
+     ; but aren't accessible during normal running (because if they were,
+     ; that's be a bug we needed to fix!)
+     (= coverage 34))))

   (:name :wolf :directions
    (wolf:pretty-print-check-directory "src"
     :copyright-notice "; Copyright .* Frank Duncan \\(frank@consxy.com\\) under AGPL3.  See distributed LICENSE.txt."))
   (:name :wolf :directions
    (wolf:pretty-print-check-directory "src"
     :copyright-notice "; Copyright .* Frank Duncan \\(frank@consxy.com\\) under AGPL3.  See distributed LICENSE.txt."))

diff --git a/resources/success1.lisp b/resources/success1.lisp
index 28d492df7cdae39169d04b6a1798e03400858495..642a3261c722122e8e90f9abdeb2b46649df8755 100644 (file)
--- a/resources/success1.lisp
+++ b/resources/success1.lisp
@@ -6,7 +6,9 @@ This is should all get pulled in and the markdown.md should be equal
 to success1.md.")
  (:export
   #:*special-variable*
 to success1.md.")
  (:export
   #:*special-variable*

+  #:*special-variable-2*

   #:test-condition
   #:test-condition

+  #:test-struct

   #:func-that-does-stuff #:noargs #:no-args-and-values #:result-list #:has-no-examples
   #:values-result #:has-optional #:has-keywords #:has-rest))
 
   #:func-that-does-stuff #:noargs #:no-args-and-values #:result-list #:has-no-examples
   #:values-result #:has-optional #:has-keywords #:has-rest))
 


@@ -30,16 +32,39 @@ DESCRIPTION:
   When true, it satisfies if coniditions.  When NIL, it does not.
   That may make it seem like it's not very special, but it is.
 
   When true, it satisfies if coniditions.  When NIL, it does not.
   That may make it seem like it's not very special, but it is.
 

+  But sometimes it needs to reference itself: *SPECIAL-VARIABLE*
+

 EXAMPLES:
 
   (let ((*special-variable* t)) (go)) => 'let-it-go")
 
 EXAMPLES:
 
   (let ((*special-variable* t)) (go)) => 'let-it-go")
 

+(defvar *special-variable-2* nil
+ "*SPECIAL-VARIABLE-2*
+
+VALUE TYPE:
+
+  a generalized boolean
+
+INITIAL VALUE:
+
+  NIL
+
+DESCRIPTION:
+
+  It is special, and a boolean.")
+

 (define-condition test-condition nil nil
  (:documentation
   "Simple documentation.
 
 For a simple condition."))
 
 (define-condition test-condition nil nil
  (:documentation
   "Simple documentation.
 
 For a simple condition."))
 

+(defstruct test-struct
+ "Simple documentation.
+
+For a simple structure.  But this structure may go to two lines
+for this part of it.")
+

 (defun func-that-does-stuff (path x)
  "FUNC-THAT-DOES-STUFF PATH X => RESULT
 
 (defun func-that-does-stuff (path x)
  "FUNC-THAT-DOES-STUFF PATH X => RESULT
 

diff --git a/resources/success1.md b/resources/success1.md
index 3c4b4f833c800e8857609690b098cb77603a588b..c8f6882539f4b53847f896fc653611ae6c39136e 100644 (file)
--- a/resources/success1.md
+++ b/resources/success1.md
@@ -7,6 +7,7 @@ This is should all get pulled in and the markdown.md should be equal to success1
 ## Contents
 
 * **variable [\*special\-variable\*](#variable-special-variable)** - It is special, and a boolean.
 ## Contents
 
 * **variable [\*special\-variable\*](#variable-special-variable)** - It is special, and a boolean.

+* **variable [\*special\-variable\-2\*](#variable-special-variable-2)** - It is special, and a boolean.

 * **function [func-that-does-stuff](#function-func-that-does-stuff)** - _func-that-does-stuff_ runs all the things against a file and returns as soon as the first func error is found.
 * **function [has-keywords](#function-has-keywords)** - _has-keywords_ runs all the things against a file and returns as soon as the first func error is found.
 * **function [has-no-examples](#function-has-no-examples)** - _has-no-examples_ runs all the things against a file and returns as soon as the first func error is found.
 * **function [func-that-does-stuff](#function-func-that-does-stuff)** - _func-that-does-stuff_ runs all the things against a file and returns as soon as the first func error is found.
 * **function [has-keywords](#function-has-keywords)** - _has-keywords_ runs all the things against a file and returns as soon as the first func error is found.
 * **function [has-no-examples](#function-has-no-examples)** - _has-no-examples_ runs all the things against a file and returns as soon as the first func error is found.


@@ -16,6 +17,7 @@ This is should all get pulled in and the markdown.md should be equal to success1
 * **function [noargs](#function-noargs)** - _noargs_ runs all the things against a file and returns as soon as the first func error is found.
 * **function [result-list](#function-result-list)** - _result-list_ runs all the things against a file and returns as soon as the first func error is found.
 * **condition [test-condition](#condition-test-condition)** - Simple documentation.
 * **function [noargs](#function-noargs)** - _noargs_ runs all the things against a file and returns as soon as the first func error is found.
 * **function [result-list](#function-result-list)** - _result-list_ runs all the things against a file and returns as soon as the first func error is found.
 * **condition [test-condition](#condition-test-condition)** - Simple documentation.

+* **structure [test-struct](#struct-test-struct)** - Simple documentation.

 * **function [values-result](#function-values-result)** - _values-result_ runs all the things against a file and returns as soon as the first func error is found.
 
 ## Variable \*SPECIAL\-VARIABLE\*
 * **function [values-result](#function-values-result)** - _values-result_ runs all the things against a file and returns as soon as the first func error is found.
 
 ## Variable \*SPECIAL\-VARIABLE\*


@@ -34,10 +36,26 @@ It is special, and a boolean.
 
 When true, it satisfies if coniditions.  When NIL, it does not. That may make it seem like it's not very special, but it is.
 
 
 When true, it satisfies if coniditions.  When NIL, it does not. That may make it seem like it's not very special, but it is.
 

+But sometimes it needs to reference itself: _*special-variable*_
+

 #### Examples:
 
 ```(let ((*special-variable* t)) (go))``` => ```'let-it-go```  
 
 #### Examples:
 
 ```(let ((*special-variable* t)) (go))``` => ```'let-it-go```  
 

+## Variable \*SPECIAL\-VARIABLE\-2\*
+
+#### Value Type:
+
+a generalized boolean
+
+#### Initial Value:
+
+NIL
+
+#### Description:
+
+It is special, and a boolean.
+

 ## Function **FUNC-THAT-DOES-STUFF**
 
 #### Syntax:
 ## Function **FUNC-THAT-DOES-STUFF**
 
 #### Syntax:


@@ -214,6 +232,12 @@ Simple documentation.
 
 For a simple condition.
 
 
 For a simple condition.
 

+## Struct TEST-STRUCT
+
+Simple documentation.
+
+For a simple structure.  But this structure may go to two lines for this part of it.
+

 ## Function **VALUES-RESULT**
 
 #### Syntax:
 ## Function **VALUES-RESULT**
 
 #### Syntax:

diff --git a/src/main/func.lisp b/src/main/func.lisp
index ae5e25a8ffd18499c906fd403cdcfbafbfd2c7fe..8f4b863d32b42d0c7a65f1288bc36bdd2d118826 100644 (file)
--- a/src/main/func.lisp
+++ b/src/main/func.lisp
@@ -65,7 +65,8 @@
     (fire-error (format nil "Type line did not match \"  TYPE: type-definition\": ~A" type-line)))
    (cl-ppcre:register-groups-bind (type def) (type-scanner type-line)
     (let
     (fire-error (format nil "Type line did not match \"  TYPE: type-definition\": ~A" type-line)))
    (cl-ppcre:register-groups-bind (type def) (type-scanner type-line)
     (let

-     ((decomposed-def (or (or-type def) (list-type def) (asterisk-type def) (symbol-type def))))
+     ((decomposed-def (or (list-type def) (or-type def) (asterisk-type def) (symbol-type def))))
+     ; This error should never be fired off, as the above regexes match everything

      (when (not decomposed-def) (fire-error (format nil "Couldn't figure out how to decompose: ~A" def)))
      (list
       type
      (when (not decomposed-def) (fire-error (format nil "Couldn't figure out how to decompose: ~A" def)))
      (list
       type


@@ -145,6 +146,7 @@
    (process-examples))))
 
 (defun parse-examples ()
    (process-examples))))
 
 (defun parse-examples ()

+ ; This error should never be fired off, as the only way description ends is if it ran into EXAMPLES

  (when (string/= "EXAMPLES:" (next)) (fire-error (format nil "Expected EXAMPLES: instead of: ~A" (prev-line))))
  (expect-blank-line)
  (list :examples (process-examples)))
  (when (string/= "EXAMPLES:" (next)) (fire-error (format nil "Expected EXAMPLES: instead of: ~A" (prev-line))))
  (expect-blank-line)
  (list :examples (process-examples)))


@@ -220,8 +222,6 @@
   (when (not (cl-ppcre:scan scanner (peek)))
    (fire-error (format nil "First line of ~A did not match: ~A {ARGS}* => {RESULT}*, ~A" func func-name (peek))))
   (cl-ppcre:register-groups-bind (args result) (scanner (next))
   (when (not (cl-ppcre:scan scanner (peek)))
    (fire-error (format nil "First line of ~A did not match: ~A {ARGS}* => {RESULT}*, ~A" func func-name (peek))))
   (cl-ppcre:register-groups-bind (args result) (scanner (next))

-   (when (cl-ppcre:scan "[a-z]" func-name)
-    (fire-error (format nil "Function name should be all uppercase: ~A" func-name)))

    (let
     ((ast-of-start
       (list
    (let
     ((ast-of-start
       (list


@@ -273,6 +273,7 @@
     (cond
      ((stringp text) text)
      ((and (listp text) (eql :keyword (car text))) (format nil "_~(~A~)_" (cadr text)))
     (cond
      ((stringp text) text)
      ((and (listp text) (eql :keyword (car text))) (format nil "_~(~A~)_" (cadr text)))

+     ; This error should never get fired, as it would only if there were a bug in the conversion code

      (t (fire-error (format nil "Don't know how to convert text: ~S" text)))))
    (cadr text))))
 
      (t (fire-error (format nil "Don't know how to convert text: ~S" text)))))
    (cadr text))))
 

diff --git a/src/main/var.lisp b/src/main/var.lisp
index c184795552b52dff6f518d7502915fb4e6ab0178..4238762bf9bef4d55c42bbaa66a8408c7770bd5d 100644 (file)
--- a/src/main/var.lisp
+++ b/src/main/var.lisp
@@ -23,7 +23,6 @@
 (defun verify-next-line (&key optional)
  (cond
   ((and optional (not (more))) t)
 (defun verify-next-line (&key optional)
  (cond
   ((and optional (not (more))) t)

-  ((not (more)) (fire-error (format nil "Expected line after: ~A" (prev-line))))

   ((cl-ppcre:scan " $" (peek)) (fire-error (format nil "Can't end line with a space: ~A" (peek))))
   ((< 120 (length (peek))) (fire-error (format nil "Longer than 120 chars: ~A" (peek))))))
 
   ((cl-ppcre:scan " $" (peek)) (fire-error (format nil "Can't end line with a space: ~A" (peek))))
   ((< 120 (length (peek))) (fire-error (format nil "Longer than 120 chars: ~A" (peek))))))
 


@@ -40,7 +39,7 @@
      (cons
       (format nil "~A~A~A"
        (subseq next-line 2 (length next-line))
      (cons
       (format nil "~A~A~A"
        (subseq next-line 2 (length next-line))

-       (if (and (car rest-of-freeform) (string/= "" (car rest-of-freeform))) " " "")
+       (if (string/= "" (car rest-of-freeform)) " " "")

        (car rest-of-freeform))
       (cdr rest-of-freeform))))
    ((string= "" next-line)
        (car rest-of-freeform))
       (cdr rest-of-freeform))))
    ((string= "" next-line)


@@ -70,6 +69,7 @@
    (process-examples))))
 
 (defun parse-examples ()
    (process-examples))))
 
 (defun parse-examples ()

+ ; This shouldn't fire, unless there's a bug in our processing

  (when (string/= "EXAMPLES:" (next)) (fire-error (format nil "Expected EXAMPLES: instead of: ~A" (prev-line))))
  (expect-blank-line)
  (list :examples (process-examples)))
  (when (string/= "EXAMPLES:" (next)) (fire-error (format nil "Expected EXAMPLES: instead of: ~A" (prev-line))))
  (expect-blank-line)
  (list :examples (process-examples)))


@@ -86,7 +86,6 @@
        (lambda
         (text-item)
         (cond
        (lambda
         (text-item)
         (cond

-         ((not (stringp text-item)) (list text-item))

          ((not (cl-ppcre:scan (cl-ppcre:quote-meta-chars (car remaining-keywords)) text-item)) (list text-item))
          (t
           (let
          ((not (cl-ppcre:scan (cl-ppcre:quote-meta-chars (car remaining-keywords)) text-item)) (list text-item))
          (t
           (let


@@ -96,8 +95,6 @@
             (mapcar (lambda (ti) (list (list :keyword (car remaining-keywords)) ti)) (cdr split-text)))))))
        (inject-keywords text (cdr remaining-keywords)))))))
   (list :text (inject-keywords text *keywords*))))
             (mapcar (lambda (ti) (list (list :keyword (car remaining-keywords)) ti)) (cdr split-text)))))))
        (inject-keywords text (cdr remaining-keywords)))))))
   (list :text (inject-keywords text *keywords*))))

-; (map
-; (list :text text))

 
 (defun parse-header (var)
  (verify-next-line)
 
 (defun parse-header (var)
  (verify-next-line)


@@ -105,8 +102,6 @@
   ((var-name (symbol-name var)))
   (when (not (string= var-name (peek)))
    (fire-error (format nil "First line of ~A did not match: ~A, ~A" var var-name (peek))))
   ((var-name (symbol-name var)))
   (when (not (string= var-name (peek)))
    (fire-error (format nil "First line of ~A did not match: ~A, ~A" var var-name (peek))))

-  (when (cl-ppcre:scan "[a-z]" var-name)
-   (fire-error (format nil "Variable name should be all uppercase: ~A" var-name)))

   (add-keyword var-name)
   (next)
   (expect-blank-line)
   (add-keyword var-name)
   (next)
   (expect-blank-line)


@@ -134,6 +129,7 @@
     (cond
      ((stringp text) text)
      ((and (listp text) (eql :keyword (car text))) (format nil "_~(~A~)_" (cadr text)))
     (cond
      ((stringp text) text)
      ((and (listp text) (eql :keyword (car text))) (format nil "_~(~A~)_" (cadr text)))

+     ; This should never fire, unless there's a bug in our processor

      (t (fire-error (format nil "Don't know how to convert text: ~S" text)))))
    (cadr text))))
 
      (t (fire-error (format nil "Don't know how to convert text: ~S" text)))))
    (cadr text))))
 

diff --git a/src/test/failures.lisp b/src/test/failures.lisp
index 76f815d38b108c00ff0260ec90fd57d992c091f6..87cfa5896be68f623c8e218f57b31fb5b08d655b 100644 (file)
--- a/src/test/failures.lisp
+++ b/src/test/failures.lisp
@@ -339,6 +339,43 @@ DESCRIPTION:
 "
  "Expected ARGUMENTS AND VALUES: instead of: ARGUUMENTS AND VALUES:")
 
 "
  "Expected ARGUMENTS AND VALUES: instead of: ARGUUMENTS AND VALUES:")
 

+(deffailure-func-test
+ "Args-and-values - non empty next line"
+ "UNUSED => RESULT
+
+ARGUMENTS AND VALUES:
+
+  RESULT: a pathname
+  RESULT2: a thing
+
+DESCRIPTION:
+
+"
+ "No arguments left, but next line isn't empty:   RESULT2: a thing")
+
+(deffailure-func-test
+ "Args-and-values - out of order arguments"
+ "UNUSED => RESULT1, RESULT2
+
+ARGUMENTS AND VALUES:
+
+  RESULT2: a thing
+  RESULT1: a thing
+
+DESCRIPTION:
+
+"
+ "Expected a description for RESULT1 but got one for RESULT2")
+
+(deffailure-func-test
+ "Args-and-values - ended before all arguments"
+ "UNUSED => RESULT1, RESULT2
+
+ARGUMENTS AND VALUES:
+
+  RESULT1: a thing"
+ "Expected line after:   RESULT1: a thing")
+

 (deffailure-func-test
  "Header - first line doesn't start with func-name (naturally all in upper case)"
  "UNUUSED => RESULT
 (deffailure-func-test
  "Header - first line doesn't start with func-name (naturally all in upper case)"
  "UNUUSED => RESULT


@@ -378,6 +415,56 @@ DESCRIPTION:
 "
  "Result in UNUSED should be all upper case: REsULT")
 
 "
  "Result in UNUSED should be all upper case: REsULT")
 

+(deffailure-func-test
+ "Description - can't end line with space"
+ "UNUSED => RESULT
+
+ARGUMENTS AND VALUES:
+
+  RESULT: a pathname
+
+DESCRIPTION:
+
+  This is a test 
+"
+ "Can't end line with a space:   This is a test ")
+
+(deffailure-func-test
+ "Symbols - keyword symbols must be all in lower case"
+ "UNUSED => RESULT
+
+  RESULT: (:ASDF)
+
+DESCRIPTION:
+
+  This is a test 
+"
+ "Keyword symbols must all be lower case: :ASDF")
+
+(deffailure-func-test
+ "Symbols - type symbols must be all in lower case"
+ "UNUSED => RESULT
+
+  RESULT: (asdf)
+
+DESCRIPTION:
+
+  This is a test 
+"
+ "Type symbols must all be upper case: asdf")
+
+(deffailure-func-test
+ "Symbols - list types can't have | in them"
+ "UNUSED => RESULT
+
+  RESULT: (ASDF | FDSA)
+
+DESCRIPTION:
+
+  This is a test 
+"
+ "List types can't have | in them: (ASDF | FDSA)")
+

 (deffailure-var-test
  "Blank line - after value type"
  "*UNUSED*
 (deffailure-var-test
  "Blank line - after value type"
  "*UNUSED*


@@ -672,3 +759,103 @@ VALUE TYPE:
 
   a generalized boolean"
  "Got unexpected line, requires blank lines or start with two spaces: NIL")
 
   a generalized boolean"
  "Got unexpected line, requires blank lines or start with two spaces: NIL")

+
+(deffailure-var-test
+ "General - Can't end line with a space"
+ "*UNUSED*
+
+VALUE TYPE:
+
+  a generalized boolean
+
+INITIAL VALUE:
+
+  NIL
+
+DESCRIPTION:
+
+  This description line ends with a space "
+ "Can't end line with a space:   This description line ends with a space ")
+
+(deffailure-var-test
+ "General - Longer than 120 characters"
+ (format nil "~A~A"
+  "*UNUSED*
+
+VALUE TYPE:
+
+  a generalized boolean
+
+INITIAL VALUE:
+
+  NIL
+
+DESCRIPTION:
+
+  This description line ends with a space is very very long, so very long, really really long"
+  "it just keeps going and going and going and going and going and going")
+ (format nil "Longer than 120 chars:   ~A~A"
+  "This description line ends with a space is very very long, so very long, really really long"
+  "it just keeps going and going and going and going and going and going"))
+
+(deffailure-pkg-test
+ "Line too long"
+ "Unused package with a first line that is extremely long, and how could it be so
+long and it keeps going and going and going and going and going and going"
+ "First package paragraph is longer than 120 characters")
+
+(deffailure-pkg-test
+ "Line too long 2"
+ (format nil "~A~A"
+  "Unused package with a first line that is extremely long, and how could it be so"
+  "long and it keeps going and going and going and going and going and going")
+ (format nil "~A~A~A"
+  "Package description longer than 120 characters: "
+  "Unused package with a first line that is extremely long, and how could it be so"
+  "long and it keeps going and going and going and going and going and going"))
+
+(deffailure-pkg-test
+ "Two empty lines"
+ "Basic description
+
+
+More information"
+ "Package description has two empty lines in it")
+
+(deffailure-pkg-test
+ "Started with space"
+ " Basic Description"
+ "Package description line started with space:  Basic Description")
+
+(deffailure-pkg-test
+ "Ended with space"
+ "Basic Description "
+ "Package description line ended with space: Basic Description ")
+
+(deffailure-struc-test
+ "Two empty lines"
+ "Basic description
+
+
+More information"
+ "Structure description has two empty lines in it")
+
+(deffailure-struc-test
+ "Line too long"
+ (format nil "~A~A"
+  "Unused package with a first line that is extremely long, and how could it be so"
+  "long and it keeps going and going and going and going and going and going")
+ (format nil "~A~A~A"
+  "Structure description longer than 120 characters: "
+  "Unused package with a first line that is extremely long, and how could it be so"
+  "long and it keeps going and going and going and going and going and going"))
+
+(deffailure-struc-test
+ "Started with space"
+ " Basic Description"
+ "Structure description line started with space:  Basic Description")
+
+(deffailure-struc-test
+ "Ended with space"
+ "Basic Description "
+ "Structure description line ended with space: Basic Description ")

diff --git a/src/test/main.lisp b/src/test/main.lisp
index 9db1bc74d7c5ee3441785c8ccddac5e66b5fcdf9..4c5deded542901b9dfd567975039e542448608f1 100644 (file)
--- a/src/test/main.lisp
+++ b/src/test/main.lisp
@@ -1,7 +1,10 @@
 ; Copyright 2022 Frank Duncan (frank@consxy.com) under AGPL3.  See distributed LICENSE.txt.
 (in-package #:sheep-test)
 
 ; Copyright 2022 Frank Duncan (frank@consxy.com) under AGPL3.  See distributed LICENSE.txt.
 (in-package #:sheep-test)
 

-(defvar *tests* nil)
+(defparameter *tests* nil)
+
+; Used just for tests
+(defstruct unused-struc)

 
 ; This really is just here to check against regressions
 (defun run-all-tests ()
 
 ; This really is just here to check against regressions
 (defun run-all-tests ()


@@ -34,6 +37,7 @@
     (handler-case
      (progn
       (load ,source)
     (handler-case
      (progn
       (load ,source)

+      (sheep:pretty-print-validate-packages ,pkg)

       (string= (slurp-file ,target) (sheep:export-package ,pkg)))
      (sheep:validation-failure (vf)
       (format t "Validation failure gotten: ~A~%"
       (string= (slurp-file ,target) (sheep:export-package ,pkg)))
      (sheep:validation-failure (vf)
       (format t "Validation failure gotten: ~A~%"


@@ -47,6 +51,10 @@
      (load ,source)
      (let
       ((result (sheep:validate-package ,pkg)))
      (load ,source)
      (let
       ((result (sheep:validate-package ,pkg)))

+      (let
+       ((*error-output* (make-broadcast-stream))
+        (*standard-output* (make-broadcast-stream)))
+       (sheep:pretty-print-validate-packages ,pkg))

       (or
        (equal ,expected result)
        (format t "  Got error:~%~S~%  but expected~%~S~%" result ,expected)))))))
       (or
        (equal ,expected result)
        (format t "  Got error:~%~S~%  but expected~%~S~%" result ,expected)))))))


@@ -57,10 +65,8 @@
    (lambda ()
     (handler-case
      (progn
    (lambda ()
     (handler-case
      (progn

-      (funcall
-       (symbol-function (find-symbol "INTERNAL-DOC->AST" :sheep-func))
-       'unused
-       ,doc)
+      (setf (documentation 'unused 'function) ,doc)
+      (sheep-func:doc->ast 'unused)

       nil)
      (sheep:validation-failure (vf)
       (let
       nil)
      (sheep:validation-failure (vf)
       (let


@@ -75,10 +81,40 @@
    (lambda ()
     (handler-case
      (progn
    (lambda ()
     (handler-case
      (progn

-      (funcall
-       (symbol-function (find-symbol "INTERNAL-DOC->AST" :sheep-var))
-       '*unused*
-       ,doc)
+      (setf (documentation '*unused* 'variable) ,doc)
+      (sheep-var:doc->ast '*unused*)
+      nil)
+     (sheep:validation-failure (vf)
+      (let
+       ((result (funcall (symbol-function (find-symbol "VALIDATION-FAILURE-MSG" :sheep)) vf)))
+       (or
+        (string= ,expected result)
+        (format t "  Got error:~%~S~%  but expected~%~S~%" result ,expected))))))))
+
+(defmacro deffailure-pkg-test (name doc expected)
+ `(deftest
+   ,(format nil "Package - ~A" name)
+   (lambda ()
+    (handler-case
+     (progn
+      (setf (documentation (find-package :sheep-unused) t) ,doc)
+      (sheep-pkg:doc->ast (find-package :sheep-unused))
+      nil)
+     (sheep:validation-failure (vf)
+      (let
+       ((result (funcall (symbol-function (find-symbol "VALIDATION-FAILURE-MSG" :sheep)) vf)))
+       (or
+        (string= ,expected result)
+        (format t "  Got error:~%~S~%  but expected~%~S~%" result ,expected))))))))
+
+(defmacro deffailure-struc-test (name doc expected)
+ `(deftest
+   ,(format nil "Struct - ~A" name)
+   (lambda ()
+    (handler-case
+     (progn
+      (setf (documentation 'unused-struc 'structure) ,doc)
+      (sheep-struc:doc->ast 'unused-struc)

       nil)
      (sheep:validation-failure (vf)
       (let
       nil)
      (sheep:validation-failure (vf)
       (let

diff --git a/src/test/package.lisp b/src/test/package.lisp
index 39b83edd6b14fe62d397c3068fb598a3490e5b29..e8780275b6bfc3a235041d896443f31b9af36711 100644 (file)
--- a/src/test/package.lisp
+++ b/src/test/package.lisp
@@ -1,3 +1,6 @@
 ; Copyright 2022 Frank Duncan (frank@consxy.com) under AGPL3.  See distributed LICENSE.txt.
 (defpackage #:sheep-test (:use :common-lisp)
  (:export :run-all-tests))
 ; Copyright 2022 Frank Duncan (frank@consxy.com) under AGPL3.  See distributed LICENSE.txt.
 (defpackage #:sheep-test (:use :common-lisp)
  (:export :run-all-tests))

+
+; This package is for testing documentation of packages
+(defpackage #:sheep-unused)