--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! 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 ;
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: fry accessors sequences parser kernel help help.markup
-help.topics words strings classes tools.vocabs namespaces make
-io io.streams.string prettyprint definitions arrays vectors
-combinators combinators.short-circuit splitting debugger
-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 ;
+USING: assocs continuations fry help help.lint.checks
+help.topics io kernel namespaces parser sequences
+source-files.errors tools.vocabs vocabs words classes
+locals ;
IN: help.lint
-SYMBOL: vocabs-quot
-
-: 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" throw ] unless ;
-
-: check-nulls ( element -- )
- \ $values swap elements
- null swap deep-member?
- [ "$values should not contain null" throw ] 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" 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
+SYMBOL: lint-failures
+
+lint-failures [ H{ } clone ] initialize
+
+TUPLE: help-lint-error < source-file-error ;
+
+SYMBOL: +help-lint-failure+
+
+M: help-lint-error source-file-error-type drop +help-lint-failure+ ;
+
+<PRIVATE
+
+: <help-lint-error> ( error topic -- help-lint-error )
+ \ help-lint-error <definition-error> ;
+
+PRIVATE>
+
+: help-lint-error ( error topic -- )
+ over [
+ [ <help-lint-error> ] keep
+ lint-failures get set-at
+ ] [ nip lint-failures get delete-at ] if ;
+
+<PRIVATE
+
+:: check-something ( topic quot -- )
+ [ quot call( -- ) f ] [ ] recover
+ topic help-lint-error ; inline
: check-word ( word -- )
[ with-file-vocabs ] vocabs-quot set
: 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
- [
- [ check-about ]
- [ words [ check-word ] each ]
- [ "vocab-articles" get at [ check-article ] each ]
- tri
- ] { } make ;
+ vocab
+ [ check-about ]
+ [ words [ check-word ] each ]
+ [ vocab-articles get at [ check-article ] each ]
+ tri ;
-: run-help-lint ( prefix -- alist )
+PRIVATE>
+
+: help-lint ( prefix -- )
[
- all-vocabs-seq [ vocab-name ] map "all-vocabs" set
- group-articles "vocab-articles" set
+ all-vocabs-seq [ vocab-name ] map all-vocabs set
+ group-articles vocab-articles set
child-vocabs
- [ dup check-vocab ] { } map>assoc
- [ nip empty? not ] assoc-filter
+ [ check-vocab ] each
] 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 )
all-words
[ word-help not ] filter
[ article-parent ] filter
- [ "predicating" word-prop not ] filter ;
+ [ predicate? not ] filter ;
MAIN: help-lint
: 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 ;
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" } }
{ { $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"
! 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
-compiler.errors compiler.units fonts kernel io.pathnames prettyprint
-tools.test stack-checker.errors source-files.errors math.parser
-math.order models models.arrow models.arrow.smart models.search
-models.mapping debugger namespaces summary locals ui ui.commands
-ui.gadgets ui.gadgets.panes ui.gadgets.tables ui.gadgets.labeled
-ui.gadgets.tracks ui.gestures ui.operations ui.tools.browser
-ui.tools.common ui.gadgets.scrollers ui.tools.inspector
-ui.gadgets.status-bar ui.operations ui.gadgets.buttons
-ui.gadgets.borders ui.gadgets.packs ui.gadgets.labels
-ui.baseline-alignment ui.images ;
+combinators combinators.smart combinators.short-circuit editors make
+memoize compiler.errors compiler.units fonts kernel io.pathnames
+prettyprint tools.test help.lint stack-checker.errors
+source-files.errors math.parser init math.order models models.arrow
+models.arrow.smart models.search models.mapping debugger namespaces
+summary locals ui ui.commands ui.gadgets ui.gadgets.panes
+ui.gadgets.tables ui.gadgets.labeled ui.gadgets.tracks ui.gestures
+ui.operations ui.tools.browser ui.tools.common ui.gadgets.scrollers
+ui.tools.inspector ui.gadgets.status-bar ui.operations
+ui.gadgets.buttons ui.gadgets.borders ui.gadgets.packs
+ui.gadgets.labels ui.baseline-alignment ui.images ;
IN: ui.tools.error-list
CONSTANT: error-types
+compiler-warning+
+compiler-error+
+test-failure+
+ +help-lint-failure+
+linkage-error+
}
{
{ +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 )
[ invoke-primary-operation ] >>action
COLOR: dark-gray >>column-line-color
6 >>gap
- 30 >>min-rows
- 30 >>max-rows
+ 10 >>min-rows
+ 10 >>max-rows
60 >>min-cols
60 >>max-cols
t >>selection-required?
[ invoke-primary-operation ] >>action
COLOR: dark-gray >>column-line-color
6 >>gap
- 30 >>min-rows
- 30 >>max-rows
+ 20 >>min-rows
+ 20 >>max-rows
60 >>min-cols
60 >>max-cols
t >>selection-required?
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
+[
+ 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>
"linkage errors" +linkage-error+ "linkage" (compiler-report) ;
: <compiler-error> ( error word -- compiler-error )
- \ compiler-error new
- swap
- [ >>asset ]
- [ where [ first2 ] [ "<unknown file>" 0 ] if* [ >>file ] [ >>line# ] bi* ] bi
- swap >>error ;
+ \ compiler-error <definition-error> ;
: compiler-error ( error word -- )
compiler-errors get-global pick
! 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 ;
\ No newline at end of file