Working on adding help-lint errors to error list

basis/help/lint/checks/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/help/lint/checks/checks.factor

@@ -0,0 +1,176 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs classes combinators
+combinators.short-circuit definitions effects eval fry grouping
+help help.markup help.topics io.streams.string kernel macros
+namespaces sequences sequences.deep sets sorting splitting
+strings unicode.categories values vocabs vocabs.loader words
+words.symbol summary debugger io ;
+IN: help.lint.checks
+
+ERROR: simple-lint-error message ;
+
+M: simple-lint-error summary message>> ;
+
+M: simple-lint-error error. summary print ;
+
+SYMBOL: vocabs-quot
+SYMBOL: all-vocabs
+SYMBOL: vocab-articles
+
+: check-example ( element -- )
+    '[
+        _ rest [
+            but-last "\n" join
+            [ (eval>string) ] call( code -- output )
+            "\n" ?tail drop
+        ] keep
+        peek assert=
+    ] vocabs-quot get call( quot -- ) ;
+
+: check-examples ( element -- )
+    \ $example swap elements [ check-example ] each ;
+
+: extract-values ( element -- seq )
+    \ $values swap elements dup empty? [
+        first rest [ first ] map prune natural-sort
+    ] unless ;
+
+: effect-values ( word -- seq )
+    stack-effect
+    [ in>> ] [ out>> ] bi append
+    [ dup pair? [ first ] when effect>string ] map
+    prune natural-sort ;
+
+: contains-funky-elements? ( element -- ? )
+    {
+        $shuffle
+        $values-x/y
+        $predicate
+        $class-description
+        $error-description
+    } swap '[ _ elements empty? not ] any? ;
+
+: don't-check-word? ( word -- ? )
+    {
+        [ macro? ]
+        [ symbol? ]
+        [ value-word? ]
+        [ parsing-word? ]
+        [ "declared-effect" word-prop not ]
+    } 1|| ;
+
+: check-values ( word element -- )
+    {
+        [
+            [ don't-check-word? ]
+            [ contains-funky-elements? ]
+            bi* or
+        ] [
+            [ effect-values ]
+            [ extract-values ]
+            bi* sequence=
+        ]
+    } 2|| [ "$values don't match stack effect" simple-lint-error ] unless ;
+
+: check-nulls ( element -- )
+    \ $values swap elements
+    null swap deep-member?
+    [ "$values should not contain null" simple-lint-error ] when ;
+
+: check-see-also ( element -- )
+    \ $see-also swap elements [
+        rest dup prune [ length ] bi@ assert=
+    ] each ;
+
+: vocab-exists? ( name -- ? )
+    [ vocab ] [ all-vocabs get member? ] bi or ;
+
+: check-modules ( element -- )
+    \ $vocab-link swap elements [
+        second
+        vocab-exists? [
+            "$vocab-link to non-existent vocabulary"
+            simple-lint-error
+        ] unless
+    ] each ;
+
+: check-rendering ( element -- )
+    [ print-content ] with-string-writer drop ;
+
+: check-strings ( str -- )
+    [
+        "\n\t" intersects? [
+            "Paragraph text should not contain \\n or \\t"
+            simple-lint-error
+        ] when
+    ] [
+        "  " swap subseq? [
+            "Paragraph text should not contain double spaces"
+            simple-lint-error
+        ] when
+    ] bi ;
+
+: check-whitespace ( str1 str2 -- )
+    [ " " tail? ] [ " " head? ] bi* or
+    [ "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"
+        simple-lint-error
+    ] when ;
+
+: check-class-description ( word element -- )
+    [ class? not ]
+    [ { $class-description } swap elements empty? not ] bi* and
+    [ "A word that is not a class has a $class-description" throw ] when ;
+
+: check-article-title ( article -- )
+    article-title first LETTER?
+    [ "Article title must begin with a capital letter" throw ] unless ;
+
+: check-elements ( element -- )
+    {
+        [ check-bogus-nl ]
+        [ [ string? ] filter [ check-strings ] each ]
+        [ [ simple-element? ] filter [ check-elements ] each ]
+        [ 2 <clumps> [ [ string? ] all? ] filter [ first2 check-whitespace ] each ]
+    } cleave ;
+
+: check-descriptions ( element -- )
+    { $description $class-description $var-description }
+    swap '[
+        _ elements [
+            rest { { } { "" } } member?
+            [ "Empty description" throw ] when
+        ] each
+    ] each ;
+
+: check-markup ( element -- )
+    {
+        [ check-elements ]
+        [ check-rendering ]
+        [ check-examples ]
+        [ check-modules ]
+        [ check-descriptions ]
+    } cleave ;
+
+: files>vocabs ( -- assoc )
+    vocabs
+    [ [ [ vocab-docs-path ] keep ] H{ } map>assoc ]
+    [ [ [ vocab-source-path ] keep ] H{ } map>assoc ]
+    bi assoc-union ;
+
+: group-articles ( -- assoc )
+    articles get keys
+    files>vocabs
+    H{ } clone [
+        '[
+            dup >link where dup
+            [ first _ at _ push-at ] [ 2drop ] if
+        ] each
+    ] keep ;
+
+: all-word-help ( words -- seq )
+    [ word-help ] filter ;

