Merge branch 'master' of git://factorcode.org/git/factor into clean-linux-x86-32
commit
9a0879ac7e
|
@ -58,3 +58,10 @@ $nl
|
||||||
"} cond >>"
|
"} cond >>"
|
||||||
}
|
}
|
||||||
"Note the parse time evaluation with " { $link POSTPONE: << } "." } ;
|
"Note the parse time evaluation with " { $link POSTPONE: << } "." } ;
|
||||||
|
|
||||||
|
ARTICLE: "loading-libs" "Loading native libraries"
|
||||||
|
"Before calling a C library, you must associate its path name on disk with a logical name which Factor uses to identify the library:"
|
||||||
|
{ $subsection add-library }
|
||||||
|
"Once a library has been defined, you can try loading it to see if the path name is correct:"
|
||||||
|
{ $subsection load-library }
|
||||||
|
"If the compiler cannot load a library, or cannot resolve a symbol in a library, a linkage error is reported using the compiler error mechanism (see " { $link "compiler-errors" } "). Once you install the right library, reload the source file containing the " { $link add-library } " form to force the compiler to try loading the library again." ;
|
||||||
|
|
|
@ -4,7 +4,7 @@ USING: accessors init namespaces words words.symbol io
|
||||||
kernel.private math memory continuations kernel io.files
|
kernel.private math memory continuations kernel io.files
|
||||||
io.pathnames io.backend system parser vocabs sequences
|
io.pathnames io.backend system parser vocabs sequences
|
||||||
vocabs.loader combinators splitting source-files strings
|
vocabs.loader combinators splitting source-files strings
|
||||||
definitions assocs compiler.errors compiler.units math.parser
|
definitions assocs compiler.units math.parser
|
||||||
generic sets command-line ;
|
generic sets command-line ;
|
||||||
IN: bootstrap.stage2
|
IN: bootstrap.stage2
|
||||||
|
|
||||||
|
@ -81,14 +81,11 @@ SYMBOL: bootstrap-time
|
||||||
"none" require
|
"none" require
|
||||||
] if
|
] if
|
||||||
|
|
||||||
[
|
load-components
|
||||||
load-components
|
|
||||||
|
|
||||||
millis over - core-bootstrap-time set-global
|
millis over - core-bootstrap-time set-global
|
||||||
|
|
||||||
run-bootstrap-init
|
run-bootstrap-init
|
||||||
] with-compiler-errors
|
|
||||||
:errors
|
|
||||||
|
|
||||||
f error set-global
|
f error set-global
|
||||||
f error-continuation set-global
|
f error-continuation set-global
|
||||||
|
|
|
@ -6,6 +6,7 @@ IN: bootstrap.tools
|
||||||
"bootstrap.image"
|
"bootstrap.image"
|
||||||
"tools.annotations"
|
"tools.annotations"
|
||||||
"tools.crossref"
|
"tools.crossref"
|
||||||
|
"tools.errors"
|
||||||
"tools.deploy"
|
"tools.deploy"
|
||||||
"tools.disassembler"
|
"tools.disassembler"
|
||||||
"tools.memory"
|
"tools.memory"
|
||||||
|
|
|
@ -5,6 +5,7 @@ kernel kernel.private layouts assocs words summary arrays
|
||||||
combinators classes.algebra alien alien.c-types alien.structs
|
combinators classes.algebra alien alien.c-types alien.structs
|
||||||
alien.strings alien.arrays alien.complex sets libc alien.libraries
|
alien.strings alien.arrays alien.complex sets libc alien.libraries
|
||||||
continuations.private fry cpu.architecture
|
continuations.private fry cpu.architecture
|
||||||
|
source-files.errors
|
||||||
compiler.errors
|
compiler.errors
|
||||||
compiler.alien
|
compiler.alien
|
||||||
compiler.cfg
|
compiler.cfg
|
||||||
|
@ -379,8 +380,7 @@ TUPLE: no-such-library name ;
|
||||||
M: no-such-library summary
|
M: no-such-library summary
|
||||||
drop "Library not found" ;
|
drop "Library not found" ;
|
||||||
|
|
||||||
M: no-such-library compiler-error-type
|
M: no-such-library error-type drop +linkage-error+ ;
|
||||||
drop +linkage+ ;
|
|
||||||
|
|
||||||
: no-such-library ( name -- )
|
: no-such-library ( name -- )
|
||||||
\ no-such-library boa
|
\ no-such-library boa
|
||||||
|
@ -391,8 +391,7 @@ TUPLE: no-such-symbol name ;
|
||||||
M: no-such-symbol summary
|
M: no-such-symbol summary
|
||||||
drop "Symbol not found" ;
|
drop "Symbol not found" ;
|
||||||
|
|
||||||
M: no-such-symbol compiler-error-type
|
M: no-such-symbol error-type drop +linkage-error+ ;
|
||||||
drop +linkage+ ;
|
|
||||||
|
|
||||||
: no-such-symbol ( name -- )
|
: no-such-symbol ( name -- )
|
||||||
\ no-such-symbol boa
|
\ no-such-symbol boa
|
||||||
|
|
|
@ -1,5 +1,7 @@
|
||||||
USING: help.markup help.syntax words io parser
|
USING: assocs compiler.cfg.builder compiler.cfg.optimizer
|
||||||
assocs words.private sequences compiler.units quotations ;
|
compiler.errors compiler.tree.builder compiler.tree.optimizer
|
||||||
|
compiler.units help.markup help.syntax io parser quotations
|
||||||
|
sequences words words.private ;
|
||||||
IN: compiler
|
IN: compiler
|
||||||
|
|
||||||
HELP: enable-compiler
|
HELP: enable-compiler
|
||||||
|
@ -18,6 +20,24 @@ ARTICLE: "compiler-usage" "Calling the optimizing compiler"
|
||||||
{ $subsection compile-call }
|
{ $subsection compile-call }
|
||||||
"Higher-level words can be found in " { $link "compilation-units" } "." ;
|
"Higher-level words can be found in " { $link "compilation-units" } "." ;
|
||||||
|
|
||||||
|
ARTICLE: "compiler-impl" "Compiler implementation"
|
||||||
|
"The " { $vocab-link "compiler" } "vocabulary, in addition to providing the user-visible words of the compiler, implements the main compilation loop."
|
||||||
|
$nl
|
||||||
|
"Words are added to the " { $link compile-queue } " variable as needed and compiled."
|
||||||
|
{ $subsection compile-queue }
|
||||||
|
"Once compiled, a word is added to the assoc stored in the " { $link compiled } " variable. When compilation is complete, this assoc is passed to " { $link modify-code-heap } "."
|
||||||
|
$nl
|
||||||
|
"The " { $link (compile) } " word performs the actual task of compiling an individual word. The process proceeds as follows:"
|
||||||
|
{ $list
|
||||||
|
{ "The " { $link frontend } " word calls " { $link build-tree-from-word } ". If this fails, the error is passed to " { $link fail } ". The logic for ignoring compile warnings generated for inline words and macros is located here. If the error is not ignorable, it is added to the global " { $link compiler-errors } " assoc (see " { $link "compiler-errors" } ")." }
|
||||||
|
{ "If the word contains a breakpoint, compilation ends here. Otherwise, all remaining steps execute until machine code is generated. Any further errors thrown by the compiler are not reported as compile errors, but instead are ordinary exceptions. This is because they indicate bugs in the compiler, not errors in user code." }
|
||||||
|
{ "The " { $link frontend } " word then calls " { $link optimize-tree } ". This produces the final optimized tree IR, and this stage of the compiler is complete." }
|
||||||
|
{ "The " { $link backend } " word calls " { $link build-cfg } " followed by " { $link optimize-cfg } " and a few other stages. Finally, it calls " { $link save-asm } ", and adds any uncompiled words called by this word to the compilation queue with " { $link maybe-compile } "." }
|
||||||
|
}
|
||||||
|
"If compilation fails, the word is stored in the " { $link compiled } " assoc with a value of " { $link f } ". This causes the VM to compile the word with the non-optimizing compiler."
|
||||||
|
$nl
|
||||||
|
"Calling " { $link modify-code-heap } " is handled not by the " { $vocab-link "compiler" } " vocabulary, but rather " { $vocab-link "compiler.units" } ". The optimizing compiler merely provides an implementation of the " { $link recompile } " generic word." ;
|
||||||
|
|
||||||
ARTICLE: "compiler" "Optimizing compiler"
|
ARTICLE: "compiler" "Optimizing compiler"
|
||||||
"Factor includes two compilers which work behind the scenes. Words are always compiled, and the compilers do not have to be invoked explicitly. For the most part, compilation is fully transparent. However, there are a few things worth knowing about the compilation process."
|
"Factor includes two compilers which work behind the scenes. Words are always compiled, and the compilers do not have to be invoked explicitly. For the most part, compilation is fully transparent. However, there are a few things worth knowing about the compilation process."
|
||||||
$nl
|
$nl
|
||||||
|
@ -31,7 +51,8 @@ $nl
|
||||||
"The optimizing compiler also trades off compile time for performance of generated code, so loading certain vocabularies might take a while. Saving the image after loading vocabularies can save you a lot of time that you would spend waiting for the same code to load in every coding session; see " { $link "images" } " for information."
|
"The optimizing compiler also trades off compile time for performance of generated code, so loading certain vocabularies might take a while. Saving the image after loading vocabularies can save you a lot of time that you would spend waiting for the same code to load in every coding session; see " { $link "images" } " for information."
|
||||||
{ $subsection "compiler-errors" }
|
{ $subsection "compiler-errors" }
|
||||||
{ $subsection "hints" }
|
{ $subsection "hints" }
|
||||||
{ $subsection "compiler-usage" } ;
|
{ $subsection "compiler-usage" }
|
||||||
|
{ $subsection "compiler-impl" } ;
|
||||||
|
|
||||||
ABOUT: "compiler"
|
ABOUT: "compiler"
|
||||||
|
|
||||||
|
|
|
@ -2,7 +2,7 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors kernel namespaces arrays sequences io words fry
|
USING: accessors kernel namespaces arrays sequences io words fry
|
||||||
continuations vocabs assocs dlists definitions math graphs generic
|
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
|
stack-checker.state stack-checker.inlining combinators.short-circuit
|
||||||
compiler.errors compiler.units compiler.tree.builder
|
compiler.errors compiler.units compiler.tree.builder
|
||||||
compiler.tree.optimizer compiler.cfg.builder compiler.cfg.optimizer
|
compiler.tree.optimizer compiler.cfg.builder compiler.cfg.optimizer
|
||||||
|
@ -53,22 +53,30 @@ SYMBOLS: +optimized+ +unoptimized+ ;
|
||||||
f swap compiler-error ;
|
f swap compiler-error ;
|
||||||
|
|
||||||
: ignore-error? ( word error -- ? )
|
: ignore-error? ( word error -- ? )
|
||||||
[ [ inline? ] [ macro? ] bi or ]
|
|
||||||
[ compiler-error-type +warning+ eq? ] bi* and ;
|
|
||||||
|
|
||||||
: fail ( word error -- * )
|
|
||||||
[ 2dup ignore-error? [ 2drop ] [ swap compiler-error ] if ]
|
|
||||||
[
|
[
|
||||||
drop
|
{
|
||||||
[ compiled-unxref ]
|
[ inline? ]
|
||||||
[ f swap compiled get set-at ]
|
[ macro? ]
|
||||||
[ +unoptimized+ save-compiled-status ]
|
[ "transform-quot" word-prop ]
|
||||||
tri
|
[ "no-compile" word-prop ]
|
||||||
] 2bi
|
[ "special" word-prop ]
|
||||||
|
} 1||
|
||||||
|
] [ error-type +compiler-warning+ eq? ] bi* and ;
|
||||||
|
|
||||||
|
: (fail) ( word -- * )
|
||||||
|
[ compiled-unxref ]
|
||||||
|
[ f swap compiled get set-at ]
|
||||||
|
[ +unoptimized+ save-compiled-status ]
|
||||||
|
tri
|
||||||
return ;
|
return ;
|
||||||
|
|
||||||
|
: fail ( word error -- * )
|
||||||
|
[ 2dup ignore-error? [ drop f ] when swap compiler-error ] [ drop (fail) ] 2bi ;
|
||||||
|
|
||||||
: frontend ( word -- nodes )
|
: frontend ( word -- nodes )
|
||||||
[ build-tree-from-word ] [ fail ] recover optimize-tree ;
|
dup contains-breakpoints? [ (fail) ] [
|
||||||
|
[ build-tree-from-word ] [ fail ] recover optimize-tree
|
||||||
|
] if ;
|
||||||
|
|
||||||
! Only switch this off for debugging.
|
! Only switch this off for debugging.
|
||||||
SYMBOL: compile-dependencies?
|
SYMBOL: compile-dependencies?
|
||||||
|
@ -122,6 +130,8 @@ t compile-dependencies? set-global
|
||||||
: compile-call ( quot -- )
|
: compile-call ( quot -- )
|
||||||
[ dup infer define-temp ] with-compilation-unit execute ;
|
[ dup infer define-temp ] with-compilation-unit execute ;
|
||||||
|
|
||||||
|
\ compile-call t "no-compile" set-word-prop
|
||||||
|
|
||||||
SINGLETON: optimizing-compiler
|
SINGLETON: optimizing-compiler
|
||||||
|
|
||||||
M: optimizing-compiler recompile ( words -- alist )
|
M: optimizing-compiler recompile ( words -- alist )
|
||||||
|
|
|
@ -0,0 +1,34 @@
|
||||||
|
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 messages arise from the compiler's stack effect checker. Production code should not have any warnings and errors in it. Warning and error conditions are documented in " { $link "inference-errors" } "."
|
||||||
|
$nl
|
||||||
|
"Words to view warnings and errors:"
|
||||||
|
{ $subsection :warnings }
|
||||||
|
{ $subsection :errors }
|
||||||
|
{ $subsection :linkage }
|
||||||
|
"Compiler warnings and errors are reported using the " { $link "tools.errors" } " mechanism and are shown in the " { $link "ui.tools.error-list" } "." ;
|
||||||
|
|
||||||
|
HELP: compiler-error
|
||||||
|
{ $values { "error" "an error" } { "word" word } }
|
||||||
|
{ $description "Saves the error for future persual via " { $link :errors } ", " { $link :warnings } " and " { $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
|
||||||
|
|
||||||
|
ABOUT: "compiler-errors"
|
|
@ -0,0 +1,63 @@
|
||||||
|
! Copyright (C) 2007, 2009 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: accessors source-files.errors kernel namespaces assocs
|
||||||
|
tools.errors ;
|
||||||
|
IN: compiler.errors
|
||||||
|
|
||||||
|
TUPLE: compiler-error < source-file-error ;
|
||||||
|
|
||||||
|
M: compiler-error error-type error>> error-type ;
|
||||||
|
|
||||||
|
SYMBOL: compiler-errors
|
||||||
|
|
||||||
|
compiler-errors [ H{ } clone ] initialize
|
||||||
|
|
||||||
|
SYMBOLS: +compiler-error+ +compiler-warning+ +linkage-error+ ;
|
||||||
|
|
||||||
|
: errors-of-type ( type -- assoc )
|
||||||
|
compiler-errors get-global
|
||||||
|
swap [ [ nip error-type ] dip eq? ] curry
|
||||||
|
assoc-filter ;
|
||||||
|
|
||||||
|
T{ error-type
|
||||||
|
{ type +compiler-error+ }
|
||||||
|
{ word ":errors" }
|
||||||
|
{ plural "compiler errors" }
|
||||||
|
{ icon "vocab:ui/tools/error-list/icons/compiler-error.tiff" }
|
||||||
|
{ quot [ +compiler-error+ errors-of-type values ] }
|
||||||
|
{ forget-quot [ compiler-errors get delete-at ] }
|
||||||
|
} define-error-type
|
||||||
|
|
||||||
|
T{ error-type
|
||||||
|
{ type +compiler-warning+ }
|
||||||
|
{ word ":warnings" }
|
||||||
|
{ plural "compiler warnings" }
|
||||||
|
{ icon "vocab:ui/tools/error-list/icons/compiler-warning.tiff" }
|
||||||
|
{ quot [ +compiler-warning+ errors-of-type values ] }
|
||||||
|
{ forget-quot [ compiler-errors get delete-at ] }
|
||||||
|
} define-error-type
|
||||||
|
|
||||||
|
T{ error-type
|
||||||
|
{ type +linkage-error+ }
|
||||||
|
{ word ":linkage" }
|
||||||
|
{ plural "linkage errors" }
|
||||||
|
{ icon "vocab:ui/tools/error-list/icons/linkage-error.tiff" }
|
||||||
|
{ quot [ +linkage-error+ errors-of-type values ] }
|
||||||
|
{ forget-quot [ compiler-errors get delete-at ] }
|
||||||
|
} define-error-type
|
||||||
|
|
||||||
|
: <compiler-error> ( error word -- compiler-error )
|
||||||
|
\ compiler-error <definition-error> ;
|
||||||
|
|
||||||
|
: compiler-error ( error word -- )
|
||||||
|
compiler-errors get-global pick
|
||||||
|
[ [ [ <compiler-error> ] keep ] dip set-at ] [ delete-at drop ] if ;
|
||||||
|
|
||||||
|
: compiler-errors. ( type -- )
|
||||||
|
errors-of-type values errors. ;
|
||||||
|
|
||||||
|
: :errors ( -- ) +compiler-error+ compiler-errors. ;
|
||||||
|
|
||||||
|
: :warnings ( -- ) +compiler-warning+ compiler-errors. ;
|
||||||
|
|
||||||
|
: :linkage ( -- ) +linkage-error+ compiler-errors. ;
|
|
@ -42,8 +42,10 @@ IN: compiler.tree.builder
|
||||||
: check-cannot-infer ( word -- )
|
: check-cannot-infer ( word -- )
|
||||||
dup "cannot-infer" word-prop [ cannot-infer-effect ] [ drop ] if ;
|
dup "cannot-infer" word-prop [ cannot-infer-effect ] [ drop ] if ;
|
||||||
|
|
||||||
|
TUPLE: do-not-compile word ;
|
||||||
|
|
||||||
: check-no-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 )
|
: build-tree-from-word ( word -- nodes )
|
||||||
[
|
[
|
||||||
|
@ -56,3 +58,6 @@ IN: compiler.tree.builder
|
||||||
} cleave
|
} cleave
|
||||||
] maybe-cannot-infer
|
] maybe-cannot-infer
|
||||||
] with-tree-builder ;
|
] with-tree-builder ;
|
||||||
|
|
||||||
|
: contains-breakpoints? ( word -- ? )
|
||||||
|
def>> [ word? ] filter [ "break?" word-prop ] any? ;
|
||||||
|
|
|
@ -148,7 +148,11 @@ DEFER: (flat-length)
|
||||||
] sum-outputs ;
|
] sum-outputs ;
|
||||||
|
|
||||||
: should-inline? ( #call word -- ? )
|
: should-inline? ( #call word -- ? )
|
||||||
dup "inline" word-prop [ 2drop t ] [ inlining-rank 5 >= ] if ;
|
{
|
||||||
|
{ [ dup contains-breakpoints? ] [ 2drop f ] }
|
||||||
|
{ [ dup "inline" word-prop ] [ 2drop t ] }
|
||||||
|
[ inlining-rank 5 >= ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
SYMBOL: history
|
SYMBOL: history
|
||||||
|
|
||||||
|
|
|
@ -7,6 +7,10 @@ IN: concurrency.promises
|
||||||
HELP: promise
|
HELP: promise
|
||||||
{ $class-description "The class of write-once promises." } ;
|
{ $class-description "The class of write-once promises." } ;
|
||||||
|
|
||||||
|
HELP: <promise>
|
||||||
|
{ $values { "promise" promise } }
|
||||||
|
{ $description "Creates a new promise which may be fulfilled by calling " { $link fulfill } "." } ;
|
||||||
|
|
||||||
HELP: promise-fulfilled?
|
HELP: promise-fulfilled?
|
||||||
{ $values { "promise" promise } { "?" "a boolean" } }
|
{ $values { "promise" promise } { "?" "a boolean" } }
|
||||||
{ $description "Tests if " { $link fulfill } " has previously been called on the promise, in which case " { $link ?promise } " will return immediately without blocking." } ;
|
{ $description "Tests if " { $link fulfill } " has previously been called on the promise, in which case " { $link ?promise } " will return immediately without blocking." } ;
|
||||||
|
|
|
@ -8,8 +8,9 @@ classes.mixin classes.tuple continuations continuations.private
|
||||||
combinators generic.math classes.builtin classes compiler.units
|
combinators generic.math classes.builtin classes compiler.units
|
||||||
generic.standard vocabs init kernel.private io.encodings
|
generic.standard vocabs init kernel.private io.encodings
|
||||||
accessors math.order destructors source-files parser
|
accessors math.order destructors source-files parser
|
||||||
classes.tuple.parser effects.parser lexer compiler.errors
|
classes.tuple.parser effects.parser lexer
|
||||||
generic.parser strings.parser vocabs.loader vocabs.parser ;
|
generic.parser strings.parser vocabs.loader vocabs.parser see
|
||||||
|
source-files.errors ;
|
||||||
IN: debugger
|
IN: debugger
|
||||||
|
|
||||||
GENERIC: error. ( error -- )
|
GENERIC: error. ( error -- )
|
||||||
|
@ -213,14 +214,13 @@ M: condition error-help error>> error-help ;
|
||||||
|
|
||||||
M: assert summary drop "Assertion failed" ;
|
M: assert summary drop "Assertion failed" ;
|
||||||
|
|
||||||
M: assert error.
|
M: assert-sequence summary drop "Assertion failed" ;
|
||||||
"Assertion failed" print
|
|
||||||
|
M: assert-sequence error.
|
||||||
standard-table-style [
|
standard-table-style [
|
||||||
15 length-limit set
|
[ "=== Expected:" print expected>> stack. ]
|
||||||
5 line-limit set
|
[ "=== Got:" print got>> stack. ] bi
|
||||||
[ expect>> [ [ "Expect:" write ] with-cell pprint-cell ] with-row ]
|
] tabular-output ;
|
||||||
[ got>> [ [ "Got:" write ] with-cell pprint-cell ] with-row ] bi
|
|
||||||
] tabular-output nl ;
|
|
||||||
|
|
||||||
M: immutable summary drop "Sequence is immutable" ;
|
M: immutable summary drop "Sequence is immutable" ;
|
||||||
|
|
||||||
|
@ -268,20 +268,6 @@ M: duplicate-slot-names summary
|
||||||
M: invalid-slot-name summary
|
M: invalid-slot-name summary
|
||||||
drop "Invalid slot name" ;
|
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 ;
|
|
||||||
|
|
||||||
M: source-file-error compute-restarts
|
|
||||||
error>> compute-restarts ;
|
|
||||||
|
|
||||||
M: source-file-error error-help
|
|
||||||
error>> error-help ;
|
|
||||||
|
|
||||||
M: not-in-a-method-error summary
|
M: not-in-a-method-error summary
|
||||||
drop "call-next-method can only be called in a method definition" ;
|
drop "call-next-method can only be called in a method definition" ;
|
||||||
|
|
||||||
|
@ -309,12 +295,6 @@ M: lexer-error compute-restarts
|
||||||
M: lexer-error error-help
|
M: lexer-error error-help
|
||||||
error>> error-help ;
|
error>> error-help ;
|
||||||
|
|
||||||
M: object compiler-error. ( error word -- )
|
|
||||||
nl
|
|
||||||
"While compiling " write pprint ": " print
|
|
||||||
nl
|
|
||||||
print-error ;
|
|
||||||
|
|
||||||
M: bad-effect summary
|
M: bad-effect summary
|
||||||
drop "Bad stack effect declaration" ;
|
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
|
IN: editors
|
||||||
|
|
||||||
ARTICLE: "editor" "Editor integration"
|
ARTICLE: "editor" "Editor integration"
|
||||||
|
@ -13,6 +14,9 @@ ARTICLE: "editor" "Editor integration"
|
||||||
|
|
||||||
ABOUT: "editor"
|
ABOUT: "editor"
|
||||||
|
|
||||||
|
HELP: edit-hook
|
||||||
|
{ $var-description "A quotation with stack effect " { $snippet "( file line -- )" } ". If not set, the " { $link edit } " word throws a condition with restarts for loading one of the sub-vocabularies of the " { $vocab-link "editors" } " vocabulary." } ;
|
||||||
|
|
||||||
HELP: edit
|
HELP: edit
|
||||||
{ $values { "defspec" "a definition specifier" } }
|
{ $values { "defspec" "a definition specifier" } }
|
||||||
{ $description "Opens the source file containing the definition using the current " { $link edit-hook } ". See " { $link "editor" } "." }
|
{ $description "Opens the source file containing the definition using the current " { $link edit-hook } ". See " { $link "editor" } "." }
|
||||||
|
|
|
@ -1,8 +1,8 @@
|
||||||
! Copyright (C) 2005, 2009 Slava Pestov.
|
! Copyright (C) 2005, 2009 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: parser lexer kernel namespaces sequences definitions
|
USING: parser lexer kernel namespaces sequences definitions io.files
|
||||||
io.files io.backend io.pathnames io summary continuations
|
io.backend io.pathnames io summary continuations tools.crossref
|
||||||
tools.crossref tools.vocabs prettyprint source-files assocs
|
tools.vocabs prettyprint source-files source-files.errors assocs
|
||||||
vocabs vocabs.loader splitting accessors debugger prettyprint
|
vocabs vocabs.loader splitting accessors debugger prettyprint
|
||||||
help.topics ;
|
help.topics ;
|
||||||
IN: editors
|
IN: editors
|
||||||
|
@ -57,7 +57,7 @@ M: lexer-error error-line
|
||||||
[ error>> error-line ] [ line>> ] bi or ;
|
[ error>> error-line ] [ line>> ] bi or ;
|
||||||
|
|
||||||
M: source-file-error error-file
|
M: source-file-error error-file
|
||||||
[ error>> error-file ] [ file>> path>> ] bi or ;
|
[ error>> error-file ] [ file>> ] bi or ;
|
||||||
|
|
||||||
M: source-file-error error-line
|
M: source-file-error error-line
|
||||||
error>> error-line ;
|
error>> error-line ;
|
||||||
|
@ -81,6 +81,9 @@ M: object error-line
|
||||||
: :edit ( -- )
|
: :edit ( -- )
|
||||||
error get (:edit) ;
|
error get (:edit) ;
|
||||||
|
|
||||||
|
: edit-error ( error -- )
|
||||||
|
[ file>> ] [ line#>> ] bi 2dup and [ edit-location ] [ 2drop ] if ;
|
||||||
|
|
||||||
: edit-each ( seq -- )
|
: edit-each ( seq -- )
|
||||||
[
|
[
|
||||||
[ "Editing " write . ]
|
[ "Editing " write . ]
|
||||||
|
|
|
@ -1,18 +1,23 @@
|
||||||
IN: eval
|
IN: eval
|
||||||
USING: help.markup help.syntax strings io ;
|
USING: help.markup help.syntax strings io effects ;
|
||||||
|
|
||||||
HELP: eval
|
HELP: eval
|
||||||
{ $values { "str" string } }
|
{ $values { "str" string } { "effect" effect } }
|
||||||
{ $description "Parses Factor source code from a string, and calls the resulting quotation." }
|
{ $description "Parses Factor source code from a string, and calls the resulting quotation, which must have the given stack effect." }
|
||||||
|
{ $errors "Throws an error if the input is malformed, or if the evaluation itself throws an error." } ;
|
||||||
|
|
||||||
|
HELP: eval(
|
||||||
|
{ $syntax "eval( inputs -- outputs )" }
|
||||||
|
{ $description "Parses Factor source code from the string at the top of the stack, and calls the resulting quotation, which must have the given stack effect." }
|
||||||
{ $errors "Throws an error if the input is malformed, or if the evaluation itself throws an error." } ;
|
{ $errors "Throws an error if the input is malformed, or if the evaluation itself throws an error." } ;
|
||||||
|
|
||||||
HELP: eval>string
|
HELP: eval>string
|
||||||
{ $values { "str" string } { "output" string } }
|
{ $values { "str" string } { "output" string } }
|
||||||
{ $description "Evaluates the Factor code in " { $snippet "str" } " with " { $link output-stream } " rebound to a string output stream, then outputs the resulting string." } ;
|
{ $description "Evaluates the Factor code in " { $snippet "str" } " with " { $link output-stream } " rebound to a string output stream, then outputs the resulting string. The code in the string must not take or leave any values on the stack." } ;
|
||||||
|
|
||||||
ARTICLE: "eval" "Evaluating strings at runtime"
|
ARTICLE: "eval" "Evaluating strings at runtime"
|
||||||
"The " { $vocab-link "eval" } " vocabulary implements support for evaluating strings at runtime."
|
"The " { $vocab-link "eval" } " vocabulary implements support for evaluating strings at runtime."
|
||||||
{ $subsection eval }
|
{ $subsection POSTPONE: eval( }
|
||||||
{ $subsection eval>string } ;
|
{ $subsection eval>string } ;
|
||||||
|
|
||||||
ABOUT: "eval"
|
ABOUT: "eval"
|
||||||
|
|
|
@ -1,23 +1,25 @@
|
||||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: splitting parser compiler.units kernel namespaces
|
USING: splitting parser compiler.units kernel namespaces
|
||||||
debugger io.streams.string fry ;
|
debugger io.streams.string fry combinators effects.parser ;
|
||||||
IN: eval
|
IN: eval
|
||||||
|
|
||||||
: parse-string ( str -- quot )
|
: parse-string ( str -- quot )
|
||||||
[ string-lines parse-lines ] with-compilation-unit ;
|
[ string-lines parse-lines ] with-compilation-unit ;
|
||||||
|
|
||||||
: (eval) ( str -- )
|
: (eval) ( str effect -- )
|
||||||
parse-string call ;
|
[ parse-string ] dip call-effect ; inline
|
||||||
|
|
||||||
: eval ( str -- )
|
: eval ( str effect -- )
|
||||||
[ (eval) ] with-file-vocabs ;
|
[ (eval) ] with-file-vocabs ; inline
|
||||||
|
|
||||||
|
SYNTAX: eval( \ eval parse-call( ;
|
||||||
|
|
||||||
: (eval>string) ( str -- output )
|
: (eval>string) ( str -- output )
|
||||||
[
|
[
|
||||||
"quiet" on
|
"quiet" on
|
||||||
parser-notes off
|
parser-notes off
|
||||||
'[ _ (eval) ] try
|
'[ _ (( -- )) (eval) ] try
|
||||||
] with-string-writer ;
|
] with-string-writer ;
|
||||||
|
|
||||||
: eval>string ( str -- output )
|
: eval>string ( str -- output )
|
||||||
|
|
|
@ -74,7 +74,7 @@ $nl
|
||||||
"shuffle-words"
|
"shuffle-words"
|
||||||
"words"
|
"words"
|
||||||
"generic"
|
"generic"
|
||||||
"tools"
|
"handbook-tools-reference"
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
ARTICLE: "cookbook-combinators" "Control flow cookbook"
|
ARTICLE: "cookbook-combinators" "Control flow cookbook"
|
||||||
|
|
|
@ -5,7 +5,7 @@ math system strings sbufs vectors byte-arrays quotations
|
||||||
io.streams.byte-array classes.builtin parser lexer
|
io.streams.byte-array classes.builtin parser lexer
|
||||||
classes.predicate classes.union classes.intersection
|
classes.predicate classes.union classes.intersection
|
||||||
classes.singleton classes.tuple help.vocabs math.parser
|
classes.singleton classes.tuple help.vocabs math.parser
|
||||||
accessors definitions ;
|
accessors definitions sets ;
|
||||||
IN: help.handbook
|
IN: help.handbook
|
||||||
|
|
||||||
ARTICLE: "conventions" "Conventions"
|
ARTICLE: "conventions" "Conventions"
|
||||||
|
@ -197,29 +197,6 @@ ARTICLE: "io" "Input and output"
|
||||||
{ $subsection "io.ports" }
|
{ $subsection "io.ports" }
|
||||||
{ $see-also "destructors" } ;
|
{ $see-also "destructors" } ;
|
||||||
|
|
||||||
ARTICLE: "tools" "Developer tools"
|
|
||||||
{ $subsection "tools.vocabs" }
|
|
||||||
"Exploratory tools:"
|
|
||||||
{ $subsection "see" }
|
|
||||||
{ $subsection "editor" }
|
|
||||||
{ $subsection "listener" }
|
|
||||||
{ $subsection "tools.crossref" }
|
|
||||||
{ $subsection "inspector" }
|
|
||||||
{ $subsection "tools.completion" }
|
|
||||||
{ $subsection "summary" }
|
|
||||||
"Debugging tools:"
|
|
||||||
{ $subsection "tools.annotations" }
|
|
||||||
{ $subsection "tools.test" }
|
|
||||||
{ $subsection "tools.threads" }
|
|
||||||
"Performance tools:"
|
|
||||||
{ $subsection "tools.memory" }
|
|
||||||
{ $subsection "profiling" }
|
|
||||||
{ $subsection "timing" }
|
|
||||||
{ $subsection "tools.disassembler" }
|
|
||||||
"Deployment tools:"
|
|
||||||
{ $subsection "tools.deploy" }
|
|
||||||
{ $see-also "ui-tools" } ;
|
|
||||||
|
|
||||||
ARTICLE: "article-index" "Article index"
|
ARTICLE: "article-index" "Article index"
|
||||||
{ $index [ articles get keys ] } ;
|
{ $index [ articles get keys ] } ;
|
||||||
|
|
||||||
|
@ -248,59 +225,79 @@ ARTICLE: "class-index" "Class index"
|
||||||
|
|
||||||
USING: help.cookbook help.tutorial ;
|
USING: help.cookbook help.tutorial ;
|
||||||
|
|
||||||
ARTICLE: "handbook-language-reference" "Language reference"
|
ARTICLE: "handbook-language-reference" "The language"
|
||||||
"Fundamentals:"
|
{ $heading "Fundamentals" }
|
||||||
{ $subsection "conventions" }
|
{ $subsection "conventions" }
|
||||||
{ $subsection "syntax" }
|
{ $subsection "syntax" }
|
||||||
{ $subsection "effects" }
|
{ $subsection "effects" }
|
||||||
"Data types:"
|
{ $subsection "evaluator" }
|
||||||
|
{ $heading "Data types" }
|
||||||
{ $subsection "booleans" }
|
{ $subsection "booleans" }
|
||||||
{ $subsection "numbers" }
|
{ $subsection "numbers" }
|
||||||
{ $subsection "collections" }
|
{ $subsection "collections" }
|
||||||
"Evaluation semantics:"
|
{ $heading "Evaluation" }
|
||||||
{ $subsection "evaluator" }
|
|
||||||
{ $subsection "words" }
|
{ $subsection "words" }
|
||||||
{ $subsection "shuffle-words" }
|
{ $subsection "shuffle-words" }
|
||||||
{ $subsection "combinators" }
|
{ $subsection "combinators" }
|
||||||
{ $subsection "errors" }
|
{ $subsection "errors" }
|
||||||
{ $subsection "continuations" }
|
{ $subsection "continuations" }
|
||||||
"Named values:"
|
{ $heading "Named values" }
|
||||||
{ $subsection "locals" }
|
{ $subsection "locals" }
|
||||||
{ $subsection "namespaces" }
|
{ $subsection "namespaces" }
|
||||||
{ $subsection "namespaces-global" }
|
{ $subsection "namespaces-global" }
|
||||||
{ $subsection "values" }
|
{ $subsection "values" }
|
||||||
"Abstractions:"
|
{ $heading "Abstractions" }
|
||||||
{ $subsection "objects" }
|
{ $subsection "objects" }
|
||||||
{ $subsection "destructors" }
|
{ $subsection "destructors" }
|
||||||
{ $subsection "macros" }
|
{ $subsection "macros" }
|
||||||
{ $subsection "fry" }
|
{ $subsection "fry" }
|
||||||
"Program organization:"
|
{ $heading "Program organization" }
|
||||||
{ $subsection "vocabs.loader" }
|
{ $subsection "vocabs.loader" }
|
||||||
"Vocabularies tagged " { $link T{ vocab-tag { name "extensions" } } } " implement various additional language abstractions." ;
|
"Vocabularies tagged " { $link T{ vocab-tag { name "extensions" } } } " implement various additional language abstractions." ;
|
||||||
|
|
||||||
ARTICLE: "handbook-environment-reference" "Environment reference"
|
ARTICLE: "handbook-system-reference" "The implementation"
|
||||||
"Parse time and compile time:"
|
{ $heading "Parse time and compile time" }
|
||||||
{ $subsection "parser" }
|
{ $subsection "parser" }
|
||||||
{ $subsection "definitions" }
|
{ $subsection "definitions" }
|
||||||
{ $subsection "vocabularies" }
|
{ $subsection "vocabularies" }
|
||||||
{ $subsection "source-files" }
|
{ $subsection "source-files" }
|
||||||
{ $subsection "compiler" }
|
{ $subsection "compiler" }
|
||||||
"Tools:"
|
{ $heading "Virtual machine" }
|
||||||
{ $subsection "prettyprint" }
|
|
||||||
{ $subsection "tools" }
|
|
||||||
{ $subsection "help" }
|
|
||||||
{ $subsection "inference" }
|
|
||||||
{ $subsection "images" }
|
{ $subsection "images" }
|
||||||
"VM:"
|
|
||||||
{ $subsection "cli" }
|
{ $subsection "cli" }
|
||||||
{ $subsection "rc-files" }
|
{ $subsection "rc-files" }
|
||||||
{ $subsection "init" }
|
{ $subsection "init" }
|
||||||
{ $subsection "system" }
|
{ $subsection "system" }
|
||||||
{ $subsection "layouts" } ;
|
{ $subsection "layouts" } ;
|
||||||
|
|
||||||
ARTICLE: "handbook-library-reference" "Library reference"
|
ARTICLE: "handbook-tools-reference" "Developer tools"
|
||||||
"This index only includes articles from loaded vocabularies. To explore more vocabularies, see " { $link "vocab-index" } "."
|
"The below tools are text-based. " { $link "ui-tools" } " are documented separately."
|
||||||
{ $index [ "handbook" orphan-articles remove ] } ;
|
{ $heading "Workflow" }
|
||||||
|
{ $subsection "listener" }
|
||||||
|
{ $subsection "editor" }
|
||||||
|
{ $subsection "tools.vocabs" }
|
||||||
|
{ $subsection "tools.test" }
|
||||||
|
{ $subsection "help" }
|
||||||
|
{ $heading "Debugging" }
|
||||||
|
{ $subsection "prettyprint" }
|
||||||
|
{ $subsection "inspector" }
|
||||||
|
{ $subsection "tools.annotations" }
|
||||||
|
{ $subsection "inference" }
|
||||||
|
{ $heading "Browsing" }
|
||||||
|
{ $subsection "see" }
|
||||||
|
{ $subsection "tools.crossref" }
|
||||||
|
{ $heading "Performance" }
|
||||||
|
{ $subsection "timing" }
|
||||||
|
{ $subsection "profiling" }
|
||||||
|
{ $subsection "tools.memory" }
|
||||||
|
{ $subsection "tools.threads" }
|
||||||
|
{ $subsection "tools.disassembler" }
|
||||||
|
{ $heading "Deployment" }
|
||||||
|
{ $subsection "tools.deploy" } ;
|
||||||
|
|
||||||
|
ARTICLE: "handbook-library-reference" "Libraries"
|
||||||
|
"This index lists articles from loaded vocabularies which are not subsections of any other article. To explore more vocabularies, see " { $link "vocab-index" } "."
|
||||||
|
{ $index [ orphan-articles { "help.home" "handbook" } diff ] } ;
|
||||||
|
|
||||||
ARTICLE: "handbook" "Factor handbook"
|
ARTICLE: "handbook" "Factor handbook"
|
||||||
"Learn the language:"
|
"Learn the language:"
|
||||||
|
@ -308,11 +305,11 @@ ARTICLE: "handbook" "Factor handbook"
|
||||||
{ $subsection "first-program" }
|
{ $subsection "first-program" }
|
||||||
"Reference material:"
|
"Reference material:"
|
||||||
{ $subsection "handbook-language-reference" }
|
{ $subsection "handbook-language-reference" }
|
||||||
{ $subsection "handbook-environment-reference" }
|
|
||||||
{ $subsection "io" }
|
{ $subsection "io" }
|
||||||
{ $subsection "ui" }
|
{ $subsection "ui" }
|
||||||
|
{ $subsection "handbook-system-reference" }
|
||||||
|
{ $subsection "handbook-tools-reference" }
|
||||||
{ $subsection "ui-tools" }
|
{ $subsection "ui-tools" }
|
||||||
{ $subsection "unicode" }
|
|
||||||
{ $subsection "alien" }
|
{ $subsection "alien" }
|
||||||
{ $subsection "handbook-library-reference" }
|
{ $subsection "handbook-library-reference" }
|
||||||
"Explore loaded libraries:"
|
"Explore loaded libraries:"
|
||||||
|
|
|
@ -8,6 +8,7 @@ ARTICLE: "help.home" "Factor documentation"
|
||||||
{ $link "handbook" }
|
{ $link "handbook" }
|
||||||
{ $link "vocab-index" }
|
{ $link "vocab-index" }
|
||||||
{ $link "ui-tools" }
|
{ $link "ui-tools" }
|
||||||
|
{ $link "ui-listener" }
|
||||||
}
|
}
|
||||||
{ $heading "Recently visited" }
|
{ $heading "Recently visited" }
|
||||||
{ $table
|
{ $table
|
||||||
|
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
|
@ -0,0 +1,176 @@
|
||||||
|
! 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" simple-lint-error ] when ;
|
||||||
|
|
||||||
|
: check-article-title ( article -- )
|
||||||
|
article-title first LETTER?
|
||||||
|
[ "Article title must begin with a capital letter" simple-lint-error ] 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 ;
|
|
@ -14,6 +14,10 @@ $nl
|
||||||
"To run help lint, use one of the following two words:"
|
"To run help lint, use one of the following two words:"
|
||||||
{ $subsection help-lint }
|
{ $subsection help-lint }
|
||||||
{ $subsection help-lint-all }
|
{ $subsection help-lint-all }
|
||||||
|
"Once a help lint run completes, failures can be listed:"
|
||||||
|
{ $subsection :lint-failures }
|
||||||
|
"Help lint failures are also shown in the " { $link "ui.tools.error-list" } "."
|
||||||
|
$nl
|
||||||
"Help lint performs the following checks:"
|
"Help lint performs the following checks:"
|
||||||
{ $list
|
{ $list
|
||||||
"ensures examples run and produce stated output"
|
"ensures examples run and produce stated output"
|
||||||
|
|
|
@ -1,161 +1,53 @@
|
||||||
! 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: fry accessors sequences parser kernel help help.markup
|
USING: assocs continuations fry help help.lint.checks
|
||||||
help.topics words strings classes tools.vocabs namespaces make
|
help.topics io kernel namespaces parser sequences
|
||||||
io io.streams.string prettyprint definitions arrays vectors
|
source-files.errors tools.vocabs vocabs words classes
|
||||||
combinators combinators.short-circuit splitting debugger
|
locals tools.errors ;
|
||||||
hashtables sorting effects vocabs vocabs.loader assocs editors
|
FROM: help.lint.checks => all-vocabs ;
|
||||||
continuations classes.predicate macros math sets eval
|
|
||||||
vocabs.parser words.symbol values grouping unicode.categories
|
|
||||||
sequences.deep ;
|
|
||||||
IN: help.lint
|
IN: help.lint
|
||||||
|
|
||||||
SYMBOL: vocabs-quot
|
SYMBOL: lint-failures
|
||||||
|
|
||||||
: check-example ( element -- )
|
lint-failures [ H{ } clone ] initialize
|
||||||
'[
|
|
||||||
_ rest [
|
|
||||||
but-last "\n" join
|
|
||||||
[ (eval>string) ] call( code -- output )
|
|
||||||
"\n" ?tail drop
|
|
||||||
] keep
|
|
||||||
peek assert=
|
|
||||||
] vocabs-quot get call( quot -- ) ;
|
|
||||||
|
|
||||||
: check-examples ( element -- )
|
TUPLE: help-lint-error < source-file-error ;
|
||||||
\ $example swap elements [ check-example ] each ;
|
|
||||||
|
|
||||||
: extract-values ( element -- seq )
|
SYMBOL: +help-lint-failure+
|
||||||
\ $values swap elements dup empty? [
|
|
||||||
first rest [ first ] map prune natural-sort
|
|
||||||
] unless ;
|
|
||||||
|
|
||||||
: effect-values ( word -- seq )
|
T{ error-type
|
||||||
stack-effect
|
{ type +help-lint-failure+ }
|
||||||
[ in>> ] [ out>> ] bi append
|
{ word ":lint-failures" }
|
||||||
[ dup pair? [ first ] when effect>string ] map
|
{ plural "help lint failures" }
|
||||||
prune natural-sort ;
|
{ icon "vocab:ui/tools/error-list/icons/help-lint-error.tiff" }
|
||||||
|
{ quot [ lint-failures get values ] }
|
||||||
|
{ forget-quot [ lint-failures get delete-at ] }
|
||||||
|
} define-error-type
|
||||||
|
|
||||||
: contains-funky-elements? ( element -- ? )
|
M: help-lint-error error-type drop +help-lint-failure+ ;
|
||||||
{
|
|
||||||
$shuffle
|
|
||||||
$values-x/y
|
|
||||||
$predicate
|
|
||||||
$class-description
|
|
||||||
$error-description
|
|
||||||
} swap '[ _ elements empty? not ] any? ;
|
|
||||||
|
|
||||||
: don't-check-word? ( word -- ? )
|
<PRIVATE
|
||||||
{
|
|
||||||
[ macro? ]
|
|
||||||
[ symbol? ]
|
|
||||||
[ value-word? ]
|
|
||||||
[ parsing-word? ]
|
|
||||||
[ "declared-effect" word-prop not ]
|
|
||||||
} 1|| ;
|
|
||||||
|
|
||||||
: check-values ( word element -- )
|
: <help-lint-error> ( error topic -- help-lint-error )
|
||||||
{
|
\ help-lint-error <definition-error> ;
|
||||||
[
|
|
||||||
[ 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 -- )
|
PRIVATE>
|
||||||
\ $values swap elements
|
|
||||||
null swap deep-member?
|
|
||||||
[ "$values should not contain null" throw ] when ;
|
|
||||||
|
|
||||||
: check-see-also ( element -- )
|
: help-lint-error ( error topic -- )
|
||||||
\ $see-also swap elements [
|
lint-failures get pick
|
||||||
rest dup prune [ length ] bi@ assert=
|
[ [ [ <help-lint-error> ] keep ] dip set-at ] [ delete-at drop ] if
|
||||||
] each ;
|
notify-error-observers ;
|
||||||
|
|
||||||
: vocab-exists? ( name -- ? )
|
<PRIVATE
|
||||||
[ vocab ] [ "all-vocabs" get member? ] bi or ;
|
|
||||||
|
|
||||||
: check-modules ( element -- )
|
:: check-something ( topic quot -- )
|
||||||
\ $vocab-link swap elements [
|
[ quot call( -- ) f ] [ ] recover
|
||||||
second
|
topic help-lint-error ; inline
|
||||||
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
|
|
||||||
|
|
||||||
: check-word ( word -- )
|
: check-word ( word -- )
|
||||||
[ with-file-vocabs ] vocabs-quot set
|
[ with-file-vocabs ] vocabs-quot set
|
||||||
dup word-help [
|
dup word-help [
|
||||||
dup '[
|
[ >link ] keep '[
|
||||||
_ dup word-help
|
_ dup word-help
|
||||||
[ check-values ]
|
[ check-values ]
|
||||||
[ check-class-description ]
|
[ check-class-description ]
|
||||||
|
@ -165,69 +57,38 @@ M: help-error error.
|
||||||
|
|
||||||
: check-words ( words -- ) [ check-word ] each ;
|
: 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 -- )
|
: check-article ( article -- )
|
||||||
[ with-interactive-vocabs ] vocabs-quot set
|
[ with-interactive-vocabs ] vocabs-quot set
|
||||||
dup '[
|
>link dup '[
|
||||||
_
|
_
|
||||||
[ check-article-title ]
|
[ check-article-title ]
|
||||||
[ article-content check-markup ] bi
|
[ article-content check-markup ] bi
|
||||||
] check-something ;
|
] 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 -- )
|
: check-about ( vocab -- )
|
||||||
dup '[ _ vocab-help [ article drop ] when* ] check-something ;
|
dup '[ _ vocab-help [ article drop ] when* ] check-something ;
|
||||||
|
|
||||||
: check-vocab ( vocab -- seq )
|
: check-vocab ( vocab -- )
|
||||||
"Checking " write dup write "..." print
|
"Checking " write dup write "..." print
|
||||||
[
|
[ vocab check-about ]
|
||||||
[ check-about ]
|
[ words [ check-word ] each ]
|
||||||
[ words [ check-word ] each ]
|
[ vocab-articles get at [ check-article ] each ]
|
||||||
[ "vocab-articles" get at [ check-article ] each ]
|
tri ;
|
||||||
tri
|
|
||||||
] { } make ;
|
|
||||||
|
|
||||||
: run-help-lint ( prefix -- alist )
|
PRIVATE>
|
||||||
|
|
||||||
|
: help-lint ( prefix -- )
|
||||||
[
|
[
|
||||||
all-vocabs-seq [ vocab-name ] map "all-vocabs" set
|
all-vocabs-seq [ vocab-name ] map all-vocabs set
|
||||||
group-articles "vocab-articles" set
|
group-articles vocab-articles set
|
||||||
child-vocabs
|
child-vocabs
|
||||||
[ dup check-vocab ] { } map>assoc
|
[ check-vocab ] each
|
||||||
[ nip empty? not ] assoc-filter
|
|
||||||
] with-scope ;
|
] 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 ;
|
: help-lint-all ( -- ) "" help-lint ;
|
||||||
|
|
||||||
|
: :lint-failures ( -- ) lint-failures get errors. ;
|
||||||
|
|
||||||
: unlinked-words ( words -- seq )
|
: unlinked-words ( words -- seq )
|
||||||
all-word-help [ article-parent not ] filter ;
|
all-word-help [ article-parent not ] filter ;
|
||||||
|
|
||||||
|
@ -235,6 +96,6 @@ M: help-error error.
|
||||||
all-words
|
all-words
|
||||||
[ word-help not ] filter
|
[ word-help not ] filter
|
||||||
[ article-parent ] filter
|
[ article-parent ] filter
|
||||||
[ "predicating" word-prop not ] filter ;
|
[ predicate? not ] filter ;
|
||||||
|
|
||||||
MAIN: help-lint
|
MAIN: help-lint
|
||||||
|
|
|
@ -76,9 +76,11 @@ $nl
|
||||||
{ $code "." }
|
{ $code "." }
|
||||||
"What we just did is called " { $emphasis "interactive testing" } ". A more advanced technique which comes into play with larger programs is " { $link "tools.test" } "."
|
"What we just did is called " { $emphasis "interactive testing" } ". A more advanced technique which comes into play with larger programs is " { $link "tools.test" } "."
|
||||||
$nl
|
$nl
|
||||||
"Open the file named " { $snippet "palindrome-tests.factor" } "; it is located in the same directory as " { $snippet "palindrome.factor" } ", and it was created by the scaffold tool."
|
"Create a test harness file using the scaffold tool:"
|
||||||
|
{ $code "\"palindrome\" scaffold-tests" }
|
||||||
|
"Now, open the file named " { $snippet "palindrome-tests.factor" } "; it is located in the same directory as " { $snippet "palindrome.factor" } ", and it was created by the scaffold tool."
|
||||||
$nl
|
$nl
|
||||||
"We will add some unit tests, which are similar to the interactive tests we did above. Unit tests are defined with the " { $link unit-test } " word, which takes a sequence of expected outputs, and a piece of code. It runs the code, and asserts that it outputs the expected values."
|
"We will add some unit tests, which are similar to the interactive tests we did above. Unit tests are defined with the " { $link POSTPONE: unit-test } " word, which takes a sequence of expected outputs, and a piece of code. It runs the code, and asserts that it outputs the expected values."
|
||||||
$nl
|
$nl
|
||||||
"Add the following three lines to " { $snippet "palindrome-tests.factor" } ":"
|
"Add the following three lines to " { $snippet "palindrome-tests.factor" } ":"
|
||||||
{ $code
|
{ $code
|
||||||
|
|
|
@ -140,7 +140,46 @@ HELP: <process-stream>
|
||||||
{ "desc" "a launch descriptor" }
|
{ "desc" "a launch descriptor" }
|
||||||
{ "encoding" "an encoding descriptor" }
|
{ "encoding" "an encoding descriptor" }
|
||||||
{ "stream" "a bidirectional stream" } }
|
{ "stream" "a bidirectional stream" } }
|
||||||
{ $description "Launches a process and redirects its input and output via a pair of pipes which may be read and written as a stream of the given encoding." } ;
|
{ $description "Launches a process and redirects its input and output via a pair of pipes which may be read and written as a stream with the given encoding." } ;
|
||||||
|
|
||||||
|
HELP: <process-reader>
|
||||||
|
{ $values
|
||||||
|
{ "desc" "a launch descriptor" }
|
||||||
|
{ "encoding" "an encoding descriptor" }
|
||||||
|
{ "stream" "an input stream" } }
|
||||||
|
{ $description "Launches a process and redirects its output via a pipe which may be read as a stream with the given encoding." } ;
|
||||||
|
|
||||||
|
HELP: <process-writer>
|
||||||
|
{ $values
|
||||||
|
{ "desc" "a launch descriptor" }
|
||||||
|
{ "encoding" "an encoding descriptor" }
|
||||||
|
{ "stream" "an output stream" }
|
||||||
|
}
|
||||||
|
{ $description "Launches a process and redirects its input via a pipe which may be written to as a stream with the given encoding." } ;
|
||||||
|
|
||||||
|
HELP: with-process-stream
|
||||||
|
{ $values
|
||||||
|
{ "desc" "a launch descriptor" }
|
||||||
|
{ "encoding" "an encoding descriptor" }
|
||||||
|
{ "quot" quotation }
|
||||||
|
}
|
||||||
|
{ $description "Launches a process and redirects its input and output via a pair of pipes. The quotation is called with " { $link input-stream } " and " { $link output-stream } " rebound to these pipes." } ;
|
||||||
|
|
||||||
|
HELP: with-process-reader
|
||||||
|
{ $values
|
||||||
|
{ "desc" "a launch descriptor" }
|
||||||
|
{ "encoding" "an encoding descriptor" }
|
||||||
|
{ "quot" quotation }
|
||||||
|
}
|
||||||
|
{ $description "Launches a process and redirects its output via a pipe. The quotation is called with " { $link input-stream } " and " { $link output-stream } " rebound to this pipe." } ;
|
||||||
|
|
||||||
|
HELP: with-process-writer
|
||||||
|
{ $values
|
||||||
|
{ "desc" "a launch descriptor" }
|
||||||
|
{ "encoding" "an encoding descriptor" }
|
||||||
|
{ "quot" quotation }
|
||||||
|
}
|
||||||
|
{ $description "Launches a process and redirects its input via a pipe. The quotation is called with " { $link input-stream } " and " { $link output-stream } " rebound to this pipe." } ;
|
||||||
|
|
||||||
HELP: wait-for-process
|
HELP: wait-for-process
|
||||||
{ $values { "process" process } { "status" object } }
|
{ $values { "process" process } { "status" object } }
|
||||||
|
@ -175,7 +214,11 @@ ARTICLE: "io.launcher.launch" "Launching processes"
|
||||||
"Redirecting standard input and output to a pipe:"
|
"Redirecting standard input and output to a pipe:"
|
||||||
{ $subsection <process-reader> }
|
{ $subsection <process-reader> }
|
||||||
{ $subsection <process-writer> }
|
{ $subsection <process-writer> }
|
||||||
{ $subsection <process-stream> } ;
|
{ $subsection <process-stream> }
|
||||||
|
"Combinators built on top of the above:"
|
||||||
|
{ $subsection with-process-reader }
|
||||||
|
{ $subsection with-process-writer }
|
||||||
|
{ $subsection with-process-stream } ;
|
||||||
|
|
||||||
ARTICLE: "io.launcher.examples" "Launcher examples"
|
ARTICLE: "io.launcher.examples" "Launcher examples"
|
||||||
"Starting a command and waiting for it to finish:"
|
"Starting a command and waiting for it to finish:"
|
||||||
|
|
|
@ -274,7 +274,7 @@ HELP: <input>
|
||||||
{ $description "Creates a new " { $link input } "." } ;
|
{ $description "Creates a new " { $link input } "." } ;
|
||||||
|
|
||||||
HELP: standard-table-style
|
HELP: standard-table-style
|
||||||
{ $values { "style" hashtable } }
|
{ $values { "value" hashtable } }
|
||||||
{ $description "Outputs a table style where cells are separated by 5-pixel gaps and framed by a light gray border. This style can be passed to " { $link tabular-output } "." } ;
|
{ $description "Outputs a table style where cells are separated by 5-pixel gaps and framed by a light gray border. This style can be passed to " { $link tabular-output } "." } ;
|
||||||
|
|
||||||
ARTICLE: "io.streams.plain" "Plain writer streams"
|
ARTICLE: "io.streams.plain" "Plain writer streams"
|
||||||
|
|
|
@ -135,11 +135,11 @@ SYMBOL: wrap-margin
|
||||||
SYMBOL: table-gap
|
SYMBOL: table-gap
|
||||||
SYMBOL: table-border
|
SYMBOL: table-border
|
||||||
|
|
||||||
: standard-table-style ( -- style )
|
CONSTANT: standard-table-style
|
||||||
H{
|
H{
|
||||||
{ table-gap { 5 5 } }
|
{ table-gap { 5 5 } }
|
||||||
{ table-border T{ rgba f 0.8 0.8 0.8 1.0 } }
|
{ table-border T{ rgba f 0.8 0.8 0.8 1.0 } }
|
||||||
} ;
|
}
|
||||||
|
|
||||||
! Input history
|
! Input history
|
||||||
TUPLE: input string ;
|
TUPLE: input string ;
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
USING: help.markup help.syntax kernel io system prettyprint ;
|
USING: help.markup help.syntax kernel io system prettyprint continuations ;
|
||||||
IN: listener
|
IN: listener
|
||||||
|
|
||||||
ARTICLE: "listener-watch" "Watching variables in the listener"
|
ARTICLE: "listener-watch" "Watching variables in the listener"
|
||||||
|
@ -41,32 +41,18 @@ $nl
|
||||||
{ $example "{ 1 2 3 } [\n .\n] each" "1\n2\n3" }
|
{ $example "{ 1 2 3 } [\n .\n] each" "1\n2\n3" }
|
||||||
"The listener knows when to expect more input by looking at the height of the stack. Parsing words such as " { $link POSTPONE: { } " leave elements on the parser stack, and corresponding words such as " { $link POSTPONE: } } " pop them."
|
"The listener knows when to expect more input by looking at the height of the stack. Parsing words such as " { $link POSTPONE: { } " leave elements on the parser stack, and corresponding words such as " { $link POSTPONE: } } " pop them."
|
||||||
{ $subsection "listener-watch" }
|
{ $subsection "listener-watch" }
|
||||||
"You can start a nested listener or exit a listener using the following words:"
|
"To start a nested listener:"
|
||||||
{ $subsection listener }
|
{ $subsection listener }
|
||||||
{ $subsection bye }
|
"To exit the listener, invoke the " { $link return } " word."
|
||||||
"Finally, the multi-line expression reading word can be used independently of the rest of the listener:"
|
$nl
|
||||||
|
"Multi-line quotations can be read independently of the rest of the listener:"
|
||||||
{ $subsection read-quot } ;
|
{ $subsection read-quot } ;
|
||||||
|
|
||||||
ABOUT: "listener"
|
ABOUT: "listener"
|
||||||
|
|
||||||
<PRIVATE
|
|
||||||
|
|
||||||
HELP: quit-flag
|
|
||||||
{ $var-description "Variable set to true by " { $link bye } " word; it forces the next iteration of the " { $link listener } " loop to end." } ;
|
|
||||||
|
|
||||||
PRIVATE>
|
|
||||||
|
|
||||||
HELP: read-quot
|
HELP: read-quot
|
||||||
{ $values { "quot/f" "a parsed quotation, or " { $link f } " indicating end of file" } }
|
{ $values { "quot/f" "a parsed quotation, or " { $link f } " indicating end of file" } }
|
||||||
{ $description "Reads a Factor expression which possibly spans more than one line from " { $link input-stream } ". Additional lines of input are read while the parser stack height is greater than one. Since structural parsing words push partial quotations on the stack, this will keep on reading input until all delimited parsing words are terminated." } ;
|
{ $description "Reads a Factor expression which possibly spans more than one line from " { $link input-stream } ". Additional lines of input are read while the parser stack height is greater than one. Since structural parsing words push partial quotations on the stack, this will keep on reading input until all delimited parsing words are terminated." } ;
|
||||||
|
|
||||||
HELP: listen
|
|
||||||
{ $description "Prompts for an expression on " { $link input-stream } " and evaluates it. On end of file, " { $link quit-flag } " is set to terminate the listener loop." }
|
|
||||||
{ $errors "If the expression input by the user throws an error, the error is printed to " { $link output-stream } " and the word returns normally." } ;
|
|
||||||
|
|
||||||
HELP: listener
|
HELP: listener
|
||||||
{ $description "Prompts for expressions on " { $link input-stream } " and evaluates them until end of file is reached." } ;
|
{ $description "Prompts for expressions on " { $link input-stream } " and evaluates them until end of file is reached." } ;
|
||||||
|
|
||||||
HELP: bye
|
|
||||||
{ $description "Exits the current listener." }
|
|
||||||
{ $notes "This word is for interactive use only. To exit the Factor runtime, use " { $link exit } "." } ;
|
|
||||||
|
|
|
@ -4,7 +4,7 @@ USING: arrays hashtables io kernel math math.parser memory
|
||||||
namespaces parser lexer sequences strings io.styles
|
namespaces parser lexer sequences strings io.styles
|
||||||
vectors words generic system combinators continuations debugger
|
vectors words generic system combinators continuations debugger
|
||||||
definitions compiler.units accessors colors prettyprint fry
|
definitions compiler.units accessors colors prettyprint fry
|
||||||
sets vocabs.parser ;
|
sets vocabs.parser source-files.errors locals ;
|
||||||
IN: listener
|
IN: listener
|
||||||
|
|
||||||
GENERIC: stream-read-quot ( stream -- quot/f )
|
GENERIC: stream-read-quot ( stream -- quot/f )
|
||||||
|
@ -32,17 +32,9 @@ M: object stream-read-quot
|
||||||
|
|
||||||
: read-quot ( -- quot/f ) input-stream get stream-read-quot ;
|
: read-quot ( -- quot/f ) input-stream get stream-read-quot ;
|
||||||
|
|
||||||
<PRIVATE
|
|
||||||
|
|
||||||
SYMBOL: quit-flag
|
|
||||||
|
|
||||||
PRIVATE>
|
|
||||||
|
|
||||||
: bye ( -- ) quit-flag on ;
|
|
||||||
|
|
||||||
SYMBOL: visible-vars
|
SYMBOL: visible-vars
|
||||||
|
|
||||||
: show-var ( var -- ) visible-vars [ swap suffix ] change ;
|
: show-var ( var -- ) visible-vars [ swap suffix ] change ;
|
||||||
|
|
||||||
: show-vars ( seq -- ) visible-vars [ swap union ] change ;
|
: show-vars ( seq -- ) visible-vars [ swap union ] change ;
|
||||||
|
|
||||||
|
@ -68,6 +60,8 @@ SYMBOL: max-stack-items
|
||||||
|
|
||||||
10 max-stack-items set-global
|
10 max-stack-items set-global
|
||||||
|
|
||||||
|
SYMBOL: error-summary-hook
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
: title. ( string -- )
|
: title. ( string -- )
|
||||||
|
@ -96,26 +90,44 @@ SYMBOL: max-stack-items
|
||||||
] dip
|
] dip
|
||||||
] when stack. ;
|
] when stack. ;
|
||||||
|
|
||||||
: stacks. ( -- )
|
: datastack. ( datastack -- )
|
||||||
display-stacks? get [
|
display-stacks? get [
|
||||||
datastack [ nl "--- Data stack:" title. trimmed-stack. ] unless-empty
|
[ nl "--- Data stack:" title. trimmed-stack. ] unless-empty
|
||||||
] when ;
|
] [ drop ] if ;
|
||||||
|
|
||||||
: prompt. ( -- )
|
: prompt. ( -- )
|
||||||
"( " in get auto-use? get [ " - auto" append ] when " )" 3append
|
in get auto-use? get [ " - auto" append ] when "( " " )" surround
|
||||||
H{ { background T{ rgba f 1 0.7 0.7 1 } } } format bl flush ;
|
H{ { background T{ rgba f 1 0.7 0.7 1 } } } format bl flush ;
|
||||||
|
|
||||||
: listen ( -- )
|
[ error-summary ] error-summary-hook set-global
|
||||||
visible-vars. stacks. prompt.
|
|
||||||
[ read-quot [ [ call-error-hook ] recover ] [ bye ] if* ]
|
|
||||||
[ dup lexer-error? [ call-error-hook ] [ rethrow ] if ] recover ;
|
|
||||||
|
|
||||||
: until-quit ( -- )
|
: call-error-summary-hook ( -- )
|
||||||
quit-flag get [ quit-flag off ] [ listen until-quit ] if ;
|
error-summary-hook get call( -- ) ;
|
||||||
|
|
||||||
|
:: (listener) ( datastack -- )
|
||||||
|
call-error-summary-hook
|
||||||
|
visible-vars.
|
||||||
|
datastack datastack.
|
||||||
|
prompt.
|
||||||
|
|
||||||
|
[
|
||||||
|
read-quot [
|
||||||
|
'[ datastack _ with-datastack ]
|
||||||
|
[ call-error-hook datastack ]
|
||||||
|
recover
|
||||||
|
] [ return ] if*
|
||||||
|
] [
|
||||||
|
dup lexer-error?
|
||||||
|
[ call-error-hook datastack ]
|
||||||
|
[ rethrow ]
|
||||||
|
if
|
||||||
|
] recover
|
||||||
|
|
||||||
|
(listener) ;
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
: listener ( -- )
|
: listener ( -- )
|
||||||
[ until-quit ] with-interactive-vocabs ;
|
[ [ { } (listener) ] with-interactive-vocabs ] with-return ;
|
||||||
|
|
||||||
MAIN: listener
|
MAIN: listener
|
||||||
|
|
|
@ -61,3 +61,5 @@ M: memoized reset-word
|
||||||
|
|
||||||
: invalidate-memoized ( inputs... word -- )
|
: invalidate-memoized ( inputs... word -- )
|
||||||
[ stack-effect in>> packer call ] [ "memoize" word-prop delete-at ] bi ;
|
[ stack-effect in>> packer call ] [ "memoize" word-prop delete-at ] bi ;
|
||||||
|
|
||||||
|
\ invalidate-memoized t "no-compile" set-word-prop
|
|
@ -137,9 +137,6 @@ ERROR: no-content-disposition multipart ;
|
||||||
[ no-content-disposition ]
|
[ no-content-disposition ]
|
||||||
} case ;
|
} case ;
|
||||||
|
|
||||||
: assert-sequence= ( a b -- )
|
|
||||||
2dup sequence= [ 2drop ] [ assert ] if ;
|
|
||||||
|
|
||||||
: read-assert-sequence= ( sequence -- )
|
: read-assert-sequence= ( sequence -- )
|
||||||
[ length read ] keep assert-sequence= ;
|
[ length read ] keep assert-sequence= ;
|
||||||
|
|
||||||
|
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
|
@ -7,15 +7,15 @@ HELP: <smart-arrow>
|
||||||
{ $examples
|
{ $examples
|
||||||
"A model which adds the values of two existing models:"
|
"A model which adds the values of two existing models:"
|
||||||
{ $example
|
{ $example
|
||||||
"USING: models models.arrows.smart accessors math prettyprint ;"
|
"USING: models models.arrow.smart accessors kernel math prettyprint ;"
|
||||||
"1 <model> 2 <model> [ + ] <smart-arrow>"
|
"1 <model> 2 <model> [ + ] <smart-arrow>"
|
||||||
"[ activate-model ] [ value>> ] bi ."
|
"[ activate-model ] [ value>> ] bi ."
|
||||||
"3"
|
"3"
|
||||||
}
|
}
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
ARTICLE: "models.arrows.smart" "Smart arrow models"
|
ARTICLE: "models.arrow.smart" "Smart arrow models"
|
||||||
"The " { $vocab-link "models.arrows.smart" } " vocabulary generalizes arrows to arbitrary input arity. They're called “smart” because they resemble " { $link "combinators.smart" } "."
|
"The " { $vocab-link "models.arrow.smart" } " vocabulary generalizes arrows to arbitrary input arity. They're called “smart” because they resemble " { $link "combinators.smart" } "."
|
||||||
{ $subsection <smart-arrow> } ;
|
{ $subsection <smart-arrow> } ;
|
||||||
|
|
||||||
ABOUT: "models.arrows.smart"
|
ABOUT: "models.arrow.smart"
|
|
@ -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
|
! Copyright (C) 2008, 2009 Slava Pestov
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: arrays fry kernel models.product models.arrow
|
USING: fry kernel models.arrow.smart sequences unicode.case ;
|
||||||
sequences unicode.case ;
|
|
||||||
IN: models.search
|
IN: models.search
|
||||||
|
|
||||||
: <search> ( values search quot -- model )
|
: <search> ( values search quot -- model )
|
||||||
[ 2array <product> ] dip
|
'[ _ curry filter ] <smart-arrow> ; inline
|
||||||
'[ first2 _ curry filter ] <arrow> ;
|
|
||||||
|
|
||||||
: <string-search> ( values search quot -- model )
|
: <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.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: arrays fry kernel models.product models.arrow
|
USING: sorting models.arrow.smart fry ;
|
||||||
sequences sorting ;
|
|
||||||
IN: models.sort
|
IN: models.sort
|
||||||
|
|
||||||
: <sort> ( values sort -- model )
|
: <sort> ( values sort -- model )
|
||||||
2array <product> [ first2 sort ] <arrow> ;
|
[ '[ _ call( obj1 obj2 -- <=> ) ] sort ] <smart-arrow> ; inline
|
|
@ -128,7 +128,9 @@ M: single-texture dispose*
|
||||||
[ display-list>> [ delete-dlist ] when* ] bi ;
|
[ display-list>> [ delete-dlist ] when* ] bi ;
|
||||||
|
|
||||||
M: single-texture draw-scaled-texture
|
M: single-texture draw-scaled-texture
|
||||||
dup texture>> [ draw-textured-rect ] [ 2drop ] if ;
|
2dup dim>> = [ nip draw-texture ] [
|
||||||
|
dup texture>> [ draw-textured-rect ] [ 2drop ] if
|
||||||
|
] if ;
|
||||||
|
|
||||||
TUPLE: multi-texture grid display-list loc disposed ;
|
TUPLE: multi-texture grid display-list loc disposed ;
|
||||||
|
|
||||||
|
@ -166,6 +168,8 @@ TUPLE: multi-texture grid display-list loc disposed ;
|
||||||
f multi-texture boa
|
f multi-texture boa
|
||||||
] with-destructors ;
|
] with-destructors ;
|
||||||
|
|
||||||
|
M: multi-texture draw-scaled-texture nip draw-texture ;
|
||||||
|
|
||||||
M: multi-texture dispose* grid>> [ [ dispose ] each ] each ;
|
M: multi-texture dispose* grid>> [ [ dispose ] each ] each ;
|
||||||
|
|
||||||
CONSTANT: max-texture-size { 512 512 }
|
CONSTANT: max-texture-size { 512 512 }
|
||||||
|
|
|
@ -21,7 +21,7 @@ TUPLE: deque { front read-only } { back read-only } ;
|
||||||
[ back>> ] [ front>> ] bi deque boa ;
|
[ back>> ] [ front>> ] bi deque boa ;
|
||||||
|
|
||||||
: flipped ( deque quot -- newdeque )
|
: flipped ( deque quot -- newdeque )
|
||||||
[ flip ] dip call flip ;
|
[ flip ] dip call flip ; inline
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
: deque-empty? ( deque -- ? )
|
: deque-empty? ( deque -- ? )
|
||||||
|
|
|
@ -2,7 +2,8 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: kernel generic sequences io words arrays summary effects
|
USING: kernel generic sequences io words arrays summary effects
|
||||||
continuations assocs accessors namespaces compiler.errors
|
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
|
IN: stack-checker.errors
|
||||||
|
|
||||||
: pretty-word ( word -- word' )
|
: pretty-word ( word -- word' )
|
||||||
|
@ -10,7 +11,7 @@ IN: stack-checker.errors
|
||||||
|
|
||||||
TUPLE: inference-error error type word ;
|
TUPLE: inference-error error type word ;
|
||||||
|
|
||||||
M: inference-error compiler-error-type type>> ;
|
M: inference-error error-type type>> ;
|
||||||
|
|
||||||
: (inference-error) ( ... class type -- * )
|
: (inference-error) ( ... class type -- * )
|
||||||
[ boa ] dip
|
[ boa ] dip
|
||||||
|
@ -18,10 +19,10 @@ M: inference-error compiler-error-type type>> ;
|
||||||
\ inference-error boa rethrow ; inline
|
\ inference-error boa rethrow ; inline
|
||||||
|
|
||||||
: inference-error ( ... class -- * )
|
: inference-error ( ... class -- * )
|
||||||
+error+ (inference-error) ; inline
|
+compiler-error+ (inference-error) ; inline
|
||||||
|
|
||||||
: inference-warning ( ... class -- * )
|
: inference-warning ( ... class -- * )
|
||||||
+warning+ (inference-error) ; inline
|
+compiler-warning+ (inference-error) ; inline
|
||||||
|
|
||||||
TUPLE: literal-expected what ;
|
TUPLE: literal-expected what ;
|
||||||
|
|
||||||
|
@ -81,3 +82,8 @@ TUPLE: unknown-primitive-error ;
|
||||||
|
|
||||||
: unknown-primitive-error ( -- * )
|
: unknown-primitive-error ( -- * )
|
||||||
\ unknown-primitive-error inference-warning ;
|
\ 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.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors kernel prettyprint io debugger
|
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
|
IN: stack-checker.errors.prettyprint
|
||||||
|
|
||||||
|
M: inference-error summary error>> summary ;
|
||||||
|
|
||||||
M: inference-error error-help error>> error-help ;
|
M: inference-error error-help error>> error-help ;
|
||||||
|
|
||||||
M: inference-error error.
|
M: inference-error error.
|
||||||
[ word>> [ "In word: " write . ] when* ] [ error>> error. ] bi ;
|
[ word>> [ "In word: " write . ] when* ] [ error>> error. ] bi ;
|
||||||
|
|
||||||
M: literal-expected error.
|
M: literal-expected summary
|
||||||
"Got a computed value where a " write what>> write " was expected" print ;
|
[ "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.
|
M: unbalanced-branches-error error.
|
||||||
"Unbalanced branches:" print
|
dup summary print
|
||||||
[ quots>> ] [ branches>> [ length <effect> ] { } assoc>map ] bi zip
|
[ quots>> ] [ branches>> [ length <effect> ] { } assoc>map ] bi zip
|
||||||
[ [ first pprint-short bl ] [ second effect>string print ] bi ] each ;
|
[ [ first pprint-short bl ] [ second effect>string print ] bi ] each ;
|
||||||
|
|
||||||
|
@ -25,16 +32,18 @@ M: too-many-r> summary
|
||||||
drop
|
drop
|
||||||
"Quotation pops retain stack elements which it did not push" ;
|
"Quotation pops retain stack elements which it did not push" ;
|
||||||
|
|
||||||
M: missing-effect error.
|
M: missing-effect summary
|
||||||
"The word " write
|
[
|
||||||
word>> pprint
|
"The word " %
|
||||||
" must declare a stack effect" print ;
|
word>> name>> %
|
||||||
|
" must declare a stack effect" %
|
||||||
|
] "" make ;
|
||||||
|
|
||||||
M: effect-error error.
|
M: effect-error summary
|
||||||
"Stack effects of the word " write
|
[
|
||||||
[ word>> pprint " do not match." print ]
|
"Stack effect declaration of the word " %
|
||||||
[ "Inferred: " write inferred>> . ]
|
word>> name>> % " is wrong" %
|
||||||
[ "Declared: " write declared>> . ] tri ;
|
] "" make ;
|
||||||
|
|
||||||
M: recursive-quotation-error error.
|
M: recursive-quotation-error error.
|
||||||
"The quotation " write
|
"The quotation " write
|
||||||
|
@ -42,26 +51,40 @@ M: recursive-quotation-error error.
|
||||||
" calls itself." print
|
" calls itself." print
|
||||||
"Stack effect inference is undecidable when quotation-level recursion is permitted." print ;
|
"Stack effect inference is undecidable when quotation-level recursion is permitted." print ;
|
||||||
|
|
||||||
M: undeclared-recursion-error error.
|
M: undeclared-recursion-error summary
|
||||||
"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.
|
|
||||||
drop
|
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 ;
|
|
@ -218,8 +218,7 @@ M: object infer-call*
|
||||||
alien-callback
|
alien-callback
|
||||||
} [ t "special" set-word-prop ] each
|
} [ t "special" set-word-prop ] each
|
||||||
|
|
||||||
{ call execute dispatch load-locals get-local drop-locals }
|
\ clear t "no-compile" set-word-prop
|
||||||
[ t "no-compile" set-word-prop ] each
|
|
||||||
|
|
||||||
: non-inline-word ( word -- )
|
: non-inline-word ( word -- )
|
||||||
dup called-dependency depends-on
|
dup called-dependency depends-on
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
IN: stack-checker.transforms.tests
|
IN: stack-checker.transforms.tests
|
||||||
USING: sequences stack-checker.transforms tools.test math kernel
|
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 ;
|
classes classes.tuple ;
|
||||||
|
|
||||||
: compose-n-quot ( word n -- quot' ) <repetition> >quotation ;
|
: compose-n-quot ( word n -- quot' ) <repetition> >quotation ;
|
||||||
|
@ -71,3 +71,10 @@ DEFER: curry-folding-test ( quot -- )
|
||||||
|
|
||||||
[ f ] [ 1.0 member?-test ] unit-test
|
[ 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 ]
|
[ dup infer-word apply-word/effect ]
|
||||||
} cond ;
|
} 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 -- )
|
:: ((apply-transform)) ( word quot values stack rstate -- )
|
||||||
rstate recursive-state
|
rstate recursive-state
|
||||||
[ stack quot with-datastack first ] with-variable
|
[ word stack quot call-transformer ] with-variable
|
||||||
[
|
[
|
||||||
word inlined-dependency depends-on
|
word inlined-dependency depends-on
|
||||||
values [ length meta-d shorten-by ] [ #drop, ] bi
|
values [ length meta-d shorten-by ] [ #drop, ] bi
|
||||||
|
|
|
@ -3,7 +3,7 @@
|
||||||
USING: accessors kernel math sorting words parser io summary
|
USING: accessors kernel math sorting words parser io summary
|
||||||
quotations sequences prettyprint continuations effects
|
quotations sequences prettyprint continuations effects
|
||||||
definitions compiler.units namespaces assocs tools.walker
|
definitions compiler.units namespaces assocs tools.walker
|
||||||
tools.time generic inspector fry ;
|
tools.time generic inspector fry tools.continuations ;
|
||||||
IN: tools.annotations
|
IN: tools.annotations
|
||||||
|
|
||||||
GENERIC: reset ( word -- )
|
GENERIC: reset ( word -- )
|
||||||
|
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
|
@ -0,0 +1,157 @@
|
||||||
|
! Copyright (C) 2009 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: threads kernel namespaces continuations combinators
|
||||||
|
sequences math namespaces.private continuations.private
|
||||||
|
concurrency.messaging quotations kernel.private words
|
||||||
|
sequences.private assocs models models.arrow arrays accessors
|
||||||
|
generic generic.standard definitions make sbufs ;
|
||||||
|
IN: tools.continuations
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
|
||||||
|
: after-break ( object -- )
|
||||||
|
{
|
||||||
|
{ [ dup continuation? ] [ (continue) ] }
|
||||||
|
{ [ dup not ] [ "Single stepping abandoned" rethrow ] }
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
|
SYMBOL: break-hook
|
||||||
|
|
||||||
|
: break ( -- )
|
||||||
|
continuation callstack >>call
|
||||||
|
break-hook get call( continuation -- continuation' )
|
||||||
|
after-break ;
|
||||||
|
|
||||||
|
\ break t "break?" set-word-prop
|
||||||
|
|
||||||
|
GENERIC: add-breakpoint ( quot -- quot' )
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
|
||||||
|
M: callable add-breakpoint
|
||||||
|
dup [ break ] head? [ \ break prefix ] unless ;
|
||||||
|
|
||||||
|
M: array add-breakpoint
|
||||||
|
[ add-breakpoint ] map ;
|
||||||
|
|
||||||
|
M: object add-breakpoint ;
|
||||||
|
|
||||||
|
: (step-into-quot) ( quot -- ) add-breakpoint call ;
|
||||||
|
|
||||||
|
: (step-into-dip) ( quot -- ) add-breakpoint dip ;
|
||||||
|
|
||||||
|
: (step-into-2dip) ( quot -- ) add-breakpoint 2dip ;
|
||||||
|
|
||||||
|
: (step-into-3dip) ( quot -- ) add-breakpoint 3dip ;
|
||||||
|
|
||||||
|
: (step-into-if) ( true false ? -- ) ? (step-into-quot) ;
|
||||||
|
|
||||||
|
: (step-into-dispatch) ( array n -- ) nth (step-into-quot) ;
|
||||||
|
|
||||||
|
: (step-into-execute) ( word -- )
|
||||||
|
{
|
||||||
|
{ [ dup "step-into" word-prop ] [ "step-into" word-prop call ] }
|
||||||
|
{ [ dup standard-generic? ] [ effective-method (step-into-execute) ] }
|
||||||
|
{ [ dup hook-generic? ] [ effective-method (step-into-execute) ] }
|
||||||
|
{ [ dup uses \ suspend swap member? ] [ execute break ] }
|
||||||
|
{ [ dup primitive? ] [ execute break ] }
|
||||||
|
[ def>> (step-into-quot) ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
\ (step-into-execute) t "step-into?" set-word-prop
|
||||||
|
|
||||||
|
: (step-into-continuation) ( -- )
|
||||||
|
continuation callstack >>call break ;
|
||||||
|
|
||||||
|
: (step-into-call-next-method) ( method -- )
|
||||||
|
next-method-quot (step-into-quot) ;
|
||||||
|
|
||||||
|
<< {
|
||||||
|
(step-into-quot)
|
||||||
|
(step-into-dip)
|
||||||
|
(step-into-2dip)
|
||||||
|
(step-into-3dip)
|
||||||
|
(step-into-if)
|
||||||
|
(step-into-dispatch)
|
||||||
|
(step-into-execute)
|
||||||
|
(step-into-continuation)
|
||||||
|
(step-into-call-next-method)
|
||||||
|
} [ t "no-compile" set-word-prop ] each >>
|
||||||
|
|
||||||
|
: change-frame ( continuation quot -- continuation' )
|
||||||
|
#! Applies quot to innermost call frame of the
|
||||||
|
#! continuation.
|
||||||
|
[ clone ] dip [
|
||||||
|
[ clone ] dip
|
||||||
|
[
|
||||||
|
[
|
||||||
|
[ innermost-frame-scan 1+ ]
|
||||||
|
[ innermost-frame-quot ] bi
|
||||||
|
] dip call
|
||||||
|
]
|
||||||
|
[ drop set-innermost-frame-quot ]
|
||||||
|
[ drop ]
|
||||||
|
2tri
|
||||||
|
] curry change-call ; inline
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
|
: continuation-step ( continuation -- continuation' )
|
||||||
|
[
|
||||||
|
2dup length = [ nip [ break ] append ] [
|
||||||
|
2dup nth \ break = [ nip ] [
|
||||||
|
swap 1+ cut [ break ] glue
|
||||||
|
] if
|
||||||
|
] if
|
||||||
|
] change-frame ;
|
||||||
|
|
||||||
|
: continuation-step-out ( continuation -- continuation' )
|
||||||
|
[ nip \ break suffix ] change-frame ;
|
||||||
|
|
||||||
|
|
||||||
|
{
|
||||||
|
{ call [ (step-into-quot) ] }
|
||||||
|
{ dip [ (step-into-dip) ] }
|
||||||
|
{ 2dip [ (step-into-2dip) ] }
|
||||||
|
{ 3dip [ (step-into-3dip) ] }
|
||||||
|
{ execute [ (step-into-execute) ] }
|
||||||
|
{ if [ (step-into-if) ] }
|
||||||
|
{ dispatch [ (step-into-dispatch) ] }
|
||||||
|
{ continuation [ (step-into-continuation) ] }
|
||||||
|
{ (call-next-method) [ (step-into-call-next-method) ] }
|
||||||
|
} [ "step-into" set-word-prop ] assoc-each
|
||||||
|
|
||||||
|
! Never step into these words
|
||||||
|
: don't-step-into ( word -- )
|
||||||
|
dup [ execute break ] curry "step-into" set-word-prop ;
|
||||||
|
|
||||||
|
{
|
||||||
|
>n ndrop >c c>
|
||||||
|
continue continue-with
|
||||||
|
stop suspend (spawn)
|
||||||
|
} [ don't-step-into ] each
|
||||||
|
|
||||||
|
\ break [ break ] "step-into" set-word-prop
|
||||||
|
|
||||||
|
: continuation-step-into ( continuation -- continuation' )
|
||||||
|
[
|
||||||
|
swap cut [
|
||||||
|
swap %
|
||||||
|
[ \ break , ] [
|
||||||
|
unclip {
|
||||||
|
{ [ dup \ break eq? ] [ , ] }
|
||||||
|
{ [ dup quotation? ] [ add-breakpoint , \ break , ] }
|
||||||
|
{ [ dup array? ] [ add-breakpoint , \ break , ] }
|
||||||
|
{ [ dup word? ] [ literalize , \ (step-into-execute) , ] }
|
||||||
|
[ , \ break , ]
|
||||||
|
} cond %
|
||||||
|
] if-empty
|
||||||
|
] [ ] make
|
||||||
|
] change-frame ;
|
||||||
|
|
||||||
|
: continuation-current ( continuation -- obj )
|
||||||
|
call>>
|
||||||
|
[ innermost-frame-scan 1+ ]
|
||||||
|
[ innermost-frame-quot ] bi ?nth ;
|
|
@ -354,8 +354,6 @@ IN: tools.deploy.shaker
|
||||||
|
|
||||||
: finish-deploy ( final-image -- )
|
: finish-deploy ( final-image -- )
|
||||||
"Finishing up" show
|
"Finishing up" show
|
||||||
[ { } set-datastack ] dip
|
|
||||||
{ } set-retainstack
|
|
||||||
V{ } set-namestack
|
V{ } set-namestack
|
||||||
V{ } set-catchstack
|
V{ } set-catchstack
|
||||||
"Saving final image" show
|
"Saving final image" show
|
||||||
|
|
|
@ -3,6 +3,6 @@
|
||||||
USING: eval ;
|
USING: eval ;
|
||||||
IN: tools.deploy.test.11
|
IN: tools.deploy.test.11
|
||||||
|
|
||||||
: foo ( -- ) "USING: math prettyprint ; 2 2 + ." eval ;
|
: foo ( -- ) "USING: math prettyprint ; 2 2 + ." eval( -- ) ;
|
||||||
|
|
||||||
MAIN: foo
|
MAIN: foo
|
|
@ -9,7 +9,7 @@ GENERIC: my-generic ( x -- b )
|
||||||
|
|
||||||
M: integer my-generic sq ;
|
M: integer my-generic sq ;
|
||||||
|
|
||||||
M: fixnum my-generic call-next-method my-var get call ;
|
M: fixnum my-generic call-next-method my-var get call( a -- b ) ;
|
||||||
|
|
||||||
: test-7 ( -- )
|
: test-7 ( -- )
|
||||||
[ 1 + ] my-var set-global
|
[ 1 + ] my-var set-global
|
||||||
|
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
|
@ -0,0 +1,19 @@
|
||||||
|
IN: tools.errors
|
||||||
|
USING: help.markup help.syntax source-files.errors ;
|
||||||
|
|
||||||
|
HELP: errors.
|
||||||
|
{ $values { "errors" "a sequence of " { $link source-file-error } " instances" } }
|
||||||
|
{ $description "Prints a list of errors, grouped by source file." } ;
|
||||||
|
|
||||||
|
ARTICLE: "tools.errors" "Batch error reporting"
|
||||||
|
"Some tools, such as the " { $link "compiler" } ", " { $link "tools.test" } " and " { $link "help.lint" } " need to report multiple errors at a time. Each error is associated with a source file, line number, and optionally, a definition. " { $link "errors" } " cannot be used for this purpose, so the " { $vocab-link "source-files.errors" } " vocabulary provides an alternative mechanism. Note that the words in this vocabulary are used for implementation only; to actually list errors, consult the documentation for the relevant tools."
|
||||||
|
$nl
|
||||||
|
"Source file errors inherit from a class:"
|
||||||
|
{ $subsection source-file-error }
|
||||||
|
"Printing an error summary:"
|
||||||
|
{ $subsection error-summary }
|
||||||
|
"Printing a list of errors:"
|
||||||
|
{ $subsection errors. }
|
||||||
|
"Batch errors are reported in the " { $link "ui.tools.error-list" } "." ;
|
||||||
|
|
||||||
|
ABOUT: "tools.errors"
|
|
@ -0,0 +1,40 @@
|
||||||
|
! Copyright (C) 2009 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: assocs debugger io kernel sequences source-files.errors
|
||||||
|
summary accessors continuations make math.parser io.styles namespaces ;
|
||||||
|
IN: tools.errors
|
||||||
|
|
||||||
|
#! Tools for source-files.errors. Used by tools.tests and others
|
||||||
|
#! for error reporting
|
||||||
|
|
||||||
|
M: source-file-error summary
|
||||||
|
error>> summary ;
|
||||||
|
|
||||||
|
M: source-file-error compute-restarts
|
||||||
|
error>> compute-restarts ;
|
||||||
|
|
||||||
|
M: source-file-error error-help
|
||||||
|
error>> error-help ;
|
||||||
|
|
||||||
|
M: source-file-error error.
|
||||||
|
[
|
||||||
|
[
|
||||||
|
[
|
||||||
|
[ file>> [ % ": " % ] when* ]
|
||||||
|
[ line#>> [ # "\n" % ] when* ] bi
|
||||||
|
] "" make
|
||||||
|
] [
|
||||||
|
[
|
||||||
|
presented set
|
||||||
|
bold font-style set
|
||||||
|
] H{ } make-assoc
|
||||||
|
] bi format
|
||||||
|
] [ error>> error. ] bi ;
|
||||||
|
|
||||||
|
: errors. ( errors -- )
|
||||||
|
group-by-source-file sort-errors
|
||||||
|
[
|
||||||
|
[ nl "==== " write print nl ]
|
||||||
|
[ [ nl ] [ error. ] interleave ]
|
||||||
|
bi*
|
||||||
|
] assoc-each ;
|
|
@ -7,7 +7,7 @@ continuations generic compiler.units sets classes fry ;
|
||||||
IN: tools.profiler
|
IN: tools.profiler
|
||||||
|
|
||||||
: profile ( quot -- )
|
: profile ( quot -- )
|
||||||
[ t profiling call ] [ f profiling ] [ ] cleanup ;
|
[ t profiling call ] [ f profiling ] [ ] cleanup ; inline
|
||||||
|
|
||||||
: filter-counts ( alist -- alist' )
|
: filter-counts ( alist -- alist' )
|
||||||
[ second 0 > ] filter ;
|
[ second 0 > ] filter ;
|
||||||
|
|
|
@ -3,33 +3,26 @@ IN: tools.test
|
||||||
|
|
||||||
ARTICLE: "tools.test.write" "Writing unit tests"
|
ARTICLE: "tools.test.write" "Writing unit tests"
|
||||||
"Assert that a quotation outputs a specific set of values:"
|
"Assert that a quotation outputs a specific set of values:"
|
||||||
{ $subsection unit-test }
|
{ $subsection POSTPONE: unit-test }
|
||||||
"Assert that a quotation throws an error:"
|
"Assert that a quotation throws an error:"
|
||||||
{ $subsection must-fail }
|
{ $subsection POSTPONE: must-fail }
|
||||||
{ $subsection must-fail-with }
|
{ $subsection POSTPONE: must-fail-with }
|
||||||
"Assert that a quotation or word has a specific static stack effect (see " { $link "inference" } "):"
|
"Assert that a quotation or word has a specific static stack effect (see " { $link "inference" } "):"
|
||||||
{ $subsection must-infer }
|
{ $subsection POSTPONE: must-infer }
|
||||||
{ $subsection must-infer-as } ;
|
{ $subsection POSTPONE: must-infer-as }
|
||||||
|
"All of the above are used like ordinary words but are actually parsing words. This ensures that parse-time state, namely the line number, can be associated with the test in question, and reported in test failures." ;
|
||||||
|
|
||||||
ARTICLE: "tools.test.run" "Running unit tests"
|
ARTICLE: "tools.test.run" "Running unit tests"
|
||||||
"The following words run test harness files; any test failures are collected and printed at the end:"
|
"The following words run test harness files; any test failures are collected and printed at the end:"
|
||||||
{ $subsection test }
|
{ $subsection test }
|
||||||
{ $subsection test-all } ;
|
{ $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 }
|
|
||||||
"The following word prints failures:"
|
"The following word prints failures:"
|
||||||
{ $subsection test-failures. } ;
|
{ $subsection :test-failures }
|
||||||
|
"Test failures are reported using the " { $link "tools.errors" } " mechanism and are shown in the " { $link "ui.tools.error-list" } "."
|
||||||
|
$nl
|
||||||
|
"Unit test failures are instances of a class, and are stored in a global variable:"
|
||||||
|
{ $subsection test-failure }
|
||||||
|
{ $subsection test-failures } ;
|
||||||
|
|
||||||
ARTICLE: "tools.test" "Unit testing"
|
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."
|
"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,12 +38,12 @@ $nl
|
||||||
$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."
|
"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.write" }
|
||||||
{ $subsection "tools.test.run" }
|
{ $subsection "tools.test.run" } ;
|
||||||
{ $subsection "tools.test.failure" } ;
|
|
||||||
|
|
||||||
ABOUT: "tools.test"
|
ABOUT: "tools.test"
|
||||||
|
|
||||||
HELP: unit-test
|
HELP: unit-test
|
||||||
|
{ $syntax "[ output ] [ input ] unit-test" }
|
||||||
{ $values { "output" "a sequence of expected stack elements" } { "input" "a quotation run with an empty stack" } }
|
{ $values { "output" "a sequence of expected stack elements" } { "input" "a quotation run with an empty stack" } }
|
||||||
{ $description "Runs a quotation with an empty stack, comparing the resulting stack with " { $snippet "output" } ". Elements are compared using " { $link = } ". Throws an error if the expected stack does not match the resulting stack." } ;
|
{ $description "Runs a quotation with an empty stack, comparing the resulting stack with " { $snippet "output" } ". Elements are compared using " { $link = } ". Throws an error if the expected stack does not match the resulting stack." } ;
|
||||||
|
|
||||||
|
@ -78,17 +71,8 @@ HELP: test
|
||||||
{ $values { "prefix" "a vocabulary name" } }
|
{ $values { "prefix" "a vocabulary name" } }
|
||||||
{ $description "Runs unit tests for the vocabulary named " { $snippet "prefix" } " and all of its child vocabularies." } ;
|
{ $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
|
HELP: test-all
|
||||||
{ $description "Runs unit tests for all loaded vocabularies." } ;
|
{ $description "Runs unit tests for all loaded vocabularies." } ;
|
||||||
|
|
||||||
HELP: run-all-tests
|
HELP: :test-failures
|
||||||
{ $values { "failures" "an association list of unit test failures" } }
|
{ $description "Prints all pending 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 } "." } ;
|
|
||||||
|
|
|
@ -1,95 +1,145 @@
|
||||||
! Copyright (C) 2003, 2008 Slava Pestov.
|
! Copyright (C) 2003, 2009 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors namespaces arrays prettyprint sequences kernel
|
USING: accessors arrays assocs combinators compiler.units
|
||||||
vectors quotations words parser assocs combinators continuations
|
continuations debugger effects fry generalizations io io.files
|
||||||
debugger io io.styles io.files vocabs vocabs.loader source-files
|
io.styles kernel lexer locals macros math.parser namespaces
|
||||||
compiler.units summary stack-checker effects tools.vocabs fry ;
|
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
|
IN: tools.test
|
||||||
|
|
||||||
SYMBOL: failures
|
TUPLE: test-failure < source-file-error continuation ;
|
||||||
|
|
||||||
: <failure> ( error what -- triple )
|
SYMBOL: +test-failure+
|
||||||
error-continuation get 3array ;
|
|
||||||
|
|
||||||
: failure ( error what -- )
|
M: test-failure error-type drop +test-failure+ ;
|
||||||
|
|
||||||
|
SYMBOL: test-failures
|
||||||
|
|
||||||
|
test-failures [ V{ } clone ] initialize
|
||||||
|
|
||||||
|
T{ error-type
|
||||||
|
{ type +test-failure+ }
|
||||||
|
{ word ":test-failures" }
|
||||||
|
{ plural "unit test failures" }
|
||||||
|
{ icon "vocab:ui/tools/error-list/icons/unit-test-error.tiff" }
|
||||||
|
{ quot [ test-failures get ] }
|
||||||
|
} define-error-type
|
||||||
|
|
||||||
|
<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
|
"--> test failed!" print
|
||||||
<failure> failures get push ;
|
<test-failure> test-failures get push
|
||||||
|
notify-error-observers ;
|
||||||
|
|
||||||
SYMBOL: this-test
|
SYMBOL: file
|
||||||
|
|
||||||
: (unit-test) ( what quot -- )
|
: file-failure ( error -- )
|
||||||
swap dup . flush this-test set
|
f file get f failure ;
|
||||||
failures get [
|
|
||||||
[ this-test get failure ] recover
|
|
||||||
] [
|
|
||||||
call
|
|
||||||
] if ; inline
|
|
||||||
|
|
||||||
: unit-test ( output input -- )
|
:: (unit-test) ( output input -- error ? )
|
||||||
[ 2array ] 2keep '[
|
[ { } input with-datastack output assert-sequence= f f ] [ t ] recover ; inline
|
||||||
_ { } _ with-datastack swap >array assert=
|
|
||||||
] (unit-test) ;
|
|
||||||
|
|
||||||
: short-effect ( effect -- pair )
|
: short-effect ( effect -- pair )
|
||||||
[ in>> length ] [ out>> length ] bi 2array ;
|
[ in>> length ] [ out>> length ] bi 2array ;
|
||||||
|
|
||||||
: must-infer-as ( effect quot -- )
|
:: (must-infer-as) ( effect quot -- error ? )
|
||||||
[ 1quotation ] dip '[ _ infer short-effect ] unit-test ;
|
[ quot infer short-effect effect assert= f f ] [ t ] recover ; inline
|
||||||
|
|
||||||
: must-infer ( word/quot -- )
|
:: (must-infer) ( word/quot -- error ? )
|
||||||
dup word? [ 1quotation ] when
|
word/quot dup word? [ '[ _ execute ] ] when :> quot
|
||||||
'[ _ infer drop ] [ ] swap unit-test ;
|
[ quot infer drop f f ] [ t ] recover ; inline
|
||||||
|
|
||||||
: must-fail-with ( quot pred -- )
|
TUPLE: did-not-fail ;
|
||||||
[ '[ @ f ] ] dip '[ _ _ recover ] [ t ] swap unit-test ;
|
CONSTANT: did-not-fail T{ did-not-fail }
|
||||||
|
|
||||||
: must-fail ( quot -- )
|
M: did-not-fail summary drop "Did not fail" ;
|
||||||
[ drop t ] must-fail-with ;
|
|
||||||
|
|
||||||
: (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 get +test-failure+ delete-file-errors
|
||||||
|
'[ _ run-file ] [ file-failure ] recover
|
||||||
|
] with-variable ;
|
||||||
|
|
||||||
|
: run-vocab-tests ( vocab -- )
|
||||||
dup vocab source-loaded?>> [
|
dup vocab source-loaded?>> [
|
||||||
vocab-tests [ run-file ] each
|
vocab-tests [ run-test-file ] each
|
||||||
] [ drop ] if ;
|
] [ drop ] if ;
|
||||||
|
|
||||||
: run-test ( vocab -- failures )
|
: traceback-button. ( failure -- )
|
||||||
V{ } clone [
|
"[" write [ "Traceback" ] dip continuation>> write-object "]" print ;
|
||||||
failures [
|
|
||||||
[ (run-test) ] [ swap failure ] recover
|
|
||||||
] with-variable
|
|
||||||
] keep ;
|
|
||||||
|
|
||||||
: failure. ( triple -- )
|
PRIVATE>
|
||||||
dup second .
|
|
||||||
dup first print-error
|
|
||||||
"Traceback" swap third write-object ;
|
|
||||||
|
|
||||||
: test-failures. ( assoc -- )
|
TEST: unit-test
|
||||||
[
|
TEST: must-infer-as
|
||||||
nl
|
TEST: must-infer
|
||||||
[
|
TEST: must-fail-with
|
||||||
"==== ALL TESTS PASSED" print
|
TEST: must-fail
|
||||||
] [
|
|
||||||
"==== FAILING TESTS:" print
|
|
||||||
[
|
|
||||||
swap vocab-heading.
|
|
||||||
[ failure. nl ] each
|
|
||||||
] assoc-each
|
|
||||||
] if-empty
|
|
||||||
] [
|
|
||||||
"==== NOTHING TO TEST" print
|
|
||||||
] if* ;
|
|
||||||
|
|
||||||
: run-tests ( prefix -- failures )
|
M: test-failure summary
|
||||||
child-vocabs [ f ] [
|
asset>> [ [ experiment. ] with-string-writer ] [ "Top-level form" ] if* ;
|
||||||
[ dup run-test ] { } map>assoc
|
|
||||||
[ second empty? not ] filter
|
M: test-failure error. ( error -- )
|
||||||
] if-empty ;
|
[ call-next-method ]
|
||||||
|
[ traceback-button. ]
|
||||||
|
bi ;
|
||||||
|
|
||||||
|
: :test-failures ( -- ) test-failures get errors. ;
|
||||||
|
|
||||||
: test ( prefix -- )
|
: test ( prefix -- )
|
||||||
run-tests test-failures. ;
|
child-vocabs [ run-vocab-tests ] each ;
|
||||||
|
|
||||||
: run-all-tests ( -- failures )
|
: test-all ( -- ) "" test ;
|
||||||
"" run-tests ;
|
|
||||||
|
|
||||||
: test-all ( -- )
|
|
||||||
run-all-tests test-failures. ;
|
|
||||||
|
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
|
@ -0,0 +1,4 @@
|
||||||
|
IN: tools.trace.tests
|
||||||
|
USING: tools.trace tools.test sequences ;
|
||||||
|
|
||||||
|
[ { 3 2 1 } ] [ { 1 2 3 } [ reverse ] trace ] unit-test
|
|
@ -0,0 +1,83 @@
|
||||||
|
! Copyright (C) 2009 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: concurrency.promises models tools.continuations kernel
|
||||||
|
sequences concurrency.messaging locals continuations threads
|
||||||
|
namespaces namespaces.private make assocs accessors io strings
|
||||||
|
prettyprint math math.parser words effects summary io.styles classes
|
||||||
|
generic.math combinators.short-circuit ;
|
||||||
|
IN: tools.trace
|
||||||
|
|
||||||
|
: callstack-depth ( callstack -- n )
|
||||||
|
callstack>array length 2/ ;
|
||||||
|
|
||||||
|
SYMBOL: end
|
||||||
|
|
||||||
|
SYMBOL: exclude-vocabs
|
||||||
|
SYMBOL: include-vocabs
|
||||||
|
|
||||||
|
exclude-vocabs { "math" "accessors" } swap set-global
|
||||||
|
|
||||||
|
: include? ( vocab -- ? )
|
||||||
|
include-vocabs get dup [ member? ] [ 2drop t ] if ;
|
||||||
|
|
||||||
|
: exclude? ( vocab -- ? )
|
||||||
|
exclude-vocabs get dup [ member? ] [ 2drop f ] if ;
|
||||||
|
|
||||||
|
: into? ( obj -- ? )
|
||||||
|
{
|
||||||
|
[ word? ]
|
||||||
|
[ predicate? not ]
|
||||||
|
[ math-generic? not ]
|
||||||
|
[
|
||||||
|
{
|
||||||
|
[ inline? ]
|
||||||
|
[
|
||||||
|
{
|
||||||
|
[ vocabulary>> include? ]
|
||||||
|
[ vocabulary>> exclude? not ]
|
||||||
|
} 1&&
|
||||||
|
]
|
||||||
|
} 1||
|
||||||
|
]
|
||||||
|
} 1&& ;
|
||||||
|
|
||||||
|
TUPLE: trace-step word inputs ;
|
||||||
|
|
||||||
|
M: trace-step summary
|
||||||
|
[
|
||||||
|
[ "Word: " % word>> name>> % ]
|
||||||
|
[ " -- inputs: " % inputs>> unparse-short % ] bi
|
||||||
|
] "" make ;
|
||||||
|
|
||||||
|
: <trace-step> ( continuation word -- trace-step )
|
||||||
|
[ nip ] [ [ data>> ] [ stack-effect in>> length ] bi* short tail* ] 2bi
|
||||||
|
\ trace-step boa ;
|
||||||
|
|
||||||
|
: print-step ( continuation -- )
|
||||||
|
dup continuation-current dup word? [
|
||||||
|
[ nip name>> ] [ <trace-step> ] 2bi write-object nl
|
||||||
|
] [
|
||||||
|
nip short.
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
: print-depth ( continuation -- )
|
||||||
|
call>> callstack-depth
|
||||||
|
[ CHAR: \s <string> write ]
|
||||||
|
[ number>string write ": " write ] bi ;
|
||||||
|
|
||||||
|
: trace-step ( continuation -- continuation' )
|
||||||
|
dup continuation-current end eq? [
|
||||||
|
[ print-depth ]
|
||||||
|
[ print-step ]
|
||||||
|
[
|
||||||
|
dup continuation-current into?
|
||||||
|
[ continuation-step-into ] [ continuation-step ] if
|
||||||
|
] tri
|
||||||
|
] unless ;
|
||||||
|
|
||||||
|
: trace ( quot -- data )
|
||||||
|
[ [ trace-step ] break-hook ] dip
|
||||||
|
[ break ] [ end drop ] surround
|
||||||
|
with-variable ;
|
||||||
|
|
||||||
|
<< \ trace t "no-compile" set-word-prop >>
|
|
@ -78,7 +78,7 @@ SYMBOL: failures
|
||||||
recover
|
recover
|
||||||
] each
|
] each
|
||||||
failures get
|
failures get
|
||||||
] with-compiler-errors ;
|
] with-scope ;
|
||||||
|
|
||||||
: source-modified? ( path -- ? )
|
: source-modified? ( path -- ? )
|
||||||
dup source-files get at [
|
dup source-files get at [
|
||||||
|
|
|
@ -1,8 +1,8 @@
|
||||||
! Copyright (C) 2004, 2008 Slava Pestov.
|
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: concurrency.promises models tools.walker kernel
|
USING: concurrency.promises models tools.walker tools.continuations
|
||||||
sequences concurrency.messaging locals continuations
|
kernel sequences concurrency.messaging locals continuations threads
|
||||||
threads namespaces namespaces.private assocs accessors ;
|
namespaces namespaces.private assocs accessors ;
|
||||||
IN: tools.walker.debug
|
IN: tools.walker.debug
|
||||||
|
|
||||||
:: test-walker ( quot -- data )
|
:: test-walker ( quot -- data )
|
||||||
|
|
|
@ -1,7 +1,8 @@
|
||||||
USING: tools.walker io io.streams.string kernel math
|
USING: tools.walker io io.streams.string kernel math
|
||||||
math.private namespaces prettyprint sequences tools.test
|
math.private namespaces prettyprint sequences tools.test
|
||||||
continuations math.parser threads arrays tools.walker.debug
|
continuations math.parser threads arrays tools.walker.debug
|
||||||
generic.standard sequences.private kernel.private ;
|
generic.standard sequences.private kernel.private
|
||||||
|
tools.continuations accessors words ;
|
||||||
IN: tools.walker.tests
|
IN: tools.walker.tests
|
||||||
|
|
||||||
[ { } ] [
|
[ { } ] [
|
||||||
|
@ -112,3 +113,22 @@ IN: tools.walker.tests
|
||||||
[ { } ] [
|
[ { } ] [
|
||||||
[ "a" "b" set "c" "d" set [ ] test-walker ] with-scope
|
[ "a" "b" set "c" "d" set [ ] test-walker ] with-scope
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
: breakpoint-test ( -- x ) break 1 2 + ;
|
||||||
|
|
||||||
|
\ breakpoint-test don't-step-into
|
||||||
|
|
||||||
|
[ f ] [ \ breakpoint-test optimized>> ] unit-test
|
||||||
|
|
||||||
|
[ { 3 } ] [ [ breakpoint-test ] test-walker ] unit-test
|
||||||
|
|
||||||
|
GENERIC: method-breakpoint-test ( x -- y )
|
||||||
|
|
||||||
|
TUPLE: method-breakpoint-tuple ;
|
||||||
|
|
||||||
|
M: method-breakpoint-tuple method-breakpoint-test break drop 1 2 + ;
|
||||||
|
|
||||||
|
\ method-breakpoint-test don't-step-into
|
||||||
|
|
||||||
|
[ { 3 } ]
|
||||||
|
[ [ T{ method-breakpoint-tuple } method-breakpoint-test ] test-walker ] unit-test
|
|
@ -1,10 +1,11 @@
|
||||||
! Copyright (C) 2004, 2008 Slava Pestov.
|
! Copyright (C) 2004, 2009 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: threads kernel namespaces continuations combinators
|
USING: threads kernel namespaces continuations combinators
|
||||||
sequences math namespaces.private continuations.private
|
sequences math namespaces.private continuations.private
|
||||||
concurrency.messaging quotations kernel.private words
|
concurrency.messaging quotations kernel.private words
|
||||||
sequences.private assocs models models.arrow arrays accessors
|
sequences.private assocs models models.arrow arrays accessors
|
||||||
generic generic.standard definitions make sbufs ;
|
generic generic.standard definitions make sbufs
|
||||||
|
tools.continuations parser ;
|
||||||
IN: tools.walker
|
IN: tools.walker
|
||||||
|
|
||||||
SYMBOL: show-walker-hook ! ( status continuation thread -- )
|
SYMBOL: show-walker-hook ! ( status continuation thread -- )
|
||||||
|
@ -31,66 +32,18 @@ DEFER: start-walker-thread
|
||||||
2dup start-walker-thread
|
2dup start-walker-thread
|
||||||
] if* ;
|
] if* ;
|
||||||
|
|
||||||
: show-walker ( -- thread )
|
|
||||||
get-walker-thread
|
|
||||||
[ show-walker-hook get call ] keep ;
|
|
||||||
|
|
||||||
: after-break ( object -- )
|
|
||||||
{
|
|
||||||
{ [ dup continuation? ] [ (continue) ] }
|
|
||||||
{ [ dup quotation? ] [ call ] }
|
|
||||||
{ [ dup not ] [ "Single stepping abandoned" rethrow ] }
|
|
||||||
} cond ;
|
|
||||||
|
|
||||||
: break ( -- )
|
|
||||||
continuation callstack >>call
|
|
||||||
show-walker send-synchronous
|
|
||||||
after-break ;
|
|
||||||
|
|
||||||
\ break t "break?" set-word-prop
|
|
||||||
|
|
||||||
: walk ( quot -- quot' )
|
: walk ( quot -- quot' )
|
||||||
\ break prefix [ break rethrow ] recover ;
|
\ break prefix [ break rethrow ] recover ;
|
||||||
|
|
||||||
GENERIC: add-breakpoint ( quot -- quot' )
|
<< \ walk t "no-compile" set-word-prop >>
|
||||||
|
|
||||||
M: callable add-breakpoint
|
break-hook [
|
||||||
dup [ break ] head? [ \ break prefix ] unless ;
|
[
|
||||||
|
get-walker-thread
|
||||||
M: array add-breakpoint
|
[ show-walker-hook get call ] keep
|
||||||
[ add-breakpoint ] map ;
|
send-synchronous
|
||||||
|
]
|
||||||
M: object add-breakpoint ;
|
] initialize
|
||||||
|
|
||||||
: (step-into-quot) ( quot -- ) add-breakpoint call ;
|
|
||||||
|
|
||||||
: (step-into-dip) ( quot -- ) add-breakpoint dip ;
|
|
||||||
|
|
||||||
: (step-into-2dip) ( quot -- ) add-breakpoint 2dip ;
|
|
||||||
|
|
||||||
: (step-into-3dip) ( quot -- ) add-breakpoint 3dip ;
|
|
||||||
|
|
||||||
: (step-into-if) ( true false ? -- ) ? (step-into-quot) ;
|
|
||||||
|
|
||||||
: (step-into-dispatch) ( array n -- ) nth (step-into-quot) ;
|
|
||||||
|
|
||||||
: (step-into-execute) ( word -- )
|
|
||||||
{
|
|
||||||
{ [ dup "step-into" word-prop ] [ "step-into" word-prop call ] }
|
|
||||||
{ [ dup standard-generic? ] [ effective-method (step-into-execute) ] }
|
|
||||||
{ [ dup hook-generic? ] [ effective-method (step-into-execute) ] }
|
|
||||||
{ [ dup uses \ suspend swap member? ] [ execute break ] }
|
|
||||||
{ [ dup primitive? ] [ execute break ] }
|
|
||||||
[ def>> (step-into-quot) ]
|
|
||||||
} cond ;
|
|
||||||
|
|
||||||
\ (step-into-execute) t "step-into?" set-word-prop
|
|
||||||
|
|
||||||
: (step-into-continuation) ( -- )
|
|
||||||
continuation callstack >>call break ;
|
|
||||||
|
|
||||||
: (step-into-call-next-method) ( method -- )
|
|
||||||
next-method-quot (step-into-quot) ;
|
|
||||||
|
|
||||||
! Messages sent to walker thread
|
! Messages sent to walker thread
|
||||||
SYMBOL: step
|
SYMBOL: step
|
||||||
|
@ -106,74 +59,6 @@ SYMBOL: +running+
|
||||||
SYMBOL: +suspended+
|
SYMBOL: +suspended+
|
||||||
SYMBOL: +stopped+
|
SYMBOL: +stopped+
|
||||||
|
|
||||||
: change-frame ( continuation quot -- continuation' )
|
|
||||||
#! Applies quot to innermost call frame of the
|
|
||||||
#! continuation.
|
|
||||||
[ clone ] dip [
|
|
||||||
[ clone ] dip
|
|
||||||
[
|
|
||||||
[
|
|
||||||
[ innermost-frame-scan 1+ ]
|
|
||||||
[ innermost-frame-quot ] bi
|
|
||||||
] dip call
|
|
||||||
]
|
|
||||||
[ drop set-innermost-frame-quot ]
|
|
||||||
[ drop ]
|
|
||||||
2tri
|
|
||||||
] curry change-call ; inline
|
|
||||||
|
|
||||||
: step-msg ( continuation -- continuation' ) USE: io
|
|
||||||
[
|
|
||||||
2dup length = [ nip [ break ] append ] [
|
|
||||||
2dup nth \ break = [ nip ] [
|
|
||||||
swap 1+ cut [ break ] glue
|
|
||||||
] if
|
|
||||||
] if
|
|
||||||
] change-frame ;
|
|
||||||
|
|
||||||
: step-out-msg ( continuation -- continuation' )
|
|
||||||
[ nip \ break suffix ] change-frame ;
|
|
||||||
|
|
||||||
{
|
|
||||||
{ call [ (step-into-quot) ] }
|
|
||||||
{ dip [ (step-into-dip) ] }
|
|
||||||
{ 2dip [ (step-into-2dip) ] }
|
|
||||||
{ 3dip [ (step-into-3dip) ] }
|
|
||||||
{ execute [ (step-into-execute) ] }
|
|
||||||
{ if [ (step-into-if) ] }
|
|
||||||
{ dispatch [ (step-into-dispatch) ] }
|
|
||||||
{ continuation [ (step-into-continuation) ] }
|
|
||||||
{ (call-next-method) [ (step-into-call-next-method) ] }
|
|
||||||
} [ "step-into" set-word-prop ] assoc-each
|
|
||||||
|
|
||||||
! Never step into these words
|
|
||||||
{
|
|
||||||
>n ndrop >c c>
|
|
||||||
continue continue-with
|
|
||||||
stop suspend (spawn)
|
|
||||||
} [
|
|
||||||
dup [ execute break ] curry
|
|
||||||
"step-into" set-word-prop
|
|
||||||
] each
|
|
||||||
|
|
||||||
\ break [ break ] "step-into" set-word-prop
|
|
||||||
|
|
||||||
: step-into-msg ( continuation -- continuation' )
|
|
||||||
[
|
|
||||||
swap cut [
|
|
||||||
swap %
|
|
||||||
[ \ break , ] [
|
|
||||||
unclip {
|
|
||||||
{ [ dup \ break eq? ] [ , ] }
|
|
||||||
{ [ dup quotation? ] [ add-breakpoint , \ break , ] }
|
|
||||||
{ [ dup array? ] [ add-breakpoint , \ break , ] }
|
|
||||||
{ [ dup word? ] [ literalize , \ (step-into-execute) , ] }
|
|
||||||
[ , \ break , ]
|
|
||||||
} cond %
|
|
||||||
] if-empty
|
|
||||||
] [ ] make
|
|
||||||
] change-frame ;
|
|
||||||
|
|
||||||
: status ( -- symbol )
|
: status ( -- symbol )
|
||||||
walker-status tget value>> ;
|
walker-status tget value>> ;
|
||||||
|
|
||||||
|
@ -200,13 +85,13 @@ SYMBOL: +stopped+
|
||||||
{ f [ +stopped+ set-status f ] }
|
{ f [ +stopped+ set-status f ] }
|
||||||
[
|
[
|
||||||
[ walker-continuation tget set-model ]
|
[ walker-continuation tget set-model ]
|
||||||
[ step-into-msg ] bi
|
[ continuation-step-into ] bi
|
||||||
]
|
]
|
||||||
} case
|
} case
|
||||||
] handle-synchronous
|
] handle-synchronous
|
||||||
] while ;
|
] while ;
|
||||||
|
|
||||||
: step-back-msg ( continuation -- continuation' )
|
: continuation-step-back ( continuation -- continuation' )
|
||||||
walker-history tget
|
walker-history tget
|
||||||
[ pop* ]
|
[ pop* ]
|
||||||
[ [ nip pop ] unless-empty ] bi ;
|
[ [ nip pop ] unless-empty ] bi ;
|
||||||
|
@ -220,16 +105,16 @@ SYMBOL: +stopped+
|
||||||
{
|
{
|
||||||
! These are sent by the walker tool. We reply
|
! These are sent by the walker tool. We reply
|
||||||
! and keep cycling.
|
! and keep cycling.
|
||||||
{ step [ step-msg keep-running ] }
|
{ step [ continuation-step keep-running ] }
|
||||||
{ step-out [ step-out-msg keep-running ] }
|
{ step-out [ continuation-step-out keep-running ] }
|
||||||
{ step-into [ step-into-msg keep-running ] }
|
{ step-into [ continuation-step-into keep-running ] }
|
||||||
{ step-all [ keep-running ] }
|
{ step-all [ keep-running ] }
|
||||||
{ step-into-all [ step-into-all-loop ] }
|
{ step-into-all [ step-into-all-loop ] }
|
||||||
{ abandon [ drop f keep-running ] }
|
{ abandon [ drop f keep-running ] }
|
||||||
! Pass quotation to debugged thread
|
! Pass quotation to debugged thread
|
||||||
{ call-in [ keep-running ] }
|
{ call-in [ keep-running ] }
|
||||||
! Pass previous continuation to debugged thread
|
! Pass previous continuation to debugged thread
|
||||||
{ step-back [ step-back-msg ] }
|
{ step-back [ continuation-step-back ] }
|
||||||
} case f
|
} case f
|
||||||
] handle-synchronous
|
] handle-synchronous
|
||||||
] while ;
|
] while ;
|
||||||
|
@ -276,4 +161,4 @@ SYMBOL: +stopped+
|
||||||
! For convenience
|
! For convenience
|
||||||
IN: syntax
|
IN: syntax
|
||||||
|
|
||||||
: B ( -- ) break ;
|
SYNTAX: B \ break parsed ;
|
||||||
|
|
|
@ -70,7 +70,7 @@ CLASS: {
|
||||||
! Service support; evaluate Factor code from other apps
|
! Service support; evaluate Factor code from other apps
|
||||||
:: do-service ( pboard error quot -- )
|
:: do-service ( pboard error quot -- )
|
||||||
pboard error ?pasteboard-string
|
pboard error ?pasteboard-string
|
||||||
dup [ quot call ] when
|
dup [ quot call( string -- result/f ) ] when
|
||||||
[ pboard set-pasteboard-string ] when* ;
|
[ pboard set-pasteboard-string ] when* ;
|
||||||
|
|
||||||
CLASS: {
|
CLASS: {
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
! 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: arrays kernel locals math math.order math.vectors
|
USING: arrays kernel locals math math.functions math.order math.vectors
|
||||||
sequences ui.gadgets accessors combinators ;
|
sequences ui.gadgets accessors combinators ;
|
||||||
IN: ui.baseline-alignment
|
IN: ui.baseline-alignment
|
||||||
|
|
||||||
|
@ -24,35 +24,47 @@ TUPLE: gadget-metrics height ascent descent cap-height ;
|
||||||
[ dup [ 2dup - ] [ f ] if ] dip
|
[ dup [ 2dup - ] [ f ] if ] dip
|
||||||
gadget-metrics boa ; inline
|
gadget-metrics boa ; inline
|
||||||
|
|
||||||
|
: ?supremum ( seq -- n/f )
|
||||||
|
sift [ f ] [ supremum ] if-empty ;
|
||||||
|
|
||||||
: max-ascent ( seq -- n )
|
: max-ascent ( seq -- n )
|
||||||
0 [ ascent>> [ max ] when* ] reduce ; inline
|
[ ascent>> ] map ?supremum ;
|
||||||
|
|
||||||
: max-cap-height ( seq -- n )
|
: max-cap-height ( seq -- n )
|
||||||
0 [ cap-height>> [ max ] when* ] reduce ; inline
|
[ cap-height>> ] map ?supremum ;
|
||||||
|
|
||||||
: max-descent ( seq -- n )
|
: max-descent ( seq -- n )
|
||||||
0 [ descent>> [ max ] when* ] reduce ; inline
|
[ descent>> ] map ?supremum ;
|
||||||
|
|
||||||
: max-text-height ( seq -- y )
|
: max-text-height ( seq -- y )
|
||||||
0 [ [ height>> ] [ ascent>> ] bi [ max ] [ drop ] if ] reduce ;
|
[ ascent>> ] filter [ height>> ] map ?supremum ;
|
||||||
|
|
||||||
: max-graphics-height ( seq -- y )
|
: max-graphics-height ( seq -- y )
|
||||||
0 [ [ height>> ] [ ascent>> ] bi [ drop ] [ max ] if ] reduce ;
|
[ ascent>> not ] filter [ height>> ] map ?supremum 0 or ;
|
||||||
|
|
||||||
: (align-baselines) ( y max leading -- y' ) [ swap - ] dip + ;
|
|
||||||
|
|
||||||
:: combine-metrics ( graphics-height ascent descent cap-height -- ascent' descent' )
|
:: combine-metrics ( graphics-height ascent descent cap-height -- ascent' descent' )
|
||||||
cap-height 2 / :> mid-line
|
ascent [
|
||||||
graphics-height 2 /
|
cap-height 2 / :> mid-line
|
||||||
[ ascent mid-line - max mid-line + >integer ]
|
graphics-height 2 /
|
||||||
[ descent mid-line + max mid-line - >integer ] bi ;
|
[ ascent mid-line - max mid-line + floor >integer ]
|
||||||
|
[ descent mid-line + max mid-line - ceiling >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>
|
PRIVATE>
|
||||||
|
|
||||||
:: align-baselines ( gadgets -- ys )
|
:: align-baselines ( gadgets -- ys )
|
||||||
gadgets [ dup pref-dim <gadget-metrics> ] map
|
gadgets [ dup pref-dim <gadget-metrics> ] map
|
||||||
dup max-ascent :> max-ascent
|
dup max-ascent 0 or :> max-ascent
|
||||||
dup max-cap-height :> max-cap-height
|
dup max-cap-height 0 or :> max-cap-height
|
||||||
dup max-graphics-height :> max-graphics-height
|
dup max-graphics-height :> max-graphics-height
|
||||||
|
|
||||||
max-cap-height max-graphics-height + 2 /i :> critical-line
|
max-cap-height max-graphics-height + 2 /i :> critical-line
|
||||||
|
@ -61,20 +73,12 @@ PRIVATE>
|
||||||
|
|
||||||
[
|
[
|
||||||
dup ascent>>
|
dup ascent>>
|
||||||
[ ascent>> max-ascent text-leading ]
|
[ ascent>> max-ascent swap - text-leading ]
|
||||||
[ height>> max-graphics-height graphics-leading ] if
|
[ height>> max-graphics-height swap - 2/ graphics-leading ] if +
|
||||||
(align-baselines)
|
|
||||||
] map ;
|
] map ;
|
||||||
|
|
||||||
: measure-metrics ( children sizes -- ascent descent )
|
: measure-metrics ( children sizes -- ascent descent )
|
||||||
[ <gadget-metrics> ] 2map
|
(measure-metrics) combine-metrics ;
|
||||||
{
|
|
||||||
[ max-graphics-height ]
|
|
||||||
[ max-ascent ]
|
|
||||||
[ max-descent ]
|
|
||||||
[ max-cap-height ]
|
|
||||||
} cleave
|
|
||||||
combine-metrics ;
|
|
||||||
|
|
||||||
: measure-height ( children sizes -- height )
|
: measure-height ( children sizes -- height )
|
||||||
measure-metrics + ;
|
(measure-metrics) dup [ combine-metrics + ] [ 3drop ] if ;
|
|
@ -1,7 +1,7 @@
|
||||||
! 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: kernel accessors ui.images ui.pens
|
USING: kernel accessors ui.images ui.pens
|
||||||
ui.pens.image ui.gadgets ;
|
ui.pens.image ui.gadgets ui.gadgets.labels ;
|
||||||
IN: ui.gadgets.icons
|
IN: ui.gadgets.icons
|
||||||
|
|
||||||
TUPLE: icon < gadget ;
|
TUPLE: icon < gadget ;
|
||||||
|
@ -10,3 +10,5 @@ TUPLE: icon < gadget ;
|
||||||
icon new swap <image-pen> t >>fill? >>interior ;
|
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> ;
|
|
@ -91,3 +91,49 @@ IN: ui.gadgets.packs.tests
|
||||||
[ ] [ "g" get prefer ] unit-test
|
[ ] [ "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
|
||||||
|
|
||||||
|
<shelf> +baseline+ >>align
|
||||||
|
<gadget> { 24 24 } >>dim add-gadget
|
||||||
|
12 9 { 15 15 } <baseline-gadget> add-gadget
|
||||||
|
"g" set
|
||||||
|
|
||||||
|
[ { 39 24 } ] [ "g" get pref-dim ] unit-test
|
|
@ -1,8 +1,8 @@
|
||||||
! Copyright (C) 2005, 2009 Slava Pestov.
|
! Copyright (C) 2005, 2009 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: sequences ui.gadgets ui.baseline-alignment kernel math
|
USING: sequences ui.gadgets ui.baseline-alignment
|
||||||
math.functions math.vectors math.order math.rectangles namespaces
|
ui.baseline-alignment.private kernel math math.functions math.vectors
|
||||||
accessors fry combinators arrays ;
|
math.order math.rectangles namespaces accessors fry combinators arrays ;
|
||||||
IN: ui.gadgets.packs
|
IN: ui.gadgets.packs
|
||||||
|
|
||||||
TUPLE: pack < gadget
|
TUPLE: pack < gadget
|
||||||
|
@ -84,8 +84,7 @@ M: pack pref-dim*
|
||||||
children>> dup pref-dims measure-metrics drop ;
|
children>> dup pref-dims measure-metrics drop ;
|
||||||
|
|
||||||
: pack-cap-height ( pack -- n )
|
: pack-cap-height ( pack -- n )
|
||||||
children>> [ cap-height ] map sift
|
children>> [ cap-height ] map ?supremum ;
|
||||||
[ f ] [ supremum ] if-empty ;
|
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
|
|
|
@ -2,7 +2,7 @@ USING: alien ui.gadgets.panes ui.gadgets namespaces
|
||||||
kernel sequences io io.styles io.streams.string tools.test
|
kernel sequences io io.styles io.streams.string tools.test
|
||||||
prettyprint definitions help help.syntax help.markup
|
prettyprint definitions help help.syntax help.markup
|
||||||
help.stylesheet splitting ui.gadgets.debug models math summary
|
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
|
IN: ui.gadgets.panes.tests
|
||||||
|
|
||||||
: #children ( -- n ) "pane" get children>> length ;
|
: #children ( -- n ) "pane" get children>> length ;
|
||||||
|
@ -18,8 +18,9 @@ IN: ui.gadgets.panes.tests
|
||||||
[ t ] [ #children "num-children" get = ] unit-test
|
[ t ] [ #children "num-children" get = ] unit-test
|
||||||
|
|
||||||
: test-gadget-text ( quot -- ? )
|
: test-gadget-text ( quot -- ? )
|
||||||
dup make-pane gadget-text dup print "======" print
|
'[ _ call( -- ) ]
|
||||||
swap with-string-writer dup print = ;
|
[ make-pane gadget-text dup print "======" print ]
|
||||||
|
[ with-string-writer dup print ] bi = ;
|
||||||
|
|
||||||
[ t ] [ [ "hello" write ] test-gadget-text ] unit-test
|
[ t ] [ [ "hello" write ] test-gadget-text ] unit-test
|
||||||
[ t ] [ [ "hello" pprint ] test-gadget-text ] unit-test
|
[ t ] [ [ "hello" pprint ] test-gadget-text ] unit-test
|
||||||
|
|
|
@ -10,7 +10,7 @@ IN: ui.gadgets.presentations
|
||||||
TUPLE: presentation < button object hook ;
|
TUPLE: presentation < button object hook ;
|
||||||
|
|
||||||
: invoke-presentation ( presentation command -- )
|
: invoke-presentation ( presentation command -- )
|
||||||
[ [ dup hook>> call ] [ object>> ] bi ] dip
|
[ [ dup hook>> call( presentation -- ) ] [ object>> ] bi ] dip
|
||||||
invoke-command ;
|
invoke-command ;
|
||||||
|
|
||||||
: invoke-primary ( presentation -- )
|
: invoke-primary ( presentation -- )
|
||||||
|
|
|
@ -74,7 +74,7 @@ CONSULT: table-protocol search-table table>> ;
|
||||||
dup field>> { 2 2 } <filled-border> f track-add
|
dup field>> { 2 2 } <filled-border> f track-add
|
||||||
values search 500 milliseconds <delay> quot <string-search>
|
values search 500 milliseconds <delay> quot <string-search>
|
||||||
renderer <table> f >>takes-focus? >>table
|
renderer <table> f >>takes-focus? >>table
|
||||||
dup table>> <scroller> 1 track-add ;
|
dup table>> <scroller> 1 track-add ; inline
|
||||||
|
|
||||||
M: search-table model-changed
|
M: search-table model-changed
|
||||||
nip field>> clear-search-field ;
|
nip field>> clear-search-field ;
|
||||||
|
|
|
@ -23,14 +23,14 @@ TUPLE: slot-editor < track ref close-hook update-hook text ;
|
||||||
} define-command
|
} define-command
|
||||||
|
|
||||||
: close ( slot-editor -- )
|
: close ( slot-editor -- )
|
||||||
dup close-hook>> call ;
|
dup close-hook>> call( slot-editor -- ) ;
|
||||||
|
|
||||||
\ close H{
|
\ close H{
|
||||||
{ +description+ "Close the slot editor without saving changes." }
|
{ +description+ "Close the slot editor without saving changes." }
|
||||||
} define-command
|
} define-command
|
||||||
|
|
||||||
: close-and-update ( slot-editor -- )
|
: close-and-update ( slot-editor -- )
|
||||||
[ update-hook>> call ] [ close ] bi ;
|
[ update-hook>> call( -- ) ] [ close ] bi ;
|
||||||
|
|
||||||
: slot-editor-value ( slot-editor -- object )
|
: slot-editor-value ( slot-editor -- object )
|
||||||
text>> control-value parse-fresh first ;
|
text>> control-value parse-fresh first ;
|
||||||
|
@ -44,11 +44,8 @@ TUPLE: slot-editor < track ref close-hook update-hook text ;
|
||||||
{ +description+ "Parse the object being edited, and store the result back into the edited slot." }
|
{ +description+ "Parse the object being edited, and store the result back into the edited slot." }
|
||||||
} define-command
|
} define-command
|
||||||
|
|
||||||
: eval-1 ( string -- object )
|
|
||||||
1array [ eval ] with-datastack first ;
|
|
||||||
|
|
||||||
: com-eval ( slot-editor -- )
|
: com-eval ( slot-editor -- )
|
||||||
[ [ text>> editor-string eval-1 ] [ ref>> ] bi set-ref ]
|
[ [ text>> editor-string eval( -- result ) ] [ ref>> ] bi set-ref ]
|
||||||
[ close-and-update ]
|
[ close-and-update ]
|
||||||
bi ;
|
bi ;
|
||||||
|
|
||||||
|
|
|
@ -59,14 +59,19 @@ focused? ;
|
||||||
|
|
||||||
GENERIC: cell-width ( font cell -- x )
|
GENERIC: cell-width ( font cell -- x )
|
||||||
GENERIC: cell-height ( font cell -- y )
|
GENERIC: cell-height ( font cell -- y )
|
||||||
|
GENERIC: cell-padding ( cell -- y )
|
||||||
GENERIC: draw-cell ( font cell -- )
|
GENERIC: draw-cell ( font cell -- )
|
||||||
|
|
||||||
M: string cell-width text-width ;
|
M: string cell-width text-width ;
|
||||||
M: string cell-height text-height ceiling ;
|
M: string cell-height text-height ceiling ;
|
||||||
|
M: string cell-padding drop 0 ;
|
||||||
M: string draw-cell draw-text ;
|
M: string draw-cell draw-text ;
|
||||||
|
|
||||||
|
CONSTANT: image-padding 2
|
||||||
|
|
||||||
M: image-name cell-width nip image-dim first ;
|
M: image-name cell-width nip image-dim first ;
|
||||||
M: image-name cell-height nip image-dim second ;
|
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 ;
|
M: image-name draw-cell nip draw-image ;
|
||||||
|
|
||||||
: table-rows ( table -- rows )
|
: table-rows ( table -- rows )
|
||||||
|
@ -87,7 +92,7 @@ CONSTANT: column-title-background COLOR: light-gray
|
||||||
if ;
|
if ;
|
||||||
|
|
||||||
: row-column-widths ( table row -- widths )
|
: 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 )
|
: compute-total-width ( gap widths -- total )
|
||||||
swap [ column-offsets drop ] keep - ;
|
swap [ column-offsets drop ] keep - ;
|
||||||
|
@ -162,9 +167,10 @@ M: table layout*
|
||||||
'[ [ 0 2array ] [ _ 2array ] bi gl-line ] each
|
'[ [ 0 2array ] [ _ 2array ] bi gl-line ] each
|
||||||
] bi ;
|
] bi ;
|
||||||
|
|
||||||
: column-loc ( font column width align -- loc )
|
:: column-loc ( font column width align -- loc )
|
||||||
[ [ cell-width ] dip swap - ] dip
|
font column cell-width width swap - align * column cell-padding 2 / 1 align - * +
|
||||||
* >integer 0 2array ;
|
font column cell-height \ line-height get swap - 2 /
|
||||||
|
[ >integer ] bi@ 2array ;
|
||||||
|
|
||||||
: translate-column ( width gap -- )
|
: translate-column ( width gap -- )
|
||||||
+ 0 2array gl-translate ;
|
+ 0 2array gl-translate ;
|
||||||
|
@ -203,18 +209,21 @@ M: table draw-line ( row index table -- )
|
||||||
|
|
||||||
M: table draw-gadget*
|
M: table draw-gadget*
|
||||||
dup control-value empty? [ drop ] [
|
dup control-value empty? [ drop ] [
|
||||||
{
|
dup line-height \ line-height [
|
||||||
[ draw-selected-row ]
|
{
|
||||||
[ draw-lines ]
|
[ draw-selected-row ]
|
||||||
[ draw-column-lines ]
|
[ draw-lines ]
|
||||||
[ draw-focused-row ]
|
[ draw-column-lines ]
|
||||||
[ draw-moused-row ]
|
[ draw-focused-row ]
|
||||||
} cleave
|
[ draw-moused-row ]
|
||||||
|
} cleave
|
||||||
|
] with-variable
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
M: table line-height ( table -- y )
|
M: table line-height ( table -- y )
|
||||||
[ font>> ] [ renderer>> prototype-row ] bi
|
[ font>> ] [ renderer>> prototype-row ] bi
|
||||||
[ cell-height ] with [ max ] map-reduce ;
|
[ [ cell-height ] [ cell-padding ] bi + ] with
|
||||||
|
[ max ] map-reduce ;
|
||||||
|
|
||||||
M: table pref-dim*
|
M: table pref-dim*
|
||||||
[ compute-column-widths drop ] keep
|
[ compute-column-widths drop ] keep
|
||||||
|
@ -379,14 +388,16 @@ TUPLE: column-headers < gadget table ;
|
||||||
column-title-background <solid> >>interior ;
|
column-title-background <solid> >>interior ;
|
||||||
|
|
||||||
: draw-column-titles ( table -- )
|
: draw-column-titles ( table -- )
|
||||||
{
|
dup font>> font-metrics height>> \ line-height [
|
||||||
[ renderer>> column-titles ]
|
{
|
||||||
[ column-widths>> ]
|
[ renderer>> column-titles ]
|
||||||
[ table-column-alignment ]
|
[ column-widths>> ]
|
||||||
[ font>> column-title-font ]
|
[ table-column-alignment ]
|
||||||
[ gap>> ]
|
[ font>> column-title-font ]
|
||||||
} cleave
|
[ gap>> ]
|
||||||
draw-columns ;
|
} cleave
|
||||||
|
draw-columns
|
||||||
|
] with-variable ;
|
||||||
|
|
||||||
M: column-headers draw-gadget*
|
M: column-headers draw-gadget*
|
||||||
table>> draw-column-titles ;
|
table>> draw-column-titles ;
|
||||||
|
|
|
@ -4,7 +4,7 @@ ui.gestures ;
|
||||||
IN: ui.operations
|
IN: ui.operations
|
||||||
|
|
||||||
: $operations ( element -- )
|
: $operations ( element -- )
|
||||||
>quotation call
|
>quotation call( -- obj )
|
||||||
f operations>commands
|
f operations>commands
|
||||||
command-map. ;
|
command-map. ;
|
||||||
|
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
! 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: 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
|
compiler.units assocs words vocabs accessors fry arrays
|
||||||
combinators.short-circuit namespaces sequences models help.apropos
|
combinators.short-circuit namespaces sequences models help.apropos
|
||||||
combinators ui ui.commands ui.gadgets ui.gadgets.panes
|
combinators ui ui.commands ui.gadgets ui.gadgets.panes
|
||||||
|
@ -91,6 +91,10 @@ M: browser-gadget focusable-child* search-field>> ;
|
||||||
: browser-window ( -- )
|
: browser-window ( -- )
|
||||||
"help.home" (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
|
\ browser-window H{ { +nullary+ t } } define-command
|
||||||
|
|
||||||
: com-browse ( link -- )
|
: com-browse ( link -- )
|
||||||
|
|
|
@ -46,7 +46,7 @@ SLOT: model
|
||||||
|
|
||||||
: show-links-popup ( browser-gadget quot title -- )
|
: show-links-popup ( browser-gadget quot title -- )
|
||||||
[ dup model>> ] 2dip <links-popup>
|
[ 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 -- )
|
: com-show-outgoing-links ( browser-gadget -- )
|
||||||
[ uses ] "Outgoing links" show-links-popup ;
|
[ 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.presentations ui.gadgets.viewports ui.gadgets.tables
|
||||||
ui.gadgets.tracks ui.gadgets.scrollers ui.gadgets.panes
|
ui.gadgets.tracks ui.gadgets.scrollers ui.gadgets.panes
|
||||||
ui.gadgets.borders ui.gadgets.status-bar ui.tools.traceback
|
ui.gadgets.borders ui.gadgets.status-bar ui.tools.traceback
|
||||||
ui.tools.inspector ;
|
ui.tools.inspector ui.tools.browser ;
|
||||||
IN: ui.tools.debugger
|
IN: ui.tools.debugger
|
||||||
|
|
||||||
TUPLE: debugger < track error restarts restart-hook restart-list continuation ;
|
TUPLE: debugger < track error restarts restart-hook restart-list continuation ;
|
||||||
|
@ -86,9 +86,7 @@ debugger "gestures" f {
|
||||||
|
|
||||||
: com-traceback ( debugger -- ) continuation>> traceback-window ;
|
: com-traceback ( debugger -- ) continuation>> traceback-window ;
|
||||||
|
|
||||||
: com-help ( debugger -- ) error>> (:help) ;
|
: com-help ( debugger -- ) error>> error-help-window ;
|
||||||
|
|
||||||
\ com-help H{ { +listener+ t } } define-command
|
|
||||||
|
|
||||||
: com-edit ( debugger -- ) error>> (:edit) ;
|
: com-edit ( debugger -- ) error>> (:edit) ;
|
||||||
|
|
||||||
|
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
|
@ -0,0 +1,20 @@
|
||||||
|
IN: ui.tools.error-list
|
||||||
|
USING: help.markup help.syntax ui.tools.common ui.commands ;
|
||||||
|
|
||||||
|
ARTICLE: "ui.tools.error-list" "UI error list tool"
|
||||||
|
"The error list tool displays messages generated by tools which process source files and definitions. To display the error list, press " { $command tool "common" show-error-list } " in any UI tool window."
|
||||||
|
$nl
|
||||||
|
"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/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 "loading-libs" } }
|
||||||
|
} ;
|
||||||
|
|
||||||
|
ABOUT: "ui.tools.error-list"
|
|
@ -0,0 +1,205 @@
|
||||||
|
! 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 make
|
||||||
|
memoize compiler.units fonts kernel io.pathnames prettyprint
|
||||||
|
source-files.errors math.parser init math.order models models.arrow
|
||||||
|
models.arrow.smart models.search models.mapping models.delay 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
|
||||||
|
compiler.errors calendar ;
|
||||||
|
IN: ui.tools.error-list
|
||||||
|
|
||||||
|
CONSTANT: source-file-icon
|
||||||
|
T{ image-name f "vocab:ui/tools/error-list/icons/source-file.tiff" }
|
||||||
|
|
||||||
|
MEMO: error-icon ( type -- image-name )
|
||||||
|
error-icon-path <image-name> ;
|
||||||
|
|
||||||
|
: <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 get keys [ 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
|
||||||
|
|
||||||
|
M: source-file-renderer row-columns
|
||||||
|
drop first2 [
|
||||||
|
[ source-file-icon ]
|
||||||
|
[ "<Listener input>" or ]
|
||||||
|
[ 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> ] [ f ] if* ] 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
|
||||||
|
5 >>min-rows
|
||||||
|
5 >>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 [
|
||||||
|
{
|
||||||
|
[ error-type error-icon ]
|
||||||
|
[ line#>> [ number>string ] [ "" ] if* ]
|
||||||
|
[ 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' )
|
||||||
|
[ [ [ asset>> unparse-short ] [ line#>> ] bi 2array ] keep ] { } map>assoc
|
||||||
|
sort-keys values ;
|
||||||
|
|
||||||
|
: file-matches? ( error pathname/f -- ? )
|
||||||
|
[ file>> ] [ dup [ string>> ] when ] bi* = ;
|
||||||
|
|
||||||
|
: <error-table-model> ( error-list -- model )
|
||||||
|
[ model>> ] [ source-file>> ] bi
|
||||||
|
[ file-matches? ] <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
|
||||||
|
5 >>min-rows
|
||||||
|
5 >>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 ] when* ] <pane-control> <scroller> 1 track-add ;
|
||||||
|
|
||||||
|
: com-inspect ( error-display -- )
|
||||||
|
model>> value>> [ inspector ] when* ;
|
||||||
|
|
||||||
|
: com-help ( error-display -- )
|
||||||
|
model>> value>> [ error>> error-help-window ] when* ;
|
||||||
|
|
||||||
|
: com-edit ( error-display -- )
|
||||||
|
model>> value>> [ edit-error ] when* ;
|
||||||
|
|
||||||
|
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 '[ 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: error-list-model
|
||||||
|
|
||||||
|
error-list-model [ f <model> ] initialize
|
||||||
|
|
||||||
|
SINGLETON: updater
|
||||||
|
|
||||||
|
M: updater errors-changed
|
||||||
|
drop f error-list-model get-global set-model ;
|
||||||
|
|
||||||
|
[ updater add-error-observer ] "ui.tools.error-list" add-init-hook
|
||||||
|
|
||||||
|
: <error-list-model> ( -- model )
|
||||||
|
error-list-model get-global
|
||||||
|
1/2 seconds <delay> [ drop all-errors ] <arrow> ;
|
||||||
|
|
||||||
|
: error-list-window ( -- )
|
||||||
|
<error-list-model> <error-list-gadget> "Errors" open-status-window ;
|
||||||
|
|
||||||
|
: show-error-list ( -- )
|
||||||
|
[ error-list-gadget? ] find-window
|
||||||
|
[ raise-window ] [ error-list-window ] if* ;
|
||||||
|
|
||||||
|
\ show-error-list H{ { +nullary+ t } } define-command
|
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.
|
@ -1,5 +1,5 @@
|
||||||
USING: help.markup help.syntax ui.commands ui.gadgets.slots
|
USING: help.markup help.syntax ui.commands ui.gadgets.slots
|
||||||
ui.gadgets.editors ;
|
ui.gadgets.editors kernel ;
|
||||||
IN: ui.tools.inspector
|
IN: ui.tools.inspector
|
||||||
|
|
||||||
ARTICLE: "ui-inspector-edit" "Editing slot values in the inspector"
|
ARTICLE: "ui-inspector-edit" "Editing slot values in the inspector"
|
||||||
|
@ -21,4 +21,8 @@ $nl
|
||||||
"The UI inspector is an instance of " { $link inspector-gadget } "."
|
"The UI inspector is an instance of " { $link inspector-gadget } "."
|
||||||
{ $subsection "ui-inspector-edit" } ;
|
{ $subsection "ui-inspector-edit" } ;
|
||||||
|
|
||||||
|
HELP: inspector
|
||||||
|
{ $values { "obj" object } }
|
||||||
|
{ $description "Opens a new inspector window displaying the slots of " { $snippet "obj" } "." } ;
|
||||||
|
|
||||||
ABOUT: "ui-inspector"
|
ABOUT: "ui-inspector"
|
|
@ -27,6 +27,8 @@ ARTICLE: "ui-listener" "UI listener"
|
||||||
{ $command-map interactor "quotation" }
|
{ $command-map interactor "quotation" }
|
||||||
{ $heading "Editing commands" }
|
{ $heading "Editing commands" }
|
||||||
"The text editing commands are standard; see " { $link "gadgets-editors-commands" } "."
|
"The text editing commands are standard; see " { $link "gadgets-editors-commands" } "."
|
||||||
|
$nl
|
||||||
|
"The listener displays a summary with any outstanding error conditions before every prompt. See " { $link "ui.tools.error-list" } " for details."
|
||||||
{ $heading "Implementation" }
|
{ $heading "Implementation" }
|
||||||
"Listeners are instances of " { $link listener-gadget } ". The listener consists of an output area (instance of " { $link pane } ") and an input area (instance of " { $link interactor } "). Clickable presentations can also be printed to the listener; see " { $link "ui-presentations" } "." ;
|
"Listeners are instances of " { $link listener-gadget } ". The listener consists of an output area (instance of " { $link pane } ") and an input area (instance of " { $link interactor } "). Clickable presentations can also be printed to the listener; see " { $link "ui-presentations" } "." ;
|
||||||
|
|
||||||
|
|
|
@ -1,10 +1,10 @@
|
||||||
! Copyright (C) 2005, 2009 Slava Pestov.
|
! Copyright (C) 2005, 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 calendar combinators locals
|
USING: accessors arrays assocs calendar combinators locals
|
||||||
colors.constants combinators.short-circuit compiler.units
|
source-files.errors colors.constants combinators.short-circuit
|
||||||
help.tips concurrency.flags concurrency.mailboxes continuations
|
compiler.units help.tips concurrency.flags concurrency.mailboxes
|
||||||
destructors documents documents.elements fry hashtables help
|
continuations destructors documents documents.elements fry hashtables
|
||||||
help.markup io io.styles kernel lexer listener math models
|
help help.markup io io.styles kernel lexer listener math models sets
|
||||||
models.delay models.arrow namespaces parser prettyprint quotations
|
models.delay models.arrow namespaces parser prettyprint quotations
|
||||||
sequences strings threads tools.vocabs vocabs vocabs.loader
|
sequences strings threads tools.vocabs vocabs vocabs.loader
|
||||||
vocabs.parser words debugger ui ui.commands ui.pens.solid ui.gadgets
|
vocabs.parser words debugger ui ui.commands ui.pens.solid ui.gadgets
|
||||||
|
@ -13,7 +13,8 @@ ui.gadgets.labeled ui.gadgets.panes ui.gadgets.scrollers
|
||||||
ui.gadgets.status-bar ui.gadgets.tracks ui.gadgets.borders ui.gestures
|
ui.gadgets.status-bar ui.gadgets.tracks ui.gadgets.borders ui.gestures
|
||||||
ui.operations ui.tools.browser ui.tools.common ui.tools.debugger
|
ui.operations ui.tools.browser ui.tools.common ui.tools.debugger
|
||||||
ui.tools.listener.completion ui.tools.listener.popups
|
ui.tools.listener.completion ui.tools.listener.popups
|
||||||
ui.tools.listener.history ;
|
ui.tools.listener.history ui.tools.error-list ;
|
||||||
|
FROM: source-files.errors => all-errors ;
|
||||||
IN: ui.tools.listener
|
IN: ui.tools.listener
|
||||||
|
|
||||||
! If waiting is t, we're waiting for user input, and invoking
|
! If waiting is t, we're waiting for user input, and invoking
|
||||||
|
@ -356,10 +357,19 @@ interactor "completion" f {
|
||||||
{ T{ key-down f { C+ } "r" } history-completion-popup }
|
{ T{ key-down f { C+ } "r" } history-completion-popup }
|
||||||
} define-command-map
|
} define-command-map
|
||||||
|
|
||||||
|
: ui-error-summary ( -- )
|
||||||
|
all-errors [
|
||||||
|
[ error-type ] map prune
|
||||||
|
[ error-icon-path 1array \ $image prefix " " 2array ] { } map-as
|
||||||
|
{ "Press " { $command tool "common" show-error-list } " to view errors." }
|
||||||
|
append print-element nl
|
||||||
|
] unless-empty ;
|
||||||
|
|
||||||
: listener-thread ( listener -- )
|
: listener-thread ( listener -- )
|
||||||
dup listener-streams [
|
dup listener-streams [
|
||||||
[ com-browse ] help-hook set
|
[ com-browse ] help-hook set
|
||||||
'[ [ _ input>> ] 2dip debugger-popup ] error-hook set
|
'[ [ _ input>> ] 2dip debugger-popup ] error-hook set
|
||||||
|
[ ui-error-summary ] error-summary-hook set
|
||||||
tip-of-the-day. nl
|
tip-of-the-day. nl
|
||||||
listener
|
listener
|
||||||
] with-streams* ;
|
] with-streams* ;
|
||||||
|
|
|
@ -1,15 +1,15 @@
|
||||||
! 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: continuations definitions generic help.topics threads
|
USING: continuations definitions generic help.topics threads
|
||||||
stack-checker summary io.pathnames io.styles kernel namespaces
|
stack-checker summary io.pathnames io.styles kernel namespaces parser
|
||||||
parser prettyprint quotations tools.crossref tools.annotations
|
prettyprint quotations tools.crossref tools.annotations editors
|
||||||
editors tools.profiler tools.test tools.time tools.walker vocabs
|
tools.profiler tools.test tools.time tools.walker vocabs vocabs.loader
|
||||||
vocabs.loader words sequences tools.vocabs classes
|
words sequences tools.vocabs classes compiler.errors compiler.units
|
||||||
compiler.units accessors vocabs.parser macros.expander ui
|
accessors vocabs.parser macros.expander ui ui.tools.browser
|
||||||
ui.tools.browser ui.tools.listener ui.tools.listener.completion
|
ui.tools.listener ui.tools.listener.completion ui.tools.profiler
|
||||||
ui.tools.profiler ui.tools.inspector ui.tools.traceback
|
ui.tools.inspector ui.tools.traceback ui.commands ui.gadgets.editors
|
||||||
ui.commands ui.gadgets.editors ui.gestures ui.operations
|
ui.gestures ui.operations ui.tools.deploy models help.tips
|
||||||
ui.tools.deploy models help.tips ;
|
source-files.errors ;
|
||||||
IN: ui.tools.operations
|
IN: ui.tools.operations
|
||||||
|
|
||||||
! Objects
|
! Objects
|
||||||
|
@ -86,6 +86,21 @@ IN: ui.tools.operations
|
||||||
{ +listener+ t }
|
{ +listener+ t }
|
||||||
} define-operation
|
} define-operation
|
||||||
|
|
||||||
|
! Source file error
|
||||||
|
[ source-file-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 -- )
|
: com-forget ( defspec -- )
|
||||||
[ forget ] with-compilation-unit ;
|
[ forget ] with-compilation-unit ;
|
||||||
|
|
||||||
|
|
|
@ -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.tools.browser ui.tools.common ui.baseline-alignment
|
||||||
ui.operations ui.images ;
|
ui.operations ui.images ;
|
||||||
FROM: models.arrow => <arrow> ;
|
FROM: models.arrow => <arrow> ;
|
||||||
|
FROM: models.arrow.smart => <smart-arrow> ;
|
||||||
FROM: models.product => <product> ;
|
FROM: models.product => <product> ;
|
||||||
IN: ui.tools.profiler
|
IN: ui.tools.profiler
|
||||||
|
|
||||||
|
@ -112,8 +113,8 @@ M: method-renderer column-titles drop { "" "Method" "Count" } ;
|
||||||
: <methods-model> ( profiler -- model )
|
: <methods-model> ( profiler -- model )
|
||||||
[
|
[
|
||||||
[ method-counters <model> ] dip
|
[ method-counters <model> ] dip
|
||||||
[ generic>> ] [ class>> ] bi 3array <product>
|
[ generic>> ] [ class>> ] bi
|
||||||
[ first3 '[ _ _ method-matches? ] filter ] <arrow>
|
[ '[ _ _ method-matches? ] filter ] <smart-arrow>
|
||||||
] keep <profiler-model> ;
|
] keep <profiler-model> ;
|
||||||
|
|
||||||
: sort-by-name ( obj1 obj2 -- <=> )
|
: sort-by-name ( obj1 obj2 -- <=> )
|
||||||
|
@ -208,6 +209,6 @@ profiler-gadget "toolbar" f {
|
||||||
: profiler-window ( -- )
|
: profiler-window ( -- )
|
||||||
<profiler-gadget> "Profiling results" open-status-window ;
|
<profiler-gadget> "Profiling results" open-status-window ;
|
||||||
|
|
||||||
: com-profile ( quot -- ) profile profiler-window ;
|
: com-profile ( quot -- ) profile profiler-window ; inline
|
||||||
|
|
||||||
MAIN: profiler-window
|
MAIN: profiler-window
|
||||||
|
|
|
@ -66,6 +66,7 @@ $nl
|
||||||
{ $subsection "ui-listener" }
|
{ $subsection "ui-listener" }
|
||||||
{ $subsection "ui-browser" }
|
{ $subsection "ui-browser" }
|
||||||
{ $subsection "ui-inspector" }
|
{ $subsection "ui-inspector" }
|
||||||
|
{ $subsection "ui.tools.error-list" }
|
||||||
{ $subsection "ui.tools.profiler" }
|
{ $subsection "ui.tools.profiler" }
|
||||||
{ $subsection "ui-walker" }
|
{ $subsection "ui-walker" }
|
||||||
{ $subsection "ui.tools.deploy" }
|
{ $subsection "ui.tools.deploy" }
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
! 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: memory system kernel tools.vocabs ui.tools.operations
|
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 ;
|
ui.tools.walker ui.commands ui.gestures ui ui.private ;
|
||||||
IN: ui.tools
|
IN: ui.tools
|
||||||
|
|
||||||
|
@ -30,4 +30,5 @@ tool "common" f {
|
||||||
{ T{ key-down f { A+ } "w" } close-window }
|
{ T{ key-down f { A+ } "w" } close-window }
|
||||||
{ T{ key-down f { A+ } "q" } com-exit }
|
{ T{ key-down f { A+ } "q" } com-exit }
|
||||||
{ T{ key-down f f "F2" } refresh-all }
|
{ T{ key-down f f "F2" } refresh-all }
|
||||||
|
{ T{ key-down f f "F3" } show-error-list }
|
||||||
} define-command-map
|
} define-command-map
|
|
@ -1,6 +1,6 @@
|
||||||
IN: ui.tools.walker
|
IN: ui.tools.walker
|
||||||
USING: help.markup help.syntax ui.commands ui.operations
|
USING: help.markup help.syntax ui.commands ui.operations
|
||||||
ui.render tools.walker sequences ;
|
ui.render tools.walker sequences tools.continuations ;
|
||||||
|
|
||||||
ARTICLE: "ui-walker-step" "Stepping through code"
|
ARTICLE: "ui-walker-step" "Stepping through code"
|
||||||
"If the current position points to a word, the various stepping commands behave as follows:"
|
"If the current position points to a word, the various stepping commands behave as follows:"
|
||||||
|
|
|
@ -22,7 +22,7 @@ SYMBOL: xim
|
||||||
xim get-global XCloseIM drop f xim set-global ;
|
xim get-global XCloseIM drop f xim set-global ;
|
||||||
|
|
||||||
: with-xim ( quot -- )
|
: with-xim ( quot -- )
|
||||||
[ "Factor" init-xim ] dip [ close-xim ] [ ] cleanup ;
|
[ "Factor" init-xim ] dip [ close-xim ] [ ] cleanup ; inline
|
||||||
|
|
||||||
: create-xic ( window classname -- xic )
|
: create-xic ( window classname -- xic )
|
||||||
[
|
[
|
||||||
|
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue