Merge branch 'smarter_error_list' of git://factorcode.org/git/factor into smarter_error_list
Slava Pestov
commit
e5606b2917
|
|
@ -88,7 +88,6 @@ SYMBOL: bootstrap-time
|
|||
|
||||
run-bootstrap-init
|
||||
] with-compiler-errors
|
||||
:errors
|
||||
|
||||
f error set-global
|
||||
f error-continuation set-global
|
||||
|
|
|
|||
|
|
@ -6,6 +6,7 @@ IN: bootstrap.tools
|
|||
"bootstrap.image"
|
||||
"tools.annotations"
|
||||
"tools.crossref"
|
||||
"tools.errors"
|
||||
"tools.deploy"
|
||||
"tools.disassembler"
|
||||
"tools.memory"
|
||||
|
|
|
|||
|
|
@ -5,6 +5,7 @@ kernel kernel.private layouts assocs words summary arrays
|
|||
combinators classes.algebra alien alien.c-types alien.structs
|
||||
alien.strings alien.arrays alien.complex sets libc alien.libraries
|
||||
continuations.private fry cpu.architecture
|
||||
source-files.errors
|
||||
compiler.errors
|
||||
compiler.alien
|
||||
compiler.cfg
|
||||
|
|
@ -379,8 +380,7 @@ TUPLE: no-such-library name ;
|
|||
M: no-such-library summary
|
||||
drop "Library not found" ;
|
||||
|
||||
M: no-such-library compiler-error-type
|
||||
drop +linkage+ ;
|
||||
M: no-such-library source-file-error-type drop +linkage-error+ ;
|
||||
|
||||
: no-such-library ( name -- )
|
||||
\ no-such-library boa
|
||||
|
|
@ -391,8 +391,7 @@ TUPLE: no-such-symbol name ;
|
|||
M: no-such-symbol summary
|
||||
drop "Symbol not found" ;
|
||||
|
||||
M: no-such-symbol compiler-error-type
|
||||
drop +linkage+ ;
|
||||
M: no-such-symbol source-file-error-type drop +linkage-error+ ;
|
||||
|
||||
: no-such-symbol ( name -- )
|
||||
\ no-such-symbol boa
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel namespaces arrays sequences io words fry
|
||||
continuations vocabs assocs dlists definitions math graphs generic
|
||||
combinators deques search-deques macros io stack-checker
|
||||
combinators deques search-deques macros io source-files.errors stack-checker
|
||||
stack-checker.state stack-checker.inlining combinators.short-circuit
|
||||
compiler.errors compiler.units compiler.tree.builder
|
||||
compiler.tree.optimizer compiler.cfg.builder compiler.cfg.optimizer
|
||||
|
|
@ -54,7 +54,7 @@ SYMBOLS: +optimized+ +unoptimized+ ;
|
|||
|
||||
: ignore-error? ( word error -- ? )
|
||||
[ [ inline? ] [ macro? ] bi or ]
|
||||
[ compiler-error-type +warning+ eq? ] bi* and ;
|
||||
[ source-file-error-type +compiler-warning+ eq? ] bi* and ;
|
||||
|
||||
: fail ( word error -- * )
|
||||
[ 2dup ignore-error? [ 2drop ] [ swap compiler-error ] if ]
|
||||
|
|
|
|||
|
|
@ -42,8 +42,10 @@ IN: compiler.tree.builder
|
|||
: check-cannot-infer ( word -- )
|
||||
dup "cannot-infer" word-prop [ cannot-infer-effect ] [ drop ] if ;
|
||||
|
||||
TUPLE: do-not-compile word ;
|
||||
|
||||
: check-no-compile ( word -- )
|
||||
dup "no-compile" word-prop [ cannot-infer-effect ] [ drop ] if ;
|
||||
dup "no-compile" word-prop [ do-not-compile inference-warning ] [ drop ] if ;
|
||||
|
||||
: build-tree-from-word ( word -- nodes )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -9,7 +9,8 @@ combinators generic.math classes.builtin classes compiler.units
|
|||
generic.standard vocabs init kernel.private io.encodings
|
||||
accessors math.order destructors source-files parser
|
||||
classes.tuple.parser effects.parser lexer compiler.errors
|
||||
generic.parser strings.parser vocabs.loader vocabs.parser ;
|
||||
generic.parser strings.parser vocabs.loader vocabs.parser see
|
||||
source-files.errors ;
|
||||
IN: debugger
|
||||
|
||||
GENERIC: error. ( error -- )
|
||||
|
|
@ -268,11 +269,6 @@ M: duplicate-slot-names summary
|
|||
M: invalid-slot-name summary
|
||||
drop "Invalid slot name" ;
|
||||
|
||||
: file. ( file -- ) path>> <pathname> . ;
|
||||
|
||||
M: source-file-error error.
|
||||
[ file>> file. ] [ error>> error. ] bi ;
|
||||
|
||||
M: source-file-error summary
|
||||
error>> summary ;
|
||||
|
||||
|
|
@ -309,11 +305,23 @@ M: lexer-error compute-restarts
|
|||
M: lexer-error error-help
|
||||
error>> error-help ;
|
||||
|
||||
M: object compiler-error. ( error word -- )
|
||||
nl
|
||||
"While compiling " write pprint ": " print
|
||||
nl
|
||||
print-error ;
|
||||
M: source-file-error error.
|
||||
[
|
||||
[
|
||||
[
|
||||
[ file>> [ % ": " % ] when* ]
|
||||
[ line#>> [ # ": " % ] when* ]
|
||||
[ summary % ] tri
|
||||
] "" make
|
||||
] [
|
||||
[
|
||||
presented set
|
||||
bold font-style set
|
||||
] H{ } make-assoc
|
||||
] bi format nl
|
||||
] [ error>> error. ] bi ;
|
||||
|
||||
M: compiler-error summary asset>> summary ;
|
||||
|
||||
M: bad-effect summary
|
||||
drop "Bad stack effect declaration" ;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
USING: help.markup help.syntax parser source-files vocabs.loader ;
|
||||
USING: help.markup help.syntax parser source-files
|
||||
source-files.errors vocabs.loader ;
|
||||
IN: editors
|
||||
|
||||
ARTICLE: "editor" "Editor integration"
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2005, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: parser lexer kernel namespaces sequences definitions
|
||||
io.files io.backend io.pathnames io summary continuations
|
||||
tools.crossref tools.vocabs prettyprint source-files assocs
|
||||
USING: parser lexer kernel namespaces sequences definitions io.files
|
||||
io.backend io.pathnames io summary continuations tools.crossref
|
||||
tools.vocabs prettyprint source-files source-files.errors assocs
|
||||
vocabs vocabs.loader splitting accessors debugger prettyprint
|
||||
help.topics ;
|
||||
IN: editors
|
||||
|
|
@ -81,6 +81,9 @@ M: object error-line
|
|||
: :edit ( -- )
|
||||
error get (:edit) ;
|
||||
|
||||
: edit-error ( error -- )
|
||||
[ file>> ] [ line#>> ] bi edit-location ;
|
||||
|
||||
: edit-each ( seq -- )
|
||||
[
|
||||
[ "Editing " write . ]
|
||||
|
|
|
|||
|
|
@ -137,9 +137,6 @@ ERROR: no-content-disposition multipart ;
|
|||
[ no-content-disposition ]
|
||||
} case ;
|
||||
|
||||
: assert-sequence= ( a b -- )
|
||||
2dup sequence= [ 2drop ] [ assert ] if ;
|
||||
|
||||
: read-assert-sequence= ( sequence -- )
|
||||
[ length read ] keep assert-sequence= ;
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
IN: models.arrows.smart.tests
|
||||
USING: models.arrow.smart tools.test accessors models math kernel ;
|
||||
|
||||
[ 7 ] [ 3 <model> 4 <model> [ + ] <smart-arrow> [ activate-model ] [ value>> ] bi ] unit-test
|
||||
|
|
@ -0,0 +1,9 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: models.arrow models.product stack-checker accessors fry
|
||||
generalizations macros kernel ;
|
||||
IN: models.arrow.smart
|
||||
|
||||
MACRO: <smart-arrow> ( quot -- quot' )
|
||||
[ infer in>> dup ] keep
|
||||
'[ _ narray <product> [ _ firstn @ ] <arrow> ] ;
|
||||
|
|
@ -1,12 +1,10 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays fry kernel models.product models.arrow
|
||||
sequences unicode.case ;
|
||||
USING: fry kernel models.arrow.smart sequences unicode.case ;
|
||||
IN: models.search
|
||||
|
||||
: <search> ( values search quot -- model )
|
||||
[ 2array <product> ] dip
|
||||
'[ first2 _ curry filter ] <arrow> ;
|
||||
'[ _ curry filter ] <smart-arrow> ; inline
|
||||
|
||||
: <string-search> ( values search quot -- model )
|
||||
'[ swap @ [ >case-fold ] bi@ subseq? ] <search> ;
|
||||
'[ swap @ [ >case-fold ] bi@ subseq? ] <search> ; inline
|
||||
|
|
|
|||
|
|
@ -1,8 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov
|
||||
! Copyright (C) 2009 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays fry kernel models.product models.arrow
|
||||
sequences sorting ;
|
||||
USING: sorting models.arrow.smart fry ;
|
||||
IN: models.sort
|
||||
|
||||
: <sort> ( values sort -- model )
|
||||
2array <product> [ first2 sort ] <arrow> ;
|
||||
[ '[ _ call( obj1 obj2 -- <=> ) ] sort ] <smart-arrow> ; inline
|
||||
|
|
@ -2,7 +2,8 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel generic sequences io words arrays summary effects
|
||||
continuations assocs accessors namespaces compiler.errors
|
||||
stack-checker.values stack-checker.recursive-state ;
|
||||
stack-checker.values stack-checker.recursive-state
|
||||
source-files.errors compiler.errors ;
|
||||
IN: stack-checker.errors
|
||||
|
||||
: pretty-word ( word -- word' )
|
||||
|
|
@ -10,7 +11,7 @@ IN: stack-checker.errors
|
|||
|
||||
TUPLE: inference-error error type word ;
|
||||
|
||||
M: inference-error compiler-error-type type>> ;
|
||||
M: inference-error source-file-error-type type>> ;
|
||||
|
||||
: (inference-error) ( ... class type -- * )
|
||||
[ boa ] dip
|
||||
|
|
@ -18,10 +19,10 @@ M: inference-error compiler-error-type type>> ;
|
|||
\ inference-error boa rethrow ; inline
|
||||
|
||||
: inference-error ( ... class -- * )
|
||||
+error+ (inference-error) ; inline
|
||||
+compiler-error+ (inference-error) ; inline
|
||||
|
||||
: inference-warning ( ... class -- * )
|
||||
+warning+ (inference-error) ; inline
|
||||
+compiler-warning+ (inference-error) ; inline
|
||||
|
||||
TUPLE: literal-expected what ;
|
||||
|
||||
|
|
@ -81,3 +82,8 @@ TUPLE: unknown-primitive-error ;
|
|||
|
||||
: unknown-primitive-error ( -- * )
|
||||
\ unknown-primitive-error inference-warning ;
|
||||
|
||||
TUPLE: transform-expansion-error word error ;
|
||||
|
||||
: transform-expansion-error ( word error -- * )
|
||||
\ transform-expansion-error inference-error ;
|
||||
|
|
@ -1,19 +1,26 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel prettyprint io debugger
|
||||
sequences assocs stack-checker.errors summary effects ;
|
||||
sequences assocs stack-checker.errors summary effects make ;
|
||||
IN: stack-checker.errors.prettyprint
|
||||
|
||||
M: inference-error summary error>> summary ;
|
||||
|
||||
M: inference-error error-help error>> error-help ;
|
||||
|
||||
M: inference-error error.
|
||||
[ word>> [ "In word: " write . ] when* ] [ error>> error. ] bi ;
|
||||
|
||||
M: literal-expected error.
|
||||
"Got a computed value where a " write what>> write " was expected" print ;
|
||||
M: literal-expected summary
|
||||
[ "Got a computed value where a " % what>> % " was expected" % ] "" make ;
|
||||
|
||||
M: literal-expected error. summary print ;
|
||||
|
||||
M: unbalanced-branches-error summary
|
||||
drop "Unbalanced branches" ;
|
||||
|
||||
M: unbalanced-branches-error error.
|
||||
"Unbalanced branches:" print
|
||||
dup summary print
|
||||
[ quots>> ] [ branches>> [ length <effect> ] { } assoc>map ] bi zip
|
||||
[ [ first pprint-short bl ] [ second effect>string print ] bi ] each ;
|
||||
|
||||
|
|
@ -25,16 +32,18 @@ M: too-many-r> summary
|
|||
drop
|
||||
"Quotation pops retain stack elements which it did not push" ;
|
||||
|
||||
M: missing-effect error.
|
||||
"The word " write
|
||||
word>> pprint
|
||||
" must declare a stack effect" print ;
|
||||
M: missing-effect summary
|
||||
[
|
||||
"The word " %
|
||||
word>> name>> %
|
||||
" must declare a stack effect" %
|
||||
] "" make ;
|
||||
|
||||
M: effect-error error.
|
||||
"Stack effects of the word " write
|
||||
[ word>> pprint " do not match." print ]
|
||||
[ "Inferred: " write inferred>> . ]
|
||||
[ "Declared: " write declared>> . ] tri ;
|
||||
M: effect-error summary
|
||||
[
|
||||
"Stack effect declaration of the word " %
|
||||
word>> name>> % " is wrong" %
|
||||
] "" make ;
|
||||
|
||||
M: recursive-quotation-error error.
|
||||
"The quotation " write
|
||||
|
|
@ -42,26 +51,40 @@ M: recursive-quotation-error error.
|
|||
" calls itself." print
|
||||
"Stack effect inference is undecidable when quotation-level recursion is permitted." print ;
|
||||
|
||||
M: undeclared-recursion-error error.
|
||||
"The inline recursive word " write
|
||||
word>> pprint
|
||||
" must be declared recursive" print ;
|
||||
|
||||
M: diverging-recursion-error error.
|
||||
"The recursive word " write
|
||||
word>> pprint
|
||||
" digs arbitrarily deep into the stack" print ;
|
||||
|
||||
M: unbalanced-recursion-error error.
|
||||
"The recursive word " write
|
||||
word>> pprint
|
||||
" leaves with the stack having the wrong height" print ;
|
||||
|
||||
M: inconsistent-recursive-call-error error.
|
||||
"The recursive word " write
|
||||
word>> pprint
|
||||
" calls itself with a different set of quotation parameters than were input" print ;
|
||||
|
||||
M: unknown-primitive-error error.
|
||||
M: undeclared-recursion-error summary
|
||||
drop
|
||||
"Cannot determine stack effect statically" print ;
|
||||
"Inline recursive words must be declared recursive" ;
|
||||
|
||||
M: diverging-recursion-error summary
|
||||
[
|
||||
"The recursive word " %
|
||||
word>> name>> %
|
||||
" digs arbitrarily deep into the stack" %
|
||||
] "" make ;
|
||||
|
||||
M: unbalanced-recursion-error summary
|
||||
[
|
||||
"The recursive word " %
|
||||
word>> name>> %
|
||||
" leaves with the stack having the wrong height" %
|
||||
] "" make ;
|
||||
|
||||
M: inconsistent-recursive-call-error summary
|
||||
[
|
||||
"The recursive word " %
|
||||
word>> name>> %
|
||||
" calls itself with a different set of quotation parameters than were input" %
|
||||
] "" make ;
|
||||
|
||||
M: unknown-primitive-error summary
|
||||
drop
|
||||
"Cannot determine stack effect statically" ;
|
||||
|
||||
M: transform-expansion-error summary
|
||||
drop
|
||||
"Compiler transform threw an error" ;
|
||||
|
||||
M: transform-expansion-error error.
|
||||
[ summary print ]
|
||||
[ "Word: " write word>> . nl ]
|
||||
[ error>> error. ] tri ;
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
IN: stack-checker.transforms.tests
|
||||
USING: sequences stack-checker.transforms tools.test math kernel
|
||||
quotations stack-checker accessors combinators words arrays
|
||||
quotations stack-checker stack-checker.errors accessors combinators words arrays
|
||||
classes classes.tuple ;
|
||||
|
||||
: compose-n-quot ( word n -- quot' ) <repetition> >quotation ;
|
||||
|
|
@ -70,4 +70,11 @@ DEFER: curry-folding-test ( quot -- )
|
|||
: member?-test ( a -- ? ) { 1 2 3 10 7 58 } member? ;
|
||||
|
||||
[ f ] [ 1.0 member?-test ] unit-test
|
||||
[ t ] [ \ member?-test def>> first [ member?-test ] all? ] unit-test
|
||||
[ t ] [ \ member?-test def>> first [ member?-test ] all? ] unit-test
|
||||
|
||||
! Macro expansion should throw its own type of error
|
||||
: bad-macro ( -- ) ;
|
||||
|
||||
\ bad-macro [ "OOPS" throw ] 0 define-transform
|
||||
|
||||
[ [ bad-macro ] infer ] [ inference-error? ] must-fail-with
|
||||
|
|
@ -17,9 +17,14 @@ IN: stack-checker.transforms
|
|||
[ dup infer-word apply-word/effect ]
|
||||
} cond ;
|
||||
|
||||
: call-transformer ( word stack quot -- newquot )
|
||||
'[ _ _ with-datastack [ length 1 assert= ] [ first ] bi nip ]
|
||||
[ transform-expansion-error ]
|
||||
recover ;
|
||||
|
||||
:: ((apply-transform)) ( word quot values stack rstate -- )
|
||||
rstate recursive-state
|
||||
[ stack quot with-datastack first ] with-variable
|
||||
[ word stack quot call-transformer ] with-variable
|
||||
[
|
||||
word inlined-dependency depends-on
|
||||
values [ length meta-d shorten-by ] [ #drop, ] bi
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,40 @@
|
|||
IN: tools.errors
|
||||
USING: compiler.errors tools.errors help.markup help.syntax vocabs.loader
|
||||
words quotations io ;
|
||||
|
||||
ARTICLE: "compiler-errors" "Compiler warnings and errors"
|
||||
"After loading a vocabulary, you might see messages like:"
|
||||
{ $code
|
||||
":errors - print 2 compiler errors."
|
||||
":warnings - print 50 compiler warnings."
|
||||
}
|
||||
"These warnings arise from the compiler's stack effect checker. Warnings are non-fatal conditions -- not all code has a static stack effect, so you try to minimize warnings but understand that in many cases they cannot be eliminated. Errors indicate programming mistakes, such as erroneous stack effect declarations."
|
||||
$nl
|
||||
"The precise warning and error conditions are documented in " { $link "inference-errors" } "."
|
||||
$nl
|
||||
"Words to view warnings and errors:"
|
||||
{ $subsection :errors }
|
||||
{ $subsection :warnings }
|
||||
{ $subsection :linkage }
|
||||
"Words such as " { $link require } " use a combinator which counts errors and prints a report at the end:"
|
||||
{ $subsection with-compiler-errors } ;
|
||||
|
||||
HELP: compiler-error
|
||||
{ $values { "error" "an error" } { "word" word } }
|
||||
{ $description "If inside a " { $link with-compiler-errors } ", saves the error for future persual via " { $link :errors } ", " { $link :warnings } " and " { $link :linkage } ". If not inside a " { $link with-compiler-errors } ", ignores the error." } ;
|
||||
|
||||
HELP: with-compiler-errors
|
||||
{ $values { "quot" quotation } }
|
||||
{ $description "Calls the quotation and collects any compiler warnings and errors. Compiler warnings and errors are summarized at the end and can be viewed with " { $link :errors } ", " { $link :warnings } ", and " { $link :linkage } "." }
|
||||
{ $notes "Nested calls to " { $link with-compiler-errors } " are ignored, and only the outermost call collects warnings and errors." } ;
|
||||
|
||||
HELP: :errors
|
||||
{ $description "Prints all serious compiler errors from the most recent compile to " { $link output-stream } "." } ;
|
||||
|
||||
HELP: :warnings
|
||||
{ $description "Prints all ignorable compiler warnings from the most recent compile to " { $link output-stream } "." } ;
|
||||
|
||||
HELP: :linkage
|
||||
{ $description "Prints all C library interface linkage errors from the most recent compile to " { $link output-stream } "." } ;
|
||||
|
||||
{ :errors :warnings } related-words
|
||||
|
|
@ -0,0 +1,25 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs compiler.errors debugger io kernel sequences
|
||||
source-files.errors ;
|
||||
IN: tools.errors
|
||||
|
||||
#! Tools for source-files.errors. Used by tools.tests and others
|
||||
#! for error reporting
|
||||
|
||||
: errors. ( errors -- )
|
||||
group-by-source-file sort-errors
|
||||
[
|
||||
[ nl "==== " write print nl ]
|
||||
[ [ nl ] [ error. ] interleave ]
|
||||
bi*
|
||||
] assoc-each ;
|
||||
|
||||
: compiler-errors. ( type -- )
|
||||
errors-of-type values errors. ;
|
||||
|
||||
: :errors ( -- ) +compiler-error+ compiler-errors. ;
|
||||
|
||||
: :warnings ( -- ) +compiler-warning+ compiler-errors. ;
|
||||
|
||||
: :linkage ( -- ) +linkage-error+ compiler-errors. ;
|
||||
|
|
@ -7,7 +7,7 @@ continuations generic compiler.units sets classes fry ;
|
|||
IN: tools.profiler
|
||||
|
||||
: profile ( quot -- )
|
||||
[ t profiling call ] [ f profiling ] [ ] cleanup ;
|
||||
[ t profiling call ] [ f profiling ] [ ] cleanup ; inline
|
||||
|
||||
: filter-counts ( alist -- alist' )
|
||||
[ second 0 > ] filter ;
|
||||
|
|
|
|||
|
|
@ -3,33 +3,23 @@ IN: tools.test
|
|||
|
||||
ARTICLE: "tools.test.write" "Writing unit tests"
|
||||
"Assert that a quotation outputs a specific set of values:"
|
||||
{ $subsection unit-test }
|
||||
{ $subsection POSTPONE: unit-test }
|
||||
"Assert that a quotation throws an error:"
|
||||
{ $subsection must-fail }
|
||||
{ $subsection must-fail-with }
|
||||
{ $subsection POSTPONE: must-fail }
|
||||
{ $subsection POSTPONE: must-fail-with }
|
||||
"Assert that a quotation or word has a specific static stack effect (see " { $link "inference" } "):"
|
||||
{ $subsection must-infer }
|
||||
{ $subsection must-infer-as } ;
|
||||
{ $subsection POSTPONE: must-infer }
|
||||
{ $subsection POSTPONE: must-infer-as } ;
|
||||
|
||||
ARTICLE: "tools.test.run" "Running unit tests"
|
||||
"The following words run test harness files; any test failures are collected and printed at the end:"
|
||||
{ $subsection test }
|
||||
{ $subsection test-all } ;
|
||||
|
||||
ARTICLE: "tools.test.failure" "Handling test failures"
|
||||
"Most of the time the words documented in " { $link "tools.test.run" } " are used because they print all test failures in human-readable form. Some tools inspect the test failures and takes some kind of action instead, for example, " { $vocab-link "mason" } "."
|
||||
$nl
|
||||
"The following words output an association list mapping vocabulary names to sequences of failures; a failure is an array having the shape " { $snippet "{ error test continuation }" } ", and the elements are as follows:"
|
||||
{ $list
|
||||
{ { $snippet "error" } " - the error thrown by the unit test" }
|
||||
{ { $snippet "test" } " - a pair " { $snippet "{ output input }" } " containing expected output and a unit test quotation which didn't produce this output" }
|
||||
{ { $snippet "continuation" } " - the traceback at the point of the error" }
|
||||
}
|
||||
"The following words run test harness files and output failures:"
|
||||
{ $subsection run-tests }
|
||||
{ $subsection run-all-tests }
|
||||
{ $subsection test-all }
|
||||
"The following word prints failures:"
|
||||
{ $subsection test-failures. } ;
|
||||
{ $subsection :failures }
|
||||
"Unit test failurs are instances of a class, and are stored in a global variable:"
|
||||
{ $subsection test-failure }
|
||||
{ $subsection test-failures } ;
|
||||
|
||||
ARTICLE: "tools.test" "Unit testing"
|
||||
"A unit test is a piece of code which starts with known input values, then compares the output of a word with an expected output, where the expected output is defined by the word's contract."
|
||||
|
|
@ -45,8 +35,7 @@ $nl
|
|||
$nl
|
||||
"If the test harness needs to define words, they should be placed in a vocabulary named " { $snippet { $emphasis "vocab" } ".tests" } " where " { $emphasis "vocab" } " is the vocab being tested."
|
||||
{ $subsection "tools.test.write" }
|
||||
{ $subsection "tools.test.run" }
|
||||
{ $subsection "tools.test.failure" } ;
|
||||
{ $subsection "tools.test.run" } ;
|
||||
|
||||
ABOUT: "tools.test"
|
||||
|
||||
|
|
@ -78,17 +67,8 @@ HELP: test
|
|||
{ $values { "prefix" "a vocabulary name" } }
|
||||
{ $description "Runs unit tests for the vocabulary named " { $snippet "prefix" } " and all of its child vocabularies." } ;
|
||||
|
||||
HELP: run-tests
|
||||
{ $values { "prefix" "a vocabulary name" } { "failures" "an association list of unit test failures" } }
|
||||
{ $description "Runs unit tests for the vocabulary named " { $snippet "prefix" } " and all of its child vocabularies. Outputs unit test failures as documented in " { $link "tools.test.failure" } "." } ;
|
||||
|
||||
HELP: test-all
|
||||
{ $description "Runs unit tests for all loaded vocabularies." } ;
|
||||
|
||||
HELP: run-all-tests
|
||||
{ $values { "failures" "an association list of unit test failures" } }
|
||||
{ $description "Runs unit tests for all loaded vocabularies and outputs unit test failures as documented in " { $link "tools.test.failure" } "." } ;
|
||||
|
||||
HELP: test-failures.
|
||||
{ $values { "assoc" "an association list of unit test failures" } }
|
||||
{ $description "Prints unit test failures output by " { $link run-tests } " or " { $link run-all-tests } " to " { $link output-stream } "." } ;
|
||||
HELP: :failures
|
||||
{ $description "Prints all pending unit test failures." } ;
|
||||
|
|
|
|||
|
|
@ -1,95 +1,138 @@
|
|||
! Copyright (C) 2003, 2008 Slava Pestov.
|
||||
! Copyright (C) 2003, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors namespaces arrays prettyprint sequences kernel
|
||||
vectors quotations words parser assocs combinators continuations
|
||||
debugger io io.styles io.files vocabs vocabs.loader source-files
|
||||
compiler.units summary stack-checker effects tools.vocabs fry ;
|
||||
USING: accessors arrays assocs combinators compiler.units
|
||||
continuations debugger effects fry generalizations io io.files
|
||||
io.styles kernel lexer locals macros math.parser namespaces
|
||||
parser prettyprint quotations sequences source-files splitting
|
||||
stack-checker summary unicode.case vectors vocabs vocabs.loader words
|
||||
tools.vocabs tools.errors source-files.errors io.streams.string make
|
||||
compiler.errors ;
|
||||
IN: tools.test
|
||||
|
||||
SYMBOL: failures
|
||||
TUPLE: test-failure < source-file-error continuation ;
|
||||
|
||||
: <failure> ( error what -- triple )
|
||||
error-continuation get 3array ;
|
||||
SYMBOL: +test-failure+
|
||||
|
||||
: failure ( error what -- )
|
||||
M: test-failure source-file-error-type drop +test-failure+ ;
|
||||
|
||||
SYMBOL: test-failures
|
||||
test-failures [ V{ } clone ] initialize
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: <test-failure> ( error experiment file line# -- triple )
|
||||
test-failure new
|
||||
swap >>line#
|
||||
swap >>file
|
||||
swap >>asset
|
||||
swap >>error
|
||||
error-continuation get >>continuation ;
|
||||
|
||||
: failure ( error experiment file line# -- )
|
||||
"--> test failed!" print
|
||||
<failure> failures get push ;
|
||||
<test-failure> test-failures get push ;
|
||||
|
||||
SYMBOL: this-test
|
||||
SYMBOL: file
|
||||
|
||||
: (unit-test) ( what quot -- )
|
||||
swap dup . flush this-test set
|
||||
failures get [
|
||||
[ this-test get failure ] recover
|
||||
] [
|
||||
call
|
||||
] if ; inline
|
||||
: file-failure ( error -- )
|
||||
f file get f failure ;
|
||||
|
||||
: unit-test ( output input -- )
|
||||
[ 2array ] 2keep '[
|
||||
_ { } _ with-datastack swap >array assert=
|
||||
] (unit-test) ;
|
||||
:: (unit-test) ( output input -- error ? )
|
||||
[ { } input with-datastack output assert-sequence= f f ] [ t ] recover ; inline
|
||||
|
||||
: short-effect ( effect -- pair )
|
||||
[ in>> length ] [ out>> length ] bi 2array ;
|
||||
|
||||
: must-infer-as ( effect quot -- )
|
||||
[ 1quotation ] dip '[ _ infer short-effect ] unit-test ;
|
||||
:: (must-infer-as) ( effect quot -- error ? )
|
||||
[ quot infer short-effect effect assert= f f ] [ t ] recover ; inline
|
||||
|
||||
: must-infer ( word/quot -- )
|
||||
dup word? [ 1quotation ] when
|
||||
'[ _ infer drop ] [ ] swap unit-test ;
|
||||
:: (must-infer) ( word/quot -- error ? )
|
||||
word/quot dup word? [ '[ _ execute ] ] when :> quot
|
||||
[ quot infer drop f f ] [ t ] recover ; inline
|
||||
|
||||
: must-fail-with ( quot pred -- )
|
||||
[ '[ @ f ] ] dip '[ _ _ recover ] [ t ] swap unit-test ;
|
||||
TUPLE: did-not-fail ;
|
||||
CONSTANT: did-not-fail T{ did-not-fail }
|
||||
|
||||
: must-fail ( quot -- )
|
||||
[ drop t ] must-fail-with ;
|
||||
M: did-not-fail summary drop "Did not fail" ;
|
||||
|
||||
: (run-test) ( vocab -- )
|
||||
:: (must-fail-with) ( quot pred -- error ? )
|
||||
[ quot call did-not-fail t ]
|
||||
[ dup pred call [ drop f f ] [ t ] if ] recover ; inline
|
||||
|
||||
:: (must-fail) ( quot -- error ? )
|
||||
[ quot call did-not-fail t ] [ drop f f ] recover ; inline
|
||||
|
||||
: experiment-title ( word -- string )
|
||||
"(" ?head drop ")" ?tail drop { { CHAR: - CHAR: \s } } substitute >title ;
|
||||
|
||||
MACRO: <experiment> ( word -- )
|
||||
[ stack-effect in>> length dup ]
|
||||
[ name>> experiment-title ] bi
|
||||
'[ _ ndup _ narray _ prefix ] ;
|
||||
|
||||
: experiment. ( seq -- )
|
||||
[ first write ": " write ] [ rest . ] bi ;
|
||||
|
||||
:: experiment ( word: ( -- error ? ) line# -- )
|
||||
word <experiment> :> e
|
||||
e experiment.
|
||||
word execute [
|
||||
file get [
|
||||
e file get line# failure
|
||||
] [ rethrow ] if
|
||||
] [ drop ] if ; inline
|
||||
|
||||
: parse-test ( accum word -- accum )
|
||||
literalize parsed
|
||||
lexer get line>> parsed
|
||||
\ experiment parsed ; inline
|
||||
|
||||
<<
|
||||
|
||||
SYNTAX: TEST:
|
||||
scan
|
||||
[ create-in ]
|
||||
[ "(" ")" surround search '[ _ parse-test ] ] bi
|
||||
define-syntax ;
|
||||
|
||||
>>
|
||||
|
||||
: run-test-file ( path -- )
|
||||
dup file [
|
||||
test-failures get [ file>> file get = not ] filter-here
|
||||
'[ _ run-file ] [ file-failure ] recover
|
||||
] with-variable ;
|
||||
|
||||
: run-vocab-tests ( vocab -- )
|
||||
dup vocab source-loaded?>> [
|
||||
vocab-tests [ run-file ] each
|
||||
vocab-tests [ run-test-file ] each
|
||||
] [ drop ] if ;
|
||||
|
||||
: run-test ( vocab -- failures )
|
||||
V{ } clone [
|
||||
failures [
|
||||
[ (run-test) ] [ swap failure ] recover
|
||||
] with-variable
|
||||
] keep ;
|
||||
: traceback-button. ( failure -- )
|
||||
"[" write [ "Traceback" ] dip continuation>> write-object "]" print ;
|
||||
|
||||
: failure. ( triple -- )
|
||||
dup second .
|
||||
dup first print-error
|
||||
"Traceback" swap third write-object ;
|
||||
PRIVATE>
|
||||
|
||||
: test-failures. ( assoc -- )
|
||||
[
|
||||
nl
|
||||
[
|
||||
"==== ALL TESTS PASSED" print
|
||||
] [
|
||||
"==== FAILING TESTS:" print
|
||||
[
|
||||
swap vocab-heading.
|
||||
[ failure. nl ] each
|
||||
] assoc-each
|
||||
] if-empty
|
||||
] [
|
||||
"==== NOTHING TO TEST" print
|
||||
] if* ;
|
||||
TEST: unit-test
|
||||
TEST: must-infer-as
|
||||
TEST: must-infer
|
||||
TEST: must-fail-with
|
||||
TEST: must-fail
|
||||
|
||||
: run-tests ( prefix -- failures )
|
||||
child-vocabs [ f ] [
|
||||
[ dup run-test ] { } map>assoc
|
||||
[ second empty? not ] filter
|
||||
] if-empty ;
|
||||
M: test-failure summary
|
||||
asset>> [ [ experiment. ] with-string-writer ] [ "Top-level form" ] if* ;
|
||||
|
||||
M: test-failure error. ( error -- )
|
||||
[ call-next-method ]
|
||||
[ traceback-button. ]
|
||||
bi ;
|
||||
|
||||
: :failures ( -- ) test-failures get errors. ;
|
||||
|
||||
: test ( prefix -- )
|
||||
run-tests test-failures. ;
|
||||
[ child-vocabs [ run-vocab-tests ] each ] with-compiler-errors
|
||||
test-failures get [
|
||||
":failures - show " write length pprint " failing tests." print
|
||||
] unless-empty ;
|
||||
|
||||
: run-all-tests ( -- failures )
|
||||
"" run-tests ;
|
||||
|
||||
: test-all ( -- )
|
||||
run-all-tests test-failures. ;
|
||||
: test-all ( -- ) "" test ;
|
||||
|
|
|
|||
|
|
@ -24,35 +24,47 @@ TUPLE: gadget-metrics height ascent descent cap-height ;
|
|||
[ dup [ 2dup - ] [ f ] if ] dip
|
||||
gadget-metrics boa ; inline
|
||||
|
||||
: ?supremum ( seq -- n/f )
|
||||
sift [ f ] [ supremum ] if-empty ;
|
||||
|
||||
: max-ascent ( seq -- n )
|
||||
0 [ ascent>> [ max ] when* ] reduce ; inline
|
||||
[ ascent>> ] map ?supremum ;
|
||||
|
||||
: max-cap-height ( seq -- n )
|
||||
0 [ cap-height>> [ max ] when* ] reduce ; inline
|
||||
[ cap-height>> ] map ?supremum ;
|
||||
|
||||
: max-descent ( seq -- n )
|
||||
0 [ descent>> [ max ] when* ] reduce ; inline
|
||||
[ descent>> ] map ?supremum ;
|
||||
|
||||
: max-text-height ( seq -- y )
|
||||
0 [ [ height>> ] [ ascent>> ] bi [ max ] [ drop ] if ] reduce ;
|
||||
[ ascent>> ] filter [ height>> ] map ?supremum ;
|
||||
|
||||
: max-graphics-height ( seq -- y )
|
||||
0 [ [ height>> ] [ ascent>> ] bi [ drop ] [ max ] if ] reduce ;
|
||||
|
||||
: (align-baselines) ( y max leading -- y' ) [ swap - ] dip + ;
|
||||
[ ascent>> not ] filter [ height>> ] map ?supremum 0 or ;
|
||||
|
||||
:: combine-metrics ( graphics-height ascent descent cap-height -- ascent' descent' )
|
||||
cap-height 2 / :> mid-line
|
||||
graphics-height 2 /
|
||||
[ ascent mid-line - max mid-line + >integer ]
|
||||
[ descent mid-line + max mid-line - >integer ] bi ;
|
||||
ascent [
|
||||
cap-height 2 / :> mid-line
|
||||
graphics-height 2 /
|
||||
[ ascent mid-line - max mid-line + >integer ]
|
||||
[ descent mid-line + max mid-line - >integer ] bi
|
||||
] [ f f ] if ;
|
||||
|
||||
: (measure-metrics) ( children sizes -- graphics-height ascent descent cap-height )
|
||||
[ <gadget-metrics> ] 2map
|
||||
{
|
||||
[ max-graphics-height ]
|
||||
[ max-ascent ]
|
||||
[ max-descent ]
|
||||
[ max-cap-height ]
|
||||
} cleave ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
:: align-baselines ( gadgets -- ys )
|
||||
gadgets [ dup pref-dim <gadget-metrics> ] map
|
||||
dup max-ascent :> max-ascent
|
||||
dup max-cap-height :> max-cap-height
|
||||
dup max-ascent 0 or :> max-ascent
|
||||
dup max-cap-height 0 or :> max-cap-height
|
||||
dup max-graphics-height :> max-graphics-height
|
||||
|
||||
max-cap-height max-graphics-height + 2 /i :> critical-line
|
||||
|
|
@ -61,20 +73,12 @@ PRIVATE>
|
|||
|
||||
[
|
||||
dup ascent>>
|
||||
[ ascent>> max-ascent text-leading ]
|
||||
[ height>> max-graphics-height graphics-leading ] if
|
||||
(align-baselines)
|
||||
[ ascent>> max-ascent swap - text-leading ]
|
||||
[ height>> max-graphics-height swap - 2/ graphics-leading ] if +
|
||||
] map ;
|
||||
|
||||
: measure-metrics ( children sizes -- ascent descent )
|
||||
[ <gadget-metrics> ] 2map
|
||||
{
|
||||
[ max-graphics-height ]
|
||||
[ max-ascent ]
|
||||
[ max-descent ]
|
||||
[ max-cap-height ]
|
||||
} cleave
|
||||
combine-metrics ;
|
||||
(measure-metrics) combine-metrics ;
|
||||
|
||||
: measure-height ( children sizes -- height )
|
||||
measure-metrics + ;
|
||||
(measure-metrics) dup [ combine-metrics + ] [ 3drop ] if ;
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors ui.images ui.pens
|
||||
ui.pens.image ui.gadgets ;
|
||||
ui.pens.image ui.gadgets ui.gadgets.labels ;
|
||||
IN: ui.gadgets.icons
|
||||
|
||||
TUPLE: icon < gadget ;
|
||||
|
|
@ -9,4 +9,6 @@ TUPLE: icon < gadget ;
|
|||
: <icon> ( image-name -- icon )
|
||||
icon new swap <image-pen> t >>fill? >>interior ;
|
||||
|
||||
M: icon pref-dim* dup interior>> pen-pref-dim ;
|
||||
M: icon pref-dim* dup interior>> pen-pref-dim ;
|
||||
|
||||
M: image-name >label <icon> ;
|
||||
|
|
@ -90,4 +90,43 @@ IN: ui.gadgets.packs.tests
|
|||
|
||||
[ ] [ "g" get prefer ] unit-test
|
||||
|
||||
[ ] [ "g" get layout ] unit-test
|
||||
[ ] [ "g" get layout ] unit-test
|
||||
|
||||
! Baseline alignment without any text gadgets should behave like align=1/2
|
||||
<shelf> +baseline+ >>align
|
||||
<gadget> { 30 30 } >>dim add-gadget
|
||||
<gadget> { 30 20 } >>dim add-gadget
|
||||
"g" set
|
||||
|
||||
[ { 60 30 } ] [ "g" get pref-dim ] unit-test
|
||||
|
||||
[ ] [ "g" get prefer ] unit-test
|
||||
|
||||
[ ] [ "g" get layout ] unit-test
|
||||
|
||||
[ V{ { 0 0 } { 30 5 } } ]
|
||||
[ "g" get children>> [ loc>> ] map ] unit-test
|
||||
|
||||
<shelf> +baseline+ >>align
|
||||
<gadget> { 30 30 } >>dim add-gadget
|
||||
10 10 { 10 10 } <baseline-gadget> add-gadget
|
||||
"g" set
|
||||
|
||||
[ ] [ "g" get prefer ] unit-test
|
||||
|
||||
[ ] [ "g" get layout ] unit-test
|
||||
|
||||
[ V{ { 0 0 } { 30 10 } } ]
|
||||
[ "g" get children>> [ loc>> ] map ] unit-test
|
||||
|
||||
<shelf> +baseline+ >>align
|
||||
<shelf> <gadget> { 30 30 } >>dim add-gadget add-gadget
|
||||
10 10 { 10 10 } <baseline-gadget> add-gadget
|
||||
"g" set
|
||||
|
||||
[ ] [ "g" get prefer ] unit-test
|
||||
|
||||
[ ] [ "g" get layout ] unit-test
|
||||
|
||||
[ V{ { 0 0 } { 30 10 } } ]
|
||||
[ "g" get children>> [ loc>> ] map ] unit-test
|
||||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2005, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: sequences ui.gadgets ui.baseline-alignment kernel math
|
||||
math.functions math.vectors math.order math.rectangles namespaces
|
||||
accessors fry combinators arrays ;
|
||||
USING: sequences ui.gadgets ui.baseline-alignment
|
||||
ui.baseline-alignment.private kernel math math.functions math.vectors
|
||||
math.order math.rectangles namespaces accessors fry combinators arrays ;
|
||||
IN: ui.gadgets.packs
|
||||
|
||||
TUPLE: pack < gadget
|
||||
|
|
@ -84,8 +84,7 @@ M: pack pref-dim*
|
|||
children>> dup pref-dims measure-metrics drop ;
|
||||
|
||||
: pack-cap-height ( pack -- n )
|
||||
children>> [ cap-height ] map sift
|
||||
[ f ] [ supremum ] if-empty ;
|
||||
children>> [ cap-height ] map ?supremum ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@ USING: alien ui.gadgets.panes ui.gadgets namespaces
|
|||
kernel sequences io io.styles io.streams.string tools.test
|
||||
prettyprint definitions help help.syntax help.markup
|
||||
help.stylesheet splitting ui.gadgets.debug models math summary
|
||||
inspector accessors help.topics see ;
|
||||
inspector accessors help.topics see fry ;
|
||||
IN: ui.gadgets.panes.tests
|
||||
|
||||
: #children ( -- n ) "pane" get children>> length ;
|
||||
|
|
@ -18,8 +18,9 @@ IN: ui.gadgets.panes.tests
|
|||
[ t ] [ #children "num-children" get = ] unit-test
|
||||
|
||||
: test-gadget-text ( quot -- ? )
|
||||
dup make-pane gadget-text dup print "======" print
|
||||
swap with-string-writer dup print = ;
|
||||
'[ _ call( -- ) ]
|
||||
[ make-pane gadget-text dup print "======" print ]
|
||||
[ with-string-writer dup print ] bi = ;
|
||||
|
||||
[ t ] [ [ "hello" write ] test-gadget-text ] unit-test
|
||||
[ t ] [ [ "hello" pprint ] test-gadget-text ] unit-test
|
||||
|
|
|
|||
|
|
@ -74,7 +74,7 @@ CONSULT: table-protocol search-table table>> ;
|
|||
dup field>> { 2 2 } <filled-border> f track-add
|
||||
values search 500 milliseconds <delay> quot <string-search>
|
||||
renderer <table> f >>takes-focus? >>table
|
||||
dup table>> <scroller> 1 track-add ;
|
||||
dup table>> <scroller> 1 track-add ; inline
|
||||
|
||||
M: search-table model-changed
|
||||
nip field>> clear-search-field ;
|
||||
|
|
|
|||
|
|
@ -59,14 +59,19 @@ focused? ;
|
|||
|
||||
GENERIC: cell-width ( font cell -- x )
|
||||
GENERIC: cell-height ( font cell -- y )
|
||||
GENERIC: cell-padding ( cell -- y )
|
||||
GENERIC: draw-cell ( font cell -- )
|
||||
|
||||
M: string cell-width text-width ;
|
||||
M: string cell-height text-height ceiling ;
|
||||
M: string cell-padding drop 0 ;
|
||||
M: string draw-cell draw-text ;
|
||||
|
||||
CONSTANT: image-padding 2
|
||||
|
||||
M: image-name cell-width nip image-dim first ;
|
||||
M: image-name cell-height nip image-dim second ;
|
||||
M: image-name cell-padding drop image-padding ;
|
||||
M: image-name draw-cell nip draw-image ;
|
||||
|
||||
: table-rows ( table -- rows )
|
||||
|
|
@ -87,7 +92,7 @@ CONSTANT: column-title-background COLOR: light-gray
|
|||
if ;
|
||||
|
||||
: row-column-widths ( table row -- widths )
|
||||
[ font>> ] dip [ cell-width ] with map ;
|
||||
[ font>> ] dip [ [ cell-width ] [ cell-padding ] bi + ] with map ;
|
||||
|
||||
: compute-total-width ( gap widths -- total )
|
||||
swap [ column-offsets drop ] keep - ;
|
||||
|
|
@ -162,9 +167,10 @@ M: table layout*
|
|||
'[ [ 0 2array ] [ _ 2array ] bi gl-line ] each
|
||||
] bi ;
|
||||
|
||||
: column-loc ( font column width align -- loc )
|
||||
[ [ cell-width ] dip swap - ] dip
|
||||
* >integer 0 2array ;
|
||||
:: column-loc ( font column width align -- loc )
|
||||
font column cell-width width swap - align * column cell-padding 2 / 1 align - * +
|
||||
font column cell-height \ line-height get swap - 2 /
|
||||
[ >integer ] bi@ 2array ;
|
||||
|
||||
: translate-column ( width gap -- )
|
||||
+ 0 2array gl-translate ;
|
||||
|
|
@ -203,18 +209,21 @@ M: table draw-line ( row index table -- )
|
|||
|
||||
M: table draw-gadget*
|
||||
dup control-value empty? [ drop ] [
|
||||
{
|
||||
[ draw-selected-row ]
|
||||
[ draw-lines ]
|
||||
[ draw-column-lines ]
|
||||
[ draw-focused-row ]
|
||||
[ draw-moused-row ]
|
||||
} cleave
|
||||
dup line-height \ line-height [
|
||||
{
|
||||
[ draw-selected-row ]
|
||||
[ draw-lines ]
|
||||
[ draw-column-lines ]
|
||||
[ draw-focused-row ]
|
||||
[ draw-moused-row ]
|
||||
} cleave
|
||||
] with-variable
|
||||
] if ;
|
||||
|
||||
M: table line-height ( table -- y )
|
||||
[ font>> ] [ renderer>> prototype-row ] bi
|
||||
[ cell-height ] with [ max ] map-reduce ;
|
||||
[ [ cell-height ] [ cell-padding ] bi + ] with
|
||||
[ max ] map-reduce ;
|
||||
|
||||
M: table pref-dim*
|
||||
[ compute-column-widths drop ] keep
|
||||
|
|
@ -379,14 +388,16 @@ TUPLE: column-headers < gadget table ;
|
|||
column-title-background <solid> >>interior ;
|
||||
|
||||
: draw-column-titles ( table -- )
|
||||
{
|
||||
[ renderer>> column-titles ]
|
||||
[ column-widths>> ]
|
||||
[ table-column-alignment ]
|
||||
[ font>> column-title-font ]
|
||||
[ gap>> ]
|
||||
} cleave
|
||||
draw-columns ;
|
||||
dup font>> font-metrics height>> \ line-height [
|
||||
{
|
||||
[ renderer>> column-titles ]
|
||||
[ column-widths>> ]
|
||||
[ table-column-alignment ]
|
||||
[ font>> column-title-font ]
|
||||
[ gap>> ]
|
||||
} cleave
|
||||
draw-columns
|
||||
] with-variable ;
|
||||
|
||||
M: column-headers draw-gadget*
|
||||
table>> draw-column-titles ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2006, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: debugger help help.topics help.crossref help.home kernel models
|
||||
USING: debugger classes help help.topics help.crossref help.home kernel models
|
||||
compiler.units assocs words vocabs accessors fry arrays
|
||||
combinators.short-circuit namespaces sequences models help.apropos
|
||||
combinators ui ui.commands ui.gadgets ui.gadgets.panes
|
||||
|
|
@ -91,6 +91,10 @@ M: browser-gadget focusable-child* search-field>> ;
|
|||
: browser-window ( -- )
|
||||
"help.home" (browser-window) ;
|
||||
|
||||
: error-help-window ( error -- )
|
||||
[ error-help ]
|
||||
[ dup tuple? [ class ] [ drop "errors" ] if ] bi or (browser-window) ;
|
||||
|
||||
\ browser-window H{ { +nullary+ t } } define-command
|
||||
|
||||
: com-browse ( link -- )
|
||||
|
|
|
|||
|
|
@ -46,7 +46,7 @@ SLOT: model
|
|||
|
||||
: show-links-popup ( browser-gadget quot title -- )
|
||||
[ dup model>> ] 2dip <links-popup>
|
||||
[ hand-loc get { 0 0 } <rect> show-glass ] [ request-focus ] bi ;
|
||||
[ hand-loc get { 0 0 } <rect> show-glass ] [ request-focus ] bi ; inline
|
||||
|
||||
: com-show-outgoing-links ( browser-gadget -- )
|
||||
[ uses ] "Outgoing links" show-links-popup ;
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ ui.gadgets.buttons ui.gadgets.labels ui.gadgets.panes
|
|||
ui.gadgets.presentations ui.gadgets.viewports ui.gadgets.tables
|
||||
ui.gadgets.tracks ui.gadgets.scrollers ui.gadgets.panes
|
||||
ui.gadgets.borders ui.gadgets.status-bar ui.tools.traceback
|
||||
ui.tools.inspector ;
|
||||
ui.tools.inspector ui.tools.browser ;
|
||||
IN: ui.tools.debugger
|
||||
|
||||
TUPLE: debugger < track error restarts restart-hook restart-list continuation ;
|
||||
|
|
@ -86,9 +86,7 @@ debugger "gestures" f {
|
|||
|
||||
: com-traceback ( debugger -- ) continuation>> traceback-window ;
|
||||
|
||||
: com-help ( debugger -- ) error>> (:help) ;
|
||||
|
||||
\ com-help H{ { +listener+ t } } define-command
|
||||
: com-help ( debugger -- ) error>> error-help-window ;
|
||||
|
||||
: com-edit ( debugger -- ) error>> (:edit) ;
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,20 @@
|
|||
IN: ui.tools.error-list
|
||||
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:"
|
||||
{ $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/syntax-error.tiff" } "Syntax error" { $link "syntax" } }
|
||||
{ { $image "vocab:ui/tools/error-list/icons/compiler-warning.tiff" } "Compiler warning" { $link "compiler-errors" } }
|
||||
{ { $image "vocab:ui/tools/error-list/icons/compiler-error.tiff" } "Compiler error" { $link "compiler-errors" } }
|
||||
{ { $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"
|
||||
|
|
@ -0,0 +1,210 @@
|
|||
! 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 ;
|
||||
IN: ui.tools.error-list
|
||||
|
||||
CONSTANT: error-types
|
||||
{
|
||||
+compiler-warning+
|
||||
+compiler-error+
|
||||
+test-failure+
|
||||
+linkage-error+
|
||||
}
|
||||
|
||||
MEMO: error-list-icon ( object -- object )
|
||||
"vocab:ui/tools/error-list/icons/" ".tiff" surround <image-name> ;
|
||||
|
||||
: error-icon ( type -- icon )
|
||||
{
|
||||
{ +compiler-error+ [ "compiler-error" ] }
|
||||
{ +compiler-warning+ [ "compiler-warning" ] }
|
||||
{ +linkage-error+ [ "linkage-error" ] }
|
||||
{ +test-failure+ [ "unit-test-error" ] }
|
||||
} case error-list-icon ;
|
||||
|
||||
: <checkboxes> ( alist -- gadget )
|
||||
[ <shelf> { 15 0 } >>gap ] dip
|
||||
[ swap <checkbox> add-gadget ] assoc-each ;
|
||||
|
||||
: <error-toggle> ( -- model gadget )
|
||||
#! Linkage errors are not shown by default.
|
||||
error-types [ dup +linkage-error+ eq? not <model> ] { } map>assoc
|
||||
[ [ [ error-icon ] dip ] assoc-map <checkboxes> ]
|
||||
[ <mapping> ] bi ;
|
||||
|
||||
TUPLE: error-list-gadget < tool
|
||||
visible-errors source-file error
|
||||
error-toggle source-file-table error-table error-display ;
|
||||
|
||||
SINGLETON: source-file-renderer
|
||||
|
||||
: source-file-icon ( -- image-name )
|
||||
"source-file" error-list-icon ;
|
||||
|
||||
M: source-file-renderer row-columns
|
||||
drop first2
|
||||
[ [ source-file-icon ] [ ] [ length number>string ] tri* ] output>array ;
|
||||
|
||||
M: source-file-renderer prototype-row
|
||||
drop source-file-icon "" "" 3array ;
|
||||
|
||||
M: source-file-renderer row-value
|
||||
drop dup [ first <pathname> ] when ;
|
||||
|
||||
M: source-file-renderer column-titles
|
||||
drop { "" "File" "Errors" } ;
|
||||
|
||||
M: source-file-renderer column-alignment drop { 0 0 1 } ;
|
||||
|
||||
M: source-file-renderer filled-column drop 1 ;
|
||||
|
||||
: <source-file-model> ( model -- model' )
|
||||
[ group-by-source-file >alist sort-keys ] <arrow> ;
|
||||
|
||||
:: <source-file-table> ( error-list -- table )
|
||||
error-list model>> <source-file-model>
|
||||
source-file-renderer
|
||||
<table>
|
||||
[ invoke-primary-operation ] >>action
|
||||
COLOR: dark-gray >>column-line-color
|
||||
6 >>gap
|
||||
30 >>min-rows
|
||||
30 >>max-rows
|
||||
60 >>min-cols
|
||||
60 >>max-cols
|
||||
t >>selection-required?
|
||||
error-list source-file>> >>selected-value ;
|
||||
|
||||
SINGLETON: error-renderer
|
||||
|
||||
M: error-renderer row-columns
|
||||
drop [
|
||||
{
|
||||
[ source-file-error-type error-icon ]
|
||||
[ line#>> number>string ]
|
||||
[ asset>> unparse-short ]
|
||||
[ error>> summary ]
|
||||
} cleave
|
||||
] output>array ;
|
||||
|
||||
M: error-renderer prototype-row
|
||||
drop [ +compiler-error+ error-icon "" "" "" ] output>array ;
|
||||
|
||||
M: error-renderer row-value
|
||||
drop ;
|
||||
|
||||
M: error-renderer column-titles
|
||||
drop { "" "Line" "Asset" "Error" } ;
|
||||
|
||||
M: error-renderer column-alignment drop { 0 1 0 0 } ;
|
||||
|
||||
: sort-errors ( seq -- seq' )
|
||||
[ [ [ file>> ] [ line#>> ] bi 2array ] compare ] sort ;
|
||||
|
||||
: <error-table-model> ( error-list -- model )
|
||||
[ model>> ] [ source-file>> ] bi
|
||||
[ [ file>> ] [ string>> ] bi* = ] <search>
|
||||
[ sort-errors ] <arrow> ;
|
||||
|
||||
:: <error-table> ( error-list -- table )
|
||||
error-list <error-table-model>
|
||||
error-renderer
|
||||
<table>
|
||||
[ invoke-primary-operation ] >>action
|
||||
COLOR: dark-gray >>column-line-color
|
||||
6 >>gap
|
||||
30 >>min-rows
|
||||
30 >>max-rows
|
||||
60 >>min-cols
|
||||
60 >>max-cols
|
||||
t >>selection-required?
|
||||
error-list error>> >>selected-value ;
|
||||
|
||||
TUPLE: error-display < track ;
|
||||
|
||||
: <error-display> ( error-list -- gadget )
|
||||
vertical error-display new-track
|
||||
add-toolbar
|
||||
swap error>> >>model
|
||||
dup model>> [ print-error ] <pane-control> <scroller> 1 track-add ;
|
||||
|
||||
: com-inspect ( error-display -- )
|
||||
model>> value>> inspector ;
|
||||
|
||||
: com-help ( error-display -- )
|
||||
model>> value>> error>> error-help-window ;
|
||||
|
||||
: com-edit ( error-display -- )
|
||||
model>> value>> edit-error ;
|
||||
|
||||
error-display "toolbar" f {
|
||||
{ f com-inspect }
|
||||
{ f com-help }
|
||||
{ f com-edit }
|
||||
} define-command-map
|
||||
|
||||
: <error-list-toolbar> ( error-list -- toolbar )
|
||||
[ <toolbar> ] [ error-toggle>> "Show errors:" label-on-left add-gadget ] bi ;
|
||||
|
||||
: <error-model> ( visible-errors model -- model' )
|
||||
[ swap '[ source-file-error-type _ at ] filter ] <smart-arrow> ;
|
||||
|
||||
:: <error-list-gadget> ( model -- gadget )
|
||||
vertical error-list-gadget new-track
|
||||
<error-toggle> [ >>error-toggle ] [ >>visible-errors ] bi*
|
||||
dup visible-errors>> model <error-model> >>model
|
||||
f <model> >>source-file
|
||||
f <model> >>error
|
||||
dup <source-file-table> >>source-file-table
|
||||
dup <error-table> >>error-table
|
||||
dup <error-display> >>error-display
|
||||
:> error-list
|
||||
error-list vertical <track>
|
||||
{ 5 5 } >>gap
|
||||
error-list <error-list-toolbar> f track-add
|
||||
error-list source-file-table>> <scroller> "Source files" <labeled-gadget> 1/4 track-add
|
||||
error-list error-table>> <scroller> "Errors" <labeled-gadget> 1/2 track-add
|
||||
error-list error-display>> "Details" <labeled-gadget> 1/4 track-add
|
||||
{ 5 5 } <filled-border> 1 track-add ;
|
||||
|
||||
M: error-list-gadget focusable-child*
|
||||
source-file-table>> ;
|
||||
|
||||
: error-list-help ( -- ) "ui.tools.error-list" com-browse ;
|
||||
|
||||
\ error-list-help H{ { +nullary+ t } } define-command
|
||||
|
||||
error-list-gadget "toolbar" f {
|
||||
{ T{ key-down f f "F1" } error-list-help }
|
||||
} define-command-map
|
||||
|
||||
SYMBOL: compiler-error-model
|
||||
|
||||
compiler-error-model [ f <model> ] initialize
|
||||
|
||||
SINGLETON: updater
|
||||
|
||||
M: updater definitions-changed
|
||||
2drop
|
||||
compiler-errors get-global values
|
||||
test-failures get-global append
|
||||
compiler-error-model get-global
|
||||
set-model ;
|
||||
|
||||
updater remove-definition-observer
|
||||
updater add-definition-observer
|
||||
|
||||
: error-list-window ( -- )
|
||||
compiler-error-model get-global <error-list-gadget>
|
||||
"Compiler errors" open-status-window ;
|
||||
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
|
|
@ -5,7 +5,7 @@ stack-checker summary io.pathnames io.styles kernel namespaces
|
|||
parser prettyprint quotations tools.crossref tools.annotations
|
||||
editors tools.profiler tools.test tools.time tools.walker vocabs
|
||||
vocabs.loader words sequences tools.vocabs classes
|
||||
compiler.units accessors vocabs.parser macros.expander ui
|
||||
compiler.errors compiler.units accessors vocabs.parser macros.expander ui
|
||||
ui.tools.browser ui.tools.listener ui.tools.listener.completion
|
||||
ui.tools.profiler ui.tools.inspector ui.tools.traceback
|
||||
ui.commands ui.gadgets.editors ui.gestures ui.operations
|
||||
|
|
@ -86,6 +86,21 @@ IN: ui.tools.operations
|
|||
{ +listener+ t }
|
||||
} define-operation
|
||||
|
||||
! Compiler errors
|
||||
[ compiler-error? ] \ edit-error H{
|
||||
{ +primary+ t }
|
||||
{ +secondary+ t }
|
||||
{ +listener+ t }
|
||||
} define-operation
|
||||
|
||||
: com-reload ( error -- )
|
||||
file>> run-file ;
|
||||
|
||||
[ compiler-error? ] \ com-reload H{
|
||||
{ +listener+ t }
|
||||
} define-operation
|
||||
|
||||
! Definitions
|
||||
: com-forget ( defspec -- )
|
||||
[ forget ] with-compilation-unit ;
|
||||
|
||||
|
|
@ -173,4 +188,4 @@ interactor
|
|||
"These commands operate on the entire contents of the input area."
|
||||
[ ]
|
||||
[ quot-action ]
|
||||
define-operation-map
|
||||
define-operation-map
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
USING: ui.tools.profiler tools.test ;
|
||||
|
||||
\ profiler-window must-infer
|
||||
|
|
@ -11,6 +11,7 @@ ui.gadgets.tabbed ui.gadgets.status-bar ui.gadgets.borders
|
|||
ui.tools.browser ui.tools.common ui.baseline-alignment
|
||||
ui.operations ui.images ;
|
||||
FROM: models.arrow => <arrow> ;
|
||||
FROM: models.arrow.smart => <smart-arrow> ;
|
||||
FROM: models.product => <product> ;
|
||||
IN: ui.tools.profiler
|
||||
|
||||
|
|
@ -112,8 +113,8 @@ M: method-renderer column-titles drop { "" "Method" "Count" } ;
|
|||
: <methods-model> ( profiler -- model )
|
||||
[
|
||||
[ method-counters <model> ] dip
|
||||
[ generic>> ] [ class>> ] bi 3array <product>
|
||||
[ first3 '[ _ _ method-matches? ] filter ] <arrow>
|
||||
[ generic>> ] [ class>> ] bi
|
||||
[ '[ _ _ method-matches? ] filter ] <smart-arrow>
|
||||
] keep <profiler-model> ;
|
||||
|
||||
: sort-by-name ( obj1 obj2 -- <=> )
|
||||
|
|
@ -208,6 +209,6 @@ profiler-gadget "toolbar" f {
|
|||
: profiler-window ( -- )
|
||||
<profiler-gadget> "Profiling results" open-status-window ;
|
||||
|
||||
: com-profile ( quot -- ) profile profiler-window ;
|
||||
: com-profile ( quot -- ) profile profiler-window ; inline
|
||||
|
||||
MAIN: profiler-window
|
||||
|
|
|
|||
|
|
@ -66,6 +66,7 @@ $nl
|
|||
{ $subsection "ui-listener" }
|
||||
{ $subsection "ui-browser" }
|
||||
{ $subsection "ui-inspector" }
|
||||
{ $subsection "ui.tools.error-list" }
|
||||
{ $subsection "ui.tools.profiler" }
|
||||
{ $subsection "ui-walker" }
|
||||
{ $subsection "ui.tools.deploy" }
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2006, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: memory system kernel tools.vocabs ui.tools.operations
|
||||
ui.tools.listener ui.tools.browser ui.tools.common
|
||||
ui.tools.listener ui.tools.browser ui.tools.common ui.tools.error-list
|
||||
ui.tools.walker ui.commands ui.gestures ui ui.private ;
|
||||
IN: ui.tools
|
||||
|
||||
|
|
|
|||
|
|
@ -2,51 +2,7 @@ IN: compiler.errors
|
|||
USING: help.markup help.syntax vocabs.loader words io
|
||||
quotations words.symbol ;
|
||||
|
||||
ARTICLE: "compiler-errors" "Compiler warnings and errors"
|
||||
"After loading a vocabulary, you might see messages like:"
|
||||
{ $code
|
||||
":errors - print 2 compiler errors."
|
||||
":warnings - print 50 compiler warnings."
|
||||
}
|
||||
"These warnings arise from the compiler's stack effect checker. Warnings are non-fatal conditions -- not all code has a static stack effect, so you try to minimize warnings but understand that in many cases they cannot be eliminated. Errors indicate programming mistakes, such as erroneous stack effect declarations."
|
||||
$nl
|
||||
"The precise warning and error conditions are documented in " { $link "inference-errors" } "."
|
||||
$nl
|
||||
"Words to view warnings and errors:"
|
||||
{ $subsection :errors }
|
||||
{ $subsection :warnings }
|
||||
{ $subsection :linkage }
|
||||
"Words such as " { $link require } " use a combinator which counts errors and prints a report at the end:"
|
||||
{ $subsection with-compiler-errors } ;
|
||||
|
||||
HELP: compiler-errors
|
||||
{ $var-description "Global variable holding an assoc mapping words to compiler errors. This variable is set by " { $link with-compiler-errors } "." } ;
|
||||
|
||||
ABOUT: "compiler-errors"
|
||||
|
||||
HELP: compiler-error
|
||||
{ $values { "error" "an error" } { "word" word } }
|
||||
{ $description "If inside a " { $link with-compiler-errors } ", saves the error for future persual via " { $link :errors } ", " { $link :warnings } " and " { $link :linkage } ". If not inside a " { $link with-compiler-errors } ", ignores the error." } ;
|
||||
|
||||
HELP: compiler-error.
|
||||
{ $values { "error" "an error" } { "word" word } }
|
||||
{ $description "Prints a compiler error to " { $link output-stream } "." } ;
|
||||
|
||||
HELP: compiler-errors.
|
||||
{ $values { "type" symbol } }
|
||||
{ $description "Prints compiler errors to " { $link output-stream } ". The type parameter is one of " { $link +error+ } ", " { $link +warning+ } ", or " { $link +linkage+ } "." } ;
|
||||
HELP: :errors
|
||||
{ $description "Prints all serious compiler errors from the most recent compile to " { $link output-stream } "." } ;
|
||||
|
||||
HELP: :warnings
|
||||
{ $description "Prints all ignorable compiler warnings from the most recent compile to " { $link output-stream } "." } ;
|
||||
|
||||
HELP: :linkage
|
||||
{ $description "Prints all C library interface linkage errors from the most recent compile to " { $link output-stream } "." } ;
|
||||
|
||||
{ :errors :warnings } related-words
|
||||
|
||||
HELP: with-compiler-errors
|
||||
{ $values { "quot" quotation } }
|
||||
{ $description "Calls the quotation and collects any compiler warnings and errors. Compiler warnings and errors are summarized at the end and can be viewed with " { $link :errors } ", " { $link :warnings } ", and " { $link :linkage } "." }
|
||||
{ $notes "Nested calls to " { $link with-compiler-errors } " are ignored, and only the outermost call collects warnings and errors." } ;
|
||||
|
|
|
|||
|
|
@ -1,32 +1,27 @@
|
|||
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||
! Copyright (C) 2007, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel namespaces make assocs io sequences
|
||||
sorting continuations math math.parser ;
|
||||
continuations math math.parser accessors definitions
|
||||
source-files.errors ;
|
||||
IN: compiler.errors
|
||||
|
||||
SYMBOL: +error+
|
||||
SYMBOL: +warning+
|
||||
SYMBOL: +linkage+
|
||||
SYMBOLS: +compiler-error+ +compiler-warning+ +linkage-error+ ;
|
||||
|
||||
GENERIC: compiler-error-type ( error -- ? )
|
||||
TUPLE: compiler-error < source-file-error ;
|
||||
|
||||
M: object compiler-error-type drop +error+ ;
|
||||
|
||||
GENERIC# compiler-error. 1 ( error word -- )
|
||||
M: compiler-error source-file-error-type error>> source-file-error-type ;
|
||||
|
||||
SYMBOL: compiler-errors
|
||||
|
||||
compiler-errors [ H{ } clone ] initialize
|
||||
|
||||
SYMBOL: with-compiler-errors?
|
||||
|
||||
: errors-of-type ( type -- assoc )
|
||||
compiler-errors get-global
|
||||
swap [ [ nip compiler-error-type ] dip eq? ] curry
|
||||
swap [ [ nip source-file-error-type ] dip eq? ] curry
|
||||
assoc-filter ;
|
||||
|
||||
: compiler-errors. ( type -- )
|
||||
errors-of-type >alist sort-keys
|
||||
[ swap compiler-error. ] assoc-each ;
|
||||
|
||||
: (compiler-report) ( what type word -- )
|
||||
over errors-of-type assoc-empty? [ 3drop ] [
|
||||
[
|
||||
|
|
@ -41,27 +36,25 @@ SYMBOL: with-compiler-errors?
|
|||
] if ;
|
||||
|
||||
: compiler-report ( -- )
|
||||
"semantic errors" +error+ "errors" (compiler-report)
|
||||
"semantic warnings" +warning+ "warnings" (compiler-report)
|
||||
"linkage errors" +linkage+ "linkage" (compiler-report) ;
|
||||
"compiler errors" +compiler-error+ "errors" (compiler-report)
|
||||
"compiler warnings" +compiler-warning+ "warnings" (compiler-report)
|
||||
"linkage errors" +linkage-error+ "linkage" (compiler-report) ;
|
||||
|
||||
: :errors ( -- ) +error+ compiler-errors. ;
|
||||
|
||||
: :warnings ( -- ) +warning+ compiler-errors. ;
|
||||
|
||||
: :linkage ( -- ) +linkage+ compiler-errors. ;
|
||||
: <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 ( error word -- )
|
||||
with-compiler-errors? get [
|
||||
compiler-errors get pick
|
||||
[ set-at ] [ delete-at drop ] if
|
||||
] [ 2drop ] if ;
|
||||
compiler-errors get-global pick
|
||||
[ [ [ <compiler-error> ] keep ] dip set-at ] [ delete-at drop ] if ;
|
||||
|
||||
: with-compiler-errors ( quot -- )
|
||||
with-compiler-errors? get "quiet" get or [ call ] [
|
||||
[
|
||||
with-compiler-errors? on
|
||||
V{ } clone compiler-errors set-global
|
||||
[ compiler-report ] [ ] cleanup
|
||||
] with-scope
|
||||
] if ; inline
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
IN: compiler.units.tests
|
||||
USING: definitions compiler.units tools.test arrays sequences words kernel
|
||||
accessors namespaces fry ;
|
||||
IN: compiler.units.tests
|
||||
|
||||
[ [ [ ] define-temp ] with-compilation-unit ] must-infer
|
||||
[ [ [ ] define-temp ] with-nested-compilation-unit ] must-infer
|
||||
|
|
@ -30,4 +30,19 @@ accessors namespaces fry ;
|
|||
"a" get [ "B" ] define
|
||||
] with-compilation-unit
|
||||
"b" get execute
|
||||
] unit-test
|
||||
] unit-test
|
||||
|
||||
! Notify observers even if compilation unit did nothing
|
||||
SINGLETON: observer
|
||||
|
||||
observer add-definition-observer
|
||||
|
||||
SYMBOL: counter
|
||||
|
||||
0 counter set-global
|
||||
|
||||
M: observer definitions-changed 2drop global [ counter inc ] bind ;
|
||||
|
||||
[ ] with-compilation-unit
|
||||
|
||||
[ 1 ] [ counter get-global ] unit-test
|
||||
|
|
@ -3,7 +3,7 @@
|
|||
USING: accessors arrays kernel continuations assocs namespaces
|
||||
sequences words vocabs definitions hashtables init sets
|
||||
math math.order classes classes.algebra classes.tuple
|
||||
classes.tuple.private generic ;
|
||||
classes.tuple.private generic compiler.errors ;
|
||||
IN: compiler.units
|
||||
|
||||
SYMBOL: old-definitions
|
||||
|
|
@ -41,7 +41,7 @@ SYMBOL: compiler-impl
|
|||
HOOK: recompile compiler-impl ( words -- alist )
|
||||
|
||||
! Non-optimizing compiler
|
||||
M: f recompile [ f ] { } map>assoc ;
|
||||
M: f recompile [ [ f swap compiler-error ] each ] [ [ f ] { } map>assoc ] bi ;
|
||||
|
||||
! Trivial compiler. We don't want to touch the code heap
|
||||
! during stage1 bootstrap, it would just waste time.
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@ io.streams.string namespaces classes effects source-files assocs
|
|||
sequences strings io.files io.pathnames definitions
|
||||
continuations sorting classes.tuple compiler.units debugger
|
||||
vocabs vocabs.loader accessors eval combinators lexer
|
||||
vocabs.parser words.symbol multiline ;
|
||||
vocabs.parser words.symbol multiline source-files.errors ;
|
||||
IN: parser.tests
|
||||
|
||||
\ run-file must-infer
|
||||
|
|
|
|||
|
|
@ -190,6 +190,7 @@ SYMBOL: interactive-vocabs
|
|||
"tools.annotations"
|
||||
"tools.crossref"
|
||||
"tools.disassembler"
|
||||
"tools.errors"
|
||||
"tools.memory"
|
||||
"tools.profiler"
|
||||
"tools.test"
|
||||
|
|
|
|||
|
|
@ -568,6 +568,9 @@ M: sequence <=>
|
|||
2dup [ length ] bi@ =
|
||||
[ mismatch not ] [ 2drop f ] if ; inline
|
||||
|
||||
: assert-sequence= ( a b -- )
|
||||
2dup sequence= [ 2drop ] [ assert ] if ;
|
||||
|
||||
: sequence-hashcode-step ( oldhash newpart -- newhash )
|
||||
>fixnum swap [
|
||||
[ -2 fixnum-shift-fast ] [ 5 fixnum-shift-fast ] bi
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,14 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs kernel math.order sorting sequences ;
|
||||
IN: source-files.errors
|
||||
|
||||
TUPLE: source-file-error error asset file line# ;
|
||||
|
||||
: sort-errors ( errors -- alerrors'ist )
|
||||
[ [ [ 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 )
|
||||
|
|
@ -4,7 +4,7 @@ USING: arrays definitions generic assocs kernel math namespaces
|
|||
sequences strings vectors words quotations io io.files
|
||||
io.pathnames combinators sorting splitting math.parser effects
|
||||
continuations checksums checksums.crc32 vocabs hashtables graphs
|
||||
compiler.units io.encodings.utf8 accessors ;
|
||||
compiler.units io.encodings.utf8 accessors source-files.errors ;
|
||||
IN: source-files
|
||||
|
||||
SYMBOL: source-files
|
||||
|
|
@ -77,21 +77,20 @@ M: pathname forget*
|
|||
|
||||
SYMBOL: file
|
||||
|
||||
TUPLE: source-file-error error file ;
|
||||
|
||||
: <source-file-error> ( msg -- error )
|
||||
: wrap-source-file-error ( error -- * )
|
||||
file get rollback-source-file
|
||||
\ source-file-error new
|
||||
file get >>file
|
||||
swap >>error ;
|
||||
f >>line#
|
||||
file get path>> >>file
|
||||
swap >>error rethrow ;
|
||||
|
||||
: with-source-file ( name quot -- )
|
||||
#! Should be called from inside with-compilation-unit.
|
||||
[
|
||||
swap source-file
|
||||
dup file set
|
||||
definitions>> old-definitions set
|
||||
[
|
||||
file get rollback-source-file
|
||||
<source-file-error> rethrow
|
||||
] recover
|
||||
source-file
|
||||
[ file set ]
|
||||
[ definitions>> old-definitions set ] bi
|
||||
] dip
|
||||
[ wrap-source-file-error ] recover
|
||||
] with-scope ; inline
|
||||
|
|
|
|||
Loading…
Reference in New Issue