basis/help/lint/lint.factor

@@ -1,156 +1,39 @@
 ! Copyright (C) 2006, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: fry accessors sequences parser kernel help help.markup
+USING: assocs continuations fry help help.lint.checks
-help.topics words strings classes tools.vocabs namespaces make
+help.topics io kernel namespaces parser sequences
-io io.streams.string prettyprint definitions arrays vectors
+source-files.errors tools.vocabs vocabs words classes
-combinators combinators.short-circuit splitting debugger
+locals ;
-hashtables sorting effects vocabs vocabs.loader assocs editors
-continuations classes.predicate macros math sets eval
-vocabs.parser words.symbol values grouping unicode.categories
-sequences.deep ;
 IN: help.lint
 
-SYMBOL: vocabs-quot
+SYMBOL: lint-failures
 
-: check-example ( element -- )
+lint-failures [ H{ } clone ] initialize
-    '[
-        _ rest [
-            but-last "\n" join
-            [ (eval>string) ] call( code -- output )
-            "\n" ?tail drop
-        ] keep
-        peek assert=
-    ] vocabs-quot get call( quot -- ) ;
 
-: check-examples ( element -- )
+TUPLE: help-lint-error < source-file-error ;
-    \ $example swap elements [ check-example ] each ;
 
-: extract-values ( element -- seq )
+SYMBOL: +help-lint-failure+
-    \ $values swap elements dup empty? [
-        first rest [ first ] map prune natural-sort
-    ] unless ;
 
-: effect-values ( word -- seq )
+M: help-lint-error source-file-error-type drop +help-lint-failure+ ;
-    stack-effect
-    [ in>> ] [ out>> ] bi append
-    [ dup pair? [ first ] when effect>string ] map
-    prune natural-sort ;
 
-: contains-funky-elements? ( element -- ? )
+<PRIVATE
-    {
-        $shuffle
-        $values-x/y
-        $predicate
-        $class-description
-        $error-description
-    } swap '[ _ elements empty? not ] any? ;
 
-: don't-check-word? ( word -- ? )
+: <help-lint-error> ( error topic -- help-lint-error )
-    {
+    \ help-lint-error <definition-error> ;
-        [ macro? ]
-        [ symbol? ]
-        [ value-word? ]
-        [ parsing-word? ]
-        [ "declared-effect" word-prop not ]
-    } 1|| ;
 
