update help-lint to complain when $quotation effect doesn't match declared effect on corresponding input parameter of stack effect

db4
Joe Groff 2010-03-09 19:51:04 -08:00
parent b9bced9a5e
commit 4367b15c4a
2 changed files with 34 additions and 9 deletions

View File

@ -36,11 +36,27 @@ SYMBOL: vocab-articles
first rest [ first ] map first rest [ first ] map
] unless ; ] unless ;
: extract-value-effects ( element -- seq )
\ $values swap elements dup empty? [
first rest [
\ $quotation swap elements dup empty? [ drop f ] [
first second
] if
] map
] unless ;
: effect-values ( word -- seq ) : effect-values ( word -- seq )
stack-effect stack-effect
[ in>> ] [ out>> ] bi append [ in>> ] [ out>> ] bi append
[ dup pair? [ first ] when effect>string ] map prune ; [ dup pair? [ first ] when effect>string ] map prune ;
: effect-effects ( word -- seq )
stack-effect in>> [
dup pair?
[ second dup effect? [ effect>string ] [ drop f ] if ]
[ drop f ] if
] map ;
: contains-funky-elements? ( element -- ? ) : contains-funky-elements? ( element -- ? )
{ {
$shuffle $shuffle
@ -70,9 +86,16 @@ SYMBOL: vocab-articles
[ effect-values ] [ effect-values ]
[ extract-values ] [ extract-values ]
bi* sequence= bi* sequence=
] ]
} 2|| [ "$values don't match stack effect" simple-lint-error ] unless ; } 2|| [ "$values don't match stack effect" simple-lint-error ] unless ;
: 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 -- ) : check-nulls ( element -- )
\ $values swap elements \ $values swap elements
null swap deep-member? null swap deep-member?

View File

@ -1,9 +1,9 @@
! Copyright (C) 2006, 2009 Slava Pestov. ! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: assocs continuations fry help help.lint.checks USING: assocs combinators continuations fry help
help.topics io kernel namespaces parser sequences help.lint.checks help.topics io kernel namespaces parser
source-files.errors vocabs.hierarchy vocabs words classes sequences source-files.errors vocabs.hierarchy vocabs words
locals tools.errors listener ; classes locals tools.errors listener ;
FROM: help.lint.checks => all-vocabs ; FROM: help.lint.checks => all-vocabs ;
FROM: vocabs => child-vocabs ; FROM: vocabs => child-vocabs ;
IN: help.lint IN: help.lint
@ -49,10 +49,12 @@ PRIVATE>
[ with-file-vocabs ] vocabs-quot set [ with-file-vocabs ] vocabs-quot set
dup word-help [ dup word-help [
[ >link ] keep '[ [ >link ] keep '[
_ dup word-help _ dup word-help {
[ check-values ] [ check-values ]
[ check-class-description ] [ check-value-effects ]
[ nip [ check-nulls ] [ check-see-also ] [ check-markup ] tri ] 2tri [ check-class-description ]
[ nip [ check-nulls ] [ check-see-also ] [ check-markup ] tri ]
} 2cleave
] check-something ] check-something
] [ drop ] if ; ] [ drop ] if ;