help.lint: add slot checking, don't check constants for $values.
							parent
							
								
									e0bbe0df38
								
							
						
					
					
						commit
						b88755769b
					
				| 
						 | 
					@ -1,11 +1,11 @@
 | 
				
			||||||
! Copyright (C) 2009 Slava Pestov.
 | 
					! Copyright (C) 2009 Slava Pestov.
 | 
				
			||||||
! See http://factorcode.org/license.txt for BSD license.
 | 
					! See http://factorcode.org/license.txt for BSD license.
 | 
				
			||||||
USING: accessors arrays assocs classes combinators
 | 
					USING: accessors arrays assocs classes classes.tuple combinators
 | 
				
			||||||
combinators.short-circuit definitions effects eval fry grouping
 | 
					combinators.short-circuit debugger definitions effects eval fry
 | 
				
			||||||
help help.markup help.topics io.streams.string kernel macros
 | 
					grouping help help.markup help.topics io io.streams.string
 | 
				
			||||||
namespaces sequences sequences.deep sets sorting splitting
 | 
					kernel macros namespaces sequences sequences.deep sets splitting
 | 
				
			||||||
strings unicode.categories vocabs vocabs.loader words
 | 
					strings summary unicode.categories vocabs vocabs.loader words
 | 
				
			||||||
words.symbol summary debugger io ;
 | 
					words.constant words.symbol ;
 | 
				
			||||||
FROM: sets => members ;
 | 
					FROM: sets => members ;
 | 
				
			||||||
IN: help.lint.checks
 | 
					IN: help.lint.checks
 | 
				
			||||||
 | 
					
 | 
				
			||||||
| 
						 | 
					@ -74,6 +74,7 @@ SYMBOL: vocab-articles
 | 
				
			||||||
        [ symbol? ]
 | 
					        [ symbol? ]
 | 
				
			||||||
        [ parsing-word? ]
 | 
					        [ parsing-word? ]
 | 
				
			||||||
        [ "declared-effect" word-prop not ]
 | 
					        [ "declared-effect" word-prop not ]
 | 
				
			||||||
 | 
					        [ constant? ]
 | 
				
			||||||
    } 1|| ;
 | 
					    } 1|| ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
: check-values ( word element -- )
 | 
					: check-values ( word element -- )
 | 
				
			||||||
| 
						 | 
					@ -86,7 +87,7 @@ 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 -- )
 | 
					: check-value-effects ( word element -- )
 | 
				
			||||||
| 
						 | 
					@ -144,10 +145,23 @@ SYMBOL: vocab-articles
 | 
				
			||||||
        simple-lint-error
 | 
					        simple-lint-error
 | 
				
			||||||
    ] when ;
 | 
					    ] when ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					: extract-slots ( elements -- seq )
 | 
				
			||||||
 | 
					    [ dup pair? [ first \ $slot = ] [ drop f ] if ] deep-filter
 | 
				
			||||||
 | 
					    [ second ] map ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
: check-class-description ( word element -- )
 | 
					: check-class-description ( word element -- )
 | 
				
			||||||
    [ class? not ]
 | 
					    \ $class-description swap elements over class? [
 | 
				
			||||||
    [ { $class-description } swap elements empty? not ] bi* and
 | 
					        [ all-slots [ name>> ] map ] [ extract-slots ] bi*
 | 
				
			||||||
    [ "A word that is not a class has a $class-description" simple-lint-error ] when ;
 | 
					        [ swap member? not ] with filter [
 | 
				
			||||||
 | 
					            ", " 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 -- )
 | 
					: check-article-title ( article -- )
 | 
				
			||||||
    article-title first LETTER?
 | 
					    article-title first LETTER?
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -53,6 +53,7 @@ PRIVATE>
 | 
				
			||||||
                [ check-values ]
 | 
					                [ check-values ]
 | 
				
			||||||
                [ check-value-effects ]
 | 
					                [ check-value-effects ]
 | 
				
			||||||
                [ check-class-description ]
 | 
					                [ check-class-description ]
 | 
				
			||||||
 | 
					                [ check-class-slots ]
 | 
				
			||||||
                [ nip [ check-nulls ] [ check-see-also ] [ check-markup ] tri ]
 | 
					                [ nip [ check-nulls ] [ check-see-also ] [ check-markup ] tri ]
 | 
				
			||||||
            } 2cleave
 | 
					            } 2cleave
 | 
				
			||||||
        ] check-something
 | 
					        ] check-something
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
		Loading…
	
		Reference in New Issue