-: check-values ( word element -- )
+PRIVATE>
-    {
-        [
-            [ don't-check-word? ]
-            [ contains-funky-elements? ]
-            bi* or
-        ] [
-            [ effect-values ]
-            [ extract-values ]
-            bi* sequence=
-        ]
-    } 2|| [ "$values don't match stack effect" throw ] unless ;
 
-: check-nulls ( element -- )
+: help-lint-error ( error topic -- )
-    \ $values swap elements
+    over [
-    null swap deep-member?
+        [ <help-lint-error> ] keep
-    [ "$values should not contain null" throw ] when ;
+        lint-failures get set-at
+    ] [ nip lint-failures get delete-at ] if ;
 
-: check-see-also ( element -- )
+<PRIVATE
-    \ $see-also swap elements [
-        rest dup prune [ length ] bi@ assert=
-    ] each ;
 
-: vocab-exists? ( name -- ? )
+:: check-something ( topic quot -- )
-    [ vocab ] [ "all-vocabs" get member? ] bi or ;
+    [ quot call( -- ) f ] [ ] recover
-
+    topic help-lint-error ; inline
-: check-modules ( element -- )
-    \ $vocab-link swap elements [
-        second
-        vocab-exists? [ "$vocab-link to non-existent vocabulary" throw ] unless
-    ] each ;
-
-: check-rendering ( element -- )
-    [ print-content ] with-string-writer drop ;
-
-: check-strings ( str -- )
-    [
-        "\n\t" intersects?
-        [ "Paragraph text should not contain \\n or \\t" throw ] when
-    ] [
-        "  " swap subseq?
-        [ "Paragraph text should not contain double spaces" throw ] when
-    ] bi ;
-
-: check-whitespace ( str1 str2 -- )
-    [ " " tail? ] [ " " head? ] bi* or
-    [ "Missing whitespace between strings" throw ] unless ;
-
-: check-bogus-nl ( element -- )
-    { { $nl } { { $nl } } } [ head? ] with any?
-    [ "Simple element should not begin with a paragraph break" throw ] when ;
-
-: check-elements ( element -- )
-    {
-        [ check-bogus-nl ]
-        [ [ string? ] filter [ check-strings ] each ]
-        [ [ simple-element? ] filter [ check-elements ] each ]
-        [ 2 <clumps> [ [ string? ] all? ] filter [ first2 check-whitespace ] each ]
-    } cleave ;
-
-: check-descriptions ( element -- )
-    { $description $class-description $var-description }
-    swap '[
-        _ elements [
-            rest { { } { "" } } member?
-            [ "Empty description" throw ] when
-        ] each
-    ] each ;
-
-: check-markup ( element -- )
-    {
-        [ check-elements ]
-        [ check-rendering ]
-        [ check-examples ]
-        [ check-modules ]
-        [ check-descriptions ]
-    } cleave ;
-
-: check-class-description ( word element -- )
-    [ class? not ]
-    [ { $class-description } swap elements empty? not ] bi* and
-    [ "A word that is not a class has a $class-description" throw ] when ;
-
-: all-word-help ( words -- seq )
-    [ word-help ] filter ;
-
-TUPLE: help-error error topic ;
-
-C: <help-error> help-error
-
-M: help-error error.
-    [ "In " write topic>> pprint nl ]
-    [ error>> error. ]
-    bi ;
-
-: check-something ( obj quot -- )
-    flush '[ _ call( -- ) ] swap '[ _ <help-error> , ] recover ; inline
 
 : check-word ( word -- )
     [ with-file-vocabs ] vocabs-quot set
@@ -165,67 +48,35 @@ M: help-error error.
 
 : check-words ( words -- ) [ check-word ] each ;
 
-: check-article-title ( article -- )
-    article-title first LETTER?
-    [ "Article title must begin with a capital letter" throw ] unless ;
-
 : check-article ( article -- )
     [ with-interactive-vocabs ] vocabs-quot set
-    dup '[
+    >link dup '[
         _
         [ check-article-title ]
         [ article-content check-markup ] bi
     ] check-something ;
 
-: files>vocabs ( -- assoc )
-    vocabs
-    [ [ [ vocab-docs-path ] keep ] H{ } map>assoc ]
-    [ [ [ vocab-source-path ] keep ] H{ } map>assoc ]
-    bi assoc-union ;
-
-: group-articles ( -- assoc )
-    articles get keys
-    files>vocabs
-    H{ } clone [
-        '[
-            dup >link where dup
-            [ first _ at _ push-at ] [ 2drop ] if
-        ] each
-    ] keep ;
-
 : check-about ( vocab -- )
     dup '[ _ vocab-help [ article drop ] when* ] check-something ;
 
-: check-vocab ( vocab -- seq )
+: check-vocab ( vocab -- )
     "Checking " write dup write "..." print
-    [
+    vocab
     [ check-about ]
     [ words [ check-word ] each ]
-        [ "vocab-articles" get at [ check-article ] each ]
+    [ vocab-articles get at [ check-article ] each ]
-        tri
+    tri ;
-    ] { } make ;
 
