! 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 ;
-FROM: sets => members ;
+USING: accessors arrays assocs classes classes.struct
+classes.tuple combinators combinators.short-circuit debugger
+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
ERROR: simple-lint-error message ;
M: simple-lint-error error. summary print ;
SYMBOL: vocabs-quot
-SYMBOL: all-vocabs
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 )
- "\n" ?tail drop
- ] keep
- last assert=
- ] vocabs-quot get call( quot -- ) ;
+ [
+ '[
+ _ rest [
+ but-last join-lines
+ (eval-with-stack>string)
+ "\n" ?tail drop
+ ] keep
+ last assert=
+ ] vocabs-quot get call( quot -- )
+ ] 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 ;
: extract-values ( element -- seq )
- \ $values swap elements dup empty? [
- first rest keys
- ] unless ;
+ \ $values swap elements
+ [ f ] [ first rest keys ] if-empty ;
: extract-value-effects ( element -- seq )
- \ $values swap elements dup empty? [
- first rest [
- \ $quotation swap elements dup empty? [ drop f ] [
- first second
- ] if
+ \ $values swap elements [ f ] [
+ first rest [
+ \ $quotation swap elements [ f ] [
+ first second dup effect? [ effect>string ] when
+ ] if-empty
] map
- ] unless ;
+ ] if-empty ;
: effect-values ( word -- seq )
stack-effect
{
[ macro? ]
[ symbol? ]
- [ value-word? ]
[ parsing-word? ]
[ "declared-effect" word-prop not ]
+ [ constant? ]
+ [ "help" word-prop not ]
} 1|| ;
+: skip-check-values? ( word element -- ? )
+ [ don't-check-word? ] [ contains-funky-elements? ] bi* or ;
+
: 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 ;
+ 2dup skip-check-values? [ 2drop ] [
+ [ effect-values ] [ extract-values ] bi* 2dup
+ sequence= [ 2drop ] [
+ "$values don't match stack effect; expected %u, got %u" sprintf
+ simple-lint-error
+ ] if
+ ] if ;
: check-value-effects ( word element -- )
- [ effect-effects ]
- [ extract-value-effects ]
- bi* [ 2dup and [ = ] [ 2drop t ] if ] 2all?
- [ "$quotation documentation in $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 ;
+ [ effect-effects ] [ extract-value-effects ] bi*
+ [ 2dup and [ = ] [ 2drop t ] if ] 2all? [
+ "$quotation stack effects in $values don't match"
+ simple-lint-error
+ ] unless ;
: check-see-also ( element -- )
- \ $see-also swap elements [
- rest all-unique? t assert=
- ] each ;
-
-: vocab-exists? ( name -- ? )
- [ lookup-vocab ] [ all-vocabs get member? ] bi or ;
+ \ $see-also swap elements [ rest all-unique? ] all?
+ [ "$see-also are not unique" simple-lint-error ] unless ;
: check-modules ( element -- )
\ $vocab-link swap elements [
] 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 ;
simple-lint-error
] when
] [
- " " swap subseq? [
+ " " subseq-of? [
"Paragraph text should not contain double spaces"
simple-lint-error
] when
simple-lint-error
] when ;
+: extract-slots ( elements -- seq )
+ [ dup pair? [ first \ $slot = ] [ drop f ] if ] deep-filter
+ [ second ] map ;
+
: 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" simple-lint-error ] when ;
+ \ $class-description swap elements over class? [
+ [
+ dup struct-class? [ struct-slots ] [ all-slots ] if
+ [ name>> ] map
+ ] [ extract-slots ] bi*
+ [ swap member? ] with reject [
+ ", " join "Described $slot does not exist: " prepend
+ simple-lint-error
+ ] unless-empty
+ ] [
+ nip empty? not [
+ "A word that is not a class has a $class-description"
+ simple-lint-error
+ ] when
+ ] if ;
: check-article-title ( article -- )
article-title first LETTER?
[ check-examples ]
[ check-modules ]
[ check-descriptions ]
+ [ check-slots-tables ]
} cleave ;
: files>vocabs ( -- assoc )
- vocabs
+ loaded-vocab-names
[ [ [ vocab-docs-path ] keep ] H{ } map>assoc ]
[ [ [ vocab-source-path ] keep ] H{ } map>assoc ]
bi assoc-union ;
projects / factor.git / blobdiff