core: subseq-index? -> subseq-of?

[factor.git] / basis / help / lint / checks / checks.factor

diff --git a/basis/help/lint/checks/checks.factor b/basis/help/lint/checks/checks.factor
index b94aa677d7ddf4bb3311496d502314f163ced2d6..dfac066116ed37f08d15db58316d03423f9f8fb9 100644 (file)
--- a/basis/help/lint/checks/checks.factor
+++ b/basis/help/lint/checks/checks.factor
@@ -2,10 +2,10 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs classes classes.struct
 classes.tuple combinators combinators.short-circuit debugger
-definitions effects eval formatting fry grouping help
-help.markup help.topics io io.streams.string kernel macros math
-namespaces sequences sequences.deep sets splitting strings
-summary tools.destructors unicode.categories vocabs
+definitions effects eval formatting grouping help help.markup
+help.topics io io.streams.string kernel macros math
+math.statistics namespaces prettyprint sequences sequences.deep
+sets splitting strings summary tools.destructors unicode vocabs
 vocabs.loader words words.constant words.symbol ;
 IN: help.lint.checks
 
@@ -16,22 +16,42 @@ M: simple-lint-error summary message>> ;
 M: simple-lint-error error. summary print ;
 
 SYMBOL: vocabs-quot
-SYMBOL: all-vocabs-list
 SYMBOL: vocab-articles
 
+: no-ui-disposables ( seq -- seq' )
+    [
+        class-of name>> {
+            "single-texture" "multi-texture" ! opengl.textures
+            "line" ! core-text
+            "layout" ! ui.text.pango
+            "script-string" ! windows.uniscribe
+            "linux-monitor" ! github issue #2014, race condition in disposing of child monitors
+            "event-stream"
+            "macosx-monitor"
+            "recursive-monitor"
+            "input-port"
+            "malloc-ptr"
+            "fd"
+        } member?
+    ] reject ;
+
 : check-example ( element -- )
     [
         '[
             _ rest [
-                but-last "\n" join
-                [ (eval>string) ] call( code -- output )
+                but-last join-lines
+                (eval-with-stack>string)
                 "\n" ?tail drop
             ] keep
             last assert=
         ] vocabs-quot get call( quot -- )
-    ] leaks members length [
-        "%d disposable(s) leaked in example" sprintf throw-simple-lint-error
-    ] unless-zero ;
+    ] leaks members no-ui-disposables
+    dup length 0 > [
+       dup [ class-of ] histogram-by
+       [ "Leaked resources: " write ... ] with-string-writer simple-lint-error
+    ] [
+        drop
+    ] if ;
 
 : check-examples ( element -- )
     \ $example swap elements [ check-example ] each ;
@@ -78,6 +98,7 @@ SYMBOL: vocab-articles
         [ parsing-word? ]
         [ "declared-effect" word-prop not ]
         [ constant? ]
+        [ "help" word-prop not ]
     } 1|| ;
 
 : skip-check-values? ( word element -- ? )
@@ -88,7 +109,7 @@ SYMBOL: vocab-articles
         [ effect-values ] [ extract-values ] bi* 2dup
         sequence= [ 2drop ] [
             "$values don't match stack effect; expected %u, got %u" sprintf
-            throw-simple-lint-error
+            simple-lint-error
         ] if
     ] if ;
 
@@ -96,30 +117,26 @@ SYMBOL: vocab-articles
     [ effect-effects ] [ extract-value-effects ] bi*
     [ 2dup and [ = ] [ 2drop t ] if ] 2all? [
         "$quotation stack effects in $values don't match"
-        throw-simple-lint-error
+        simple-lint-error
     ] unless ;
 
-: check-nulls ( element -- )
-    \ $values swap elements
-    null swap deep-member?
-    [ "$values should not contain null" throw-simple-lint-error ] when ;
-
 : check-see-also ( element -- )
     \ $see-also swap elements [ rest all-unique? ] all?
-    [ "$see-also are not unique" throw-simple-lint-error ] unless ;
-
-: vocab-exists? ( name -- ? )
-    [ lookup-vocab ] [ all-vocabs-list get member? ] bi or ;
+    [ "$see-also are not unique" simple-lint-error ] unless ;
 
 : check-modules ( element -- )
     \ $vocab-link swap elements [
         second
         vocab-exists? [
             "$vocab-link to non-existent vocabulary"
-            throw-simple-lint-error
+            simple-lint-error
         ] unless
     ] each ;
 
+: check-slots-tables ( element -- )
+    \ $slots swap elements [ rest [ length 2 = ] all?  ] all?
+    [ "$slots have too many values in at least one row" simple-lint-error ] unless ;
+
 : check-rendering ( element -- )
     [ print-content ] with-string-writer drop ;
 
@@ -127,23 +144,23 @@ SYMBOL: vocab-articles
     [
         "\n\t" intersects? [
             "Paragraph text should not contain \\n or \\t"
-            throw-simple-lint-error
+            simple-lint-error
         ] when
     ] [
-        "  " swap subseq? [
+        "  " subseq-of? [
             "Paragraph text should not contain double spaces"
-            throw-simple-lint-error
+            simple-lint-error
         ] when
     ] bi ;
 
 : check-whitespace ( str1 str2 -- )
     [ " " tail? ] [ " " head? ] bi* or
-    [ "Missing whitespace between strings" throw-simple-lint-error ] unless ;
+    [ "Missing whitespace between strings" simple-lint-error ] unless ;
 
 : check-bogus-nl ( element -- )
     { { $nl } { { $nl } } } [ head? ] with any? [
         "Simple element should not begin with a paragraph break"
-        throw-simple-lint-error
+        simple-lint-error
     ] when ;
 
 : extract-slots ( elements -- seq )
@@ -158,18 +175,18 @@ SYMBOL: vocab-articles
         ] [ extract-slots ] bi*
         [ swap member? ] with reject [
             ", " join "Described $slot does not exist: " prepend
-            throw-simple-lint-error
+            simple-lint-error
         ] unless-empty
     ] [
         nip empty? not [
             "A word that is not a class has a $class-description"
-            throw-simple-lint-error
+            simple-lint-error
         ] when
     ] if ;
 
 : check-article-title ( article -- )
     article-title first LETTER?
-    [ "Article title must begin with a capital letter" throw-simple-lint-error ] unless ;
+    [ "Article title must begin with a capital letter" simple-lint-error ] unless ;
 
 : check-elements ( element -- )
     {
@@ -184,7 +201,7 @@ SYMBOL: vocab-articles
     swap '[
         _ elements [
             rest { { } { "" } } member?
-            [ "Empty $description" throw-simple-lint-error ] when
+            [ "Empty $description" simple-lint-error ] when
         ] each
     ] each ;
 
@@ -195,6 +212,7 @@ SYMBOL: vocab-articles
         [ check-examples ]
         [ check-modules ]
         [ check-descriptions ]
+        [ check-slots-tables ]
     } cleave ;
 
 : files>vocabs ( -- assoc )