-: run-help-lint ( prefix -- alist )
+PRIVATE>
+
+: help-lint ( prefix -- )
     [
-        all-vocabs-seq [ vocab-name ] map "all-vocabs" set
+        all-vocabs-seq [ vocab-name ] map all-vocabs set
-        group-articles "vocab-articles" set
+        group-articles vocab-articles set
         child-vocabs
-        [ dup check-vocab ] { } map>assoc
+        [ check-vocab ] each
-        [ nip empty? not ] assoc-filter
     ] with-scope ;
 
-: typos. ( assoc -- )
-    [
-        "==== ALL CHECKS PASSED" print
-    ] [
-        [
-            swap vocab-heading.
-            [ print-error nl ] each
-        ] assoc-each
-    ] if-empty ;
-
-: help-lint ( prefix -- ) run-help-lint typos. ;
-
 : help-lint-all ( -- ) "" help-lint ;
 
 : unlinked-words ( words -- seq )
@@ -235,6 +86,6 @@ M: help-error error.
     all-words
     [ word-help not ] filter
     [ article-parent ] filter
-    [ "predicating" word-prop not ] filter ;
+    [ predicate? not ] filter ;
 
 MAIN: help-lint

basis/tools/test/test.factor

@@ -99,7 +99,7 @@ SYNTAX: TEST:
 
 : run-test-file ( path -- )
     dup file [
-        test-failures get [ file>> file get = not ] filter-here
+        test-failures get file get +test-failure+ delete-file-errors
         '[ _ run-file ] [ file-failure ] recover
     ] with-variable ;
 

basis/ui/tools/error-list/error-list-docs.factor

@@ -4,7 +4,8 @@ USING: help.markup help.syntax ;
 ARTICLE: "ui.tools.error-list" "UI error list tool"
 "The error list tool displays messages generated by tools which process source files and definitions."
 $nl
-"The different types of messages displayed:"
+"The " { $vocab-link "source-files.errors" } " vocabulary contains backend code used by this tool."
+{ $heading "Message icons" }
 { $table
     { "Icon" "Message type" "Reference" }
     { { $image "vocab:ui/tools/error-list/icons/note.tiff" } "Parser note" { $link "parser" } }
@@ -14,7 +15,6 @@ $nl
     { { $image "vocab:ui/tools/error-list/icons/unit-test-error.tiff" } "Unit test failure" { $link "tools.test" } }
     { { $image "vocab:ui/tools/error-list/icons/help-lint-error.tiff" } "Help lint failure" { $link "help.lint" } }
     { { $image "vocab:ui/tools/error-list/icons/linkage-error.tiff" } "Linkage error" { $link "compiler-errors" } }
-}
+} ;
-"The " { $vocab-link "source-files.errors" } " vocabulary contains backend code used by this tool." ;
 
 ABOUT: "ui.tools.error-list"

basis/ui/tools/error-list/error-list.factor

@@ -1,17 +1,17 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays sequences sorting assocs colors.constants fry
-combinators combinators.smart combinators.short-circuit editors memoize
+combinators combinators.smart combinators.short-circuit editors make
-compiler.errors compiler.units fonts kernel io.pathnames prettyprint
+memoize compiler.errors compiler.units fonts kernel io.pathnames
-tools.test stack-checker.errors source-files.errors math.parser
+prettyprint tools.test help.lint stack-checker.errors
-math.order models models.arrow models.arrow.smart models.search
+source-files.errors math.parser init math.order models models.arrow
-models.mapping debugger namespaces summary locals ui ui.commands
+models.arrow.smart models.search models.mapping debugger namespaces
-ui.gadgets ui.gadgets.panes ui.gadgets.tables ui.gadgets.labeled
+summary locals ui ui.commands ui.gadgets ui.gadgets.panes
-ui.gadgets.tracks ui.gestures ui.operations ui.tools.browser
+ui.gadgets.tables ui.gadgets.labeled ui.gadgets.tracks ui.gestures
-ui.tools.common ui.gadgets.scrollers ui.tools.inspector
+ui.operations ui.tools.browser ui.tools.common ui.gadgets.scrollers
-ui.gadgets.status-bar ui.operations ui.gadgets.buttons
+ui.tools.inspector ui.gadgets.status-bar ui.operations
-ui.gadgets.borders ui.gadgets.packs ui.gadgets.labels
+ui.gadgets.buttons ui.gadgets.borders ui.gadgets.packs
-ui.baseline-alignment ui.images ;
+ui.gadgets.labels ui.baseline-alignment ui.images ;
 IN: ui.tools.error-list
 
 CONSTANT: error-types
@@ -19,6 +19,7 @@ CONSTANT: error-types
         +compiler-warning+
         +compiler-error+
         +test-failure+
+        +help-lint-failure+
         +linkage-error+
     }
 
@@ -29,8 +30,9 @@ MEMO: error-list-icon ( object -- object )
     {
         { +compiler-error+ [ "compiler-error" ] }
         { +compiler-warning+ [ "compiler-warning" ] }
-        { +linkage-error+ [ "linkage-error" ] }
         { +test-failure+ [ "unit-test-error" ] }
+        { +help-lint-failure+ [ "help-lint-error" ] }
+        { +linkage-error+ [ "linkage-error" ] }
     } case error-list-icon ;
 
 : <checkboxes> ( alist -- gadget )
@@ -79,8 +81,8 @@ M: source-file-renderer filled-column drop 1 ;
         [ invoke-primary-operation ] >>action
         COLOR: dark-gray >>column-line-color
         6 >>gap
-        30 >>min-rows
+        10 >>min-rows
-        30 >>max-rows
+        10 >>max-rows
         60 >>min-cols
         60 >>max-cols
         t >>selection-required?
@@ -124,8 +126,8 @@ M: error-renderer column-alignment drop { 0 1 0 0 } ;
         [ invoke-primary-operation ] >>action
         COLOR: dark-gray >>column-line-color
         6 >>gap
-        30 >>min-rows
+        20 >>min-rows
-        30 >>max-rows
+        20 >>max-rows
         60 >>min-cols
         60 >>max-cols
         t >>selection-required?
@@ -197,13 +199,18 @@ SINGLETON: updater
 
 M: updater definitions-changed
     2drop
-    compiler-errors get-global values
+    [
-    test-failures get-global append
+        compiler-errors get-global values %
+        test-failures get-global %
+        lint-failures get-global values %
+    ] { } make
     compiler-error-model get-global
     set-model ;
 
+[
     updater remove-definition-observer
     updater add-definition-observer
+] "ui.tools.error-list" add-init-hook
 
 : error-list-window ( -- )
     compiler-error-model get-global <error-list-gadget>

core/compiler/errors/errors.factor

@@ -41,11 +41,7 @@ SYMBOL: with-compiler-errors?
     "linkage errors" +linkage-error+ "linkage" (compiler-report) ;
 
 : <compiler-error> ( error word -- compiler-error )
-    \ compiler-error new
+    \ compiler-error <definition-error> ;
-        swap
-        [ >>asset ]
-        [ where [ first2 ] [ "<unknown file>" 0 ] if* [ >>file ] [ >>line# ] bi* ] bi
-        swap >>error ;
 
 : compiler-error ( error word -- )
     compiler-errors get-global pick

core/source-files/errors/errors.factor

@@ -1,14 +1,30 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs kernel math.order sorting sequences ;
+USING: accessors assocs kernel math.order sorting sequences definitions ;
 IN: source-files.errors
 
 TUPLE: source-file-error error asset file line# ;
 
-: sort-errors ( errors -- alerrors'ist )
+: sort-errors ( errors -- alist )
     [ [ [ line#>> ] compare ] sort ] { } assoc-map-as sort-keys ;
 
 : group-by-source-file ( errors -- assoc )
     H{ } clone [ [ push-at ] curry [ dup file>> ] prepose each ] keep ;
 
 GENERIC: source-file-error-type ( error -- type )
+
+: <definition-error> ( error definition class -- source-file-error )
+    new
+        swap
+        [ >>asset ]
+        [
+            where [ first2 ] [ "<unknown file>" 0 ] if*
+            [ >>file ] [ >>line# ] bi*
+        ] bi
+        swap >>error ; inline
+
+: delete-file-errors ( seq file type -- )
+    [
+        [ swap file>> = ] [ swap source-file-error-type = ]
+        bi-curry* bi and not
+    ] 2curry filter-here ;