"} cond >>"
}
"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." ;
kernel.private math memory continuations kernel io.files
io.pathnames io.backend system parser vocabs sequences
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 ;
IN: bootstrap.stage2
"none" require
] if
- [
- load-components
+ load-components
- millis over - core-bootstrap-time set-global
+ millis over - core-bootstrap-time set-global
- run-bootstrap-init
- ] with-compiler-errors
- :errors
+ run-bootstrap-init
f error set-global
f error-continuation set-global
"bootstrap.image"
"tools.annotations"
"tools.crossref"
+ "tools.errors"
"tools.deploy"
"tools.disassembler"
"tools.memory"
combinators classes.algebra alien alien.c-types alien.structs
alien.strings alien.arrays alien.complex sets libc alien.libraries
continuations.private fry cpu.architecture
+source-files.errors
compiler.errors
compiler.alien
compiler.cfg
M: no-such-library summary
drop "Library not found" ;
-M: no-such-library compiler-error-type
- drop +linkage+ ;
+M: no-such-library error-type drop +linkage-error+ ;
: no-such-library ( name -- )
\ no-such-library boa
M: no-such-symbol summary
drop "Symbol not found" ;
-M: no-such-symbol compiler-error-type
- drop +linkage+ ;
+M: no-such-symbol error-type drop +linkage-error+ ;
: no-such-symbol ( name -- )
\ no-such-symbol boa
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces arrays sequences io words fry
continuations vocabs assocs dlists definitions math graphs generic
-combinators deques search-deques macros io stack-checker
+combinators deques search-deques macros io source-files.errors stack-checker
stack-checker.state stack-checker.inlining combinators.short-circuit
compiler.errors compiler.units compiler.tree.builder
compiler.tree.optimizer compiler.cfg.builder compiler.cfg.optimizer
f swap compiler-error ;
: ignore-error? ( word error -- ? )
- [ [ inline? ] [ macro? ] bi or ]
- [ compiler-error-type +warning+ eq? ] bi* and ;
+ [
+ {
+ [ inline? ]
+ [ macro? ]
+ [ "transform-quot" word-prop ]
+ [ "no-compile" word-prop ]
+ [ "special" word-prop ]
+ } 1||
+ ] [ error-type +compiler-warning+ eq? ] bi* and ;
: fail ( word error -- * )
- [ 2dup ignore-error? [ 2drop ] [ swap compiler-error ] if ]
+ [ 2dup ignore-error? [ drop f ] when swap compiler-error ]
[
drop
[ compiled-unxref ]
: compile-call ( quot -- )
[ dup infer define-temp ] with-compilation-unit execute ;
+\ compile-call t "no-compile" set-word-prop
+
SINGLETON: optimizing-compiler
M: optimizing-compiler recompile ( words -- alist )
--- /dev/null
+Slava Pestov
--- /dev/null
+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"
--- /dev/null
+! 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. ;
--- /dev/null
+Compiler warning and error reporting
: check-cannot-infer ( word -- )
dup "cannot-infer" word-prop [ cannot-infer-effect ] [ drop ] if ;
+TUPLE: do-not-compile word ;
+
: check-no-compile ( word -- )
- dup "no-compile" word-prop [ cannot-infer-effect ] [ drop ] if ;
+ dup "no-compile" word-prop [ do-not-compile inference-warning ] [ drop ] if ;
: build-tree-from-word ( word -- nodes )
[
HELP: promise\r
{ $class-description "The class of write-once promises." } ;\r
\r
+HELP: <promise>\r
+{ $values { "promise" promise } }\r
+{ $description "Creates a new promise which may be fulfilled by calling " { $link fulfill } "." } ;\r
+\r
HELP: promise-fulfilled?\r
{ $values { "promise" promise } { "?" "a boolean" } }\r
{ $description "Tests if " { $link fulfill } " has previously been called on the promise, in which case " { $link ?promise } " will return immediately without blocking." } ;\r
combinators generic.math classes.builtin classes compiler.units
generic.standard vocabs init kernel.private io.encodings
accessors math.order destructors source-files parser
-classes.tuple.parser effects.parser lexer compiler.errors
-generic.parser strings.parser vocabs.loader vocabs.parser ;
+classes.tuple.parser effects.parser lexer
+generic.parser strings.parser vocabs.loader vocabs.parser see
+source-files.errors ;
IN: debugger
GENERIC: error. ( error -- )
M: assert summary drop "Assertion failed" ;
-M: assert error.
- "Assertion failed" print
+M: assert-sequence summary drop "Assertion failed" ;
+
+M: assert-sequence error.
standard-table-style [
- 15 length-limit set
- 5 line-limit set
- [ expect>> [ [ "Expect:" write ] with-cell pprint-cell ] with-row ]
- [ got>> [ [ "Got:" write ] with-cell pprint-cell ] with-row ] bi
- ] tabular-output nl ;
+ [ "=== Expected:" print expected>> stack. ]
+ [ "=== Got:" print got>> stack. ] bi
+ ] tabular-output ;
M: immutable summary drop "Sequence is immutable" ;
M: invalid-slot-name summary
drop "Invalid slot name" ;
-: file. ( file -- ) path>> <pathname> . ;
-
-M: source-file-error error.
- [ file>> file. ] [ error>> error. ] bi ;
-
-M: source-file-error summary
- error>> summary ;
-
-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
drop "call-next-method can only be called in a method definition" ;
M: lexer-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
drop "Bad stack effect declaration" ;
-USING: help.markup help.syntax parser source-files vocabs.loader ;
+USING: help.markup help.syntax parser source-files
+source-files.errors vocabs.loader ;
IN: editors
ARTICLE: "editor" "Editor integration"
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
{ $values { "defspec" "a definition specifier" } }
{ $description "Opens the source file containing the definition using the current " { $link edit-hook } ". See " { $link "editor" } "." }
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: parser lexer kernel namespaces sequences definitions
-io.files io.backend io.pathnames io summary continuations
-tools.crossref tools.vocabs prettyprint source-files assocs
+USING: parser lexer kernel namespaces sequences definitions io.files
+io.backend io.pathnames io summary continuations tools.crossref
+tools.vocabs prettyprint source-files source-files.errors assocs
vocabs vocabs.loader splitting accessors debugger prettyprint
help.topics ;
IN: editors
[ error>> error-line ] [ line>> ] bi or ;
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
error>> error-line ;
: :edit ( -- )
error get (:edit) ;
+: edit-error ( error -- )
+ [ file>> ] [ line#>> ] bi 2dup and [ edit-location ] [ 2drop ] if ;
+
: edit-each ( seq -- )
[
[ "Editing " write . ]
IN: eval
-USING: help.markup help.syntax strings io ;
+USING: help.markup help.syntax strings io effects ;
HELP: eval
-{ $values { "str" string } }
-{ $description "Parses Factor source code from a string, and calls the resulting quotation." }
+{ $values { "str" string } { "effect" effect } }
+{ $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." } ;
HELP: eval>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"
"The " { $vocab-link "eval" } " vocabulary implements support for evaluating strings at runtime."
-{ $subsection eval }
+{ $subsection POSTPONE: eval( }
{ $subsection eval>string } ;
ABOUT: "eval"
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: splitting parser compiler.units kernel namespaces
-debugger io.streams.string fry ;
+debugger io.streams.string fry combinators effects.parser ;
IN: eval
: parse-string ( str -- quot )
[ string-lines parse-lines ] with-compilation-unit ;
-: (eval) ( str -- )
- parse-string call ;
+: (eval) ( str effect -- )
+ [ parse-string ] dip call-effect ; inline
-: eval ( str -- )
- [ (eval) ] with-file-vocabs ;
+: eval ( str effect -- )
+ [ (eval) ] with-file-vocabs ; inline
+
+SYNTAX: eval( \ eval parse-call( ;
: (eval>string) ( str -- output )
[
"quiet" on
parser-notes off
- '[ _ (eval) ] try
+ '[ _ (( -- )) (eval) ] try
] with-string-writer ;
: eval>string ( str -- output )
"shuffle-words"
"words"
"generic"
- "tools"
+ "handbook-tools-reference"
} ;
ARTICLE: "cookbook-combinators" "Control flow cookbook"
io.streams.byte-array classes.builtin parser lexer
classes.predicate classes.union classes.intersection
classes.singleton classes.tuple help.vocabs math.parser
-accessors definitions ;
+accessors definitions sets ;
IN: help.handbook
ARTICLE: "conventions" "Conventions"
{ $subsection "io.ports" }
{ $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"
{ $index [ articles get keys ] } ;
USING: help.cookbook help.tutorial ;
-ARTICLE: "handbook-language-reference" "Language reference"
-"Fundamentals:"
+ARTICLE: "handbook-language-reference" "The language"
+{ $heading "Fundamentals" }
{ $subsection "conventions" }
{ $subsection "syntax" }
{ $subsection "effects" }
-"Data types:"
+{ $subsection "evaluator" }
+{ $heading "Data types" }
{ $subsection "booleans" }
{ $subsection "numbers" }
{ $subsection "collections" }
-"Evaluation semantics:"
-{ $subsection "evaluator" }
+{ $heading "Evaluation" }
{ $subsection "words" }
{ $subsection "shuffle-words" }
{ $subsection "combinators" }
{ $subsection "errors" }
{ $subsection "continuations" }
-"Named values:"
+{ $heading "Named values" }
{ $subsection "locals" }
{ $subsection "namespaces" }
{ $subsection "namespaces-global" }
{ $subsection "values" }
-"Abstractions:"
+{ $heading "Abstractions" }
{ $subsection "objects" }
{ $subsection "destructors" }
{ $subsection "macros" }
{ $subsection "fry" }
-"Program organization:"
+{ $heading "Program organization" }
{ $subsection "vocabs.loader" }
"Vocabularies tagged " { $link T{ vocab-tag { name "extensions" } } } " implement various additional language abstractions." ;
-ARTICLE: "handbook-environment-reference" "Environment reference"
-"Parse time and compile time:"
+ARTICLE: "handbook-system-reference" "The implementation"
+{ $heading "Parse time and compile time" }
{ $subsection "parser" }
{ $subsection "definitions" }
{ $subsection "vocabularies" }
{ $subsection "source-files" }
{ $subsection "compiler" }
-"Tools:"
-{ $subsection "prettyprint" }
-{ $subsection "tools" }
-{ $subsection "help" }
-{ $subsection "inference" }
+{ $heading "Virtual machine" }
{ $subsection "images" }
-"VM:"
{ $subsection "cli" }
{ $subsection "rc-files" }
{ $subsection "init" }
{ $subsection "system" }
{ $subsection "layouts" } ;
-ARTICLE: "handbook-library-reference" "Library reference"
-"This index only includes articles from loaded vocabularies. To explore more vocabularies, see " { $link "vocab-index" } "."
-{ $index [ "handbook" orphan-articles remove ] } ;
+ARTICLE: "handbook-tools-reference" "Developer tools"
+"The below tools are text-based. " { $link "ui-tools" } " are documented separately."
+{ $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"
"Learn the language:"
{ $subsection "first-program" }
"Reference material:"
{ $subsection "handbook-language-reference" }
-{ $subsection "handbook-environment-reference" }
{ $subsection "io" }
{ $subsection "ui" }
+{ $subsection "handbook-system-reference" }
+{ $subsection "handbook-tools-reference" }
{ $subsection "ui-tools" }
-{ $subsection "unicode" }
{ $subsection "alien" }
{ $subsection "handbook-library-reference" }
"Explore loaded libraries:"
{ $link "handbook" }
{ $link "vocab-index" }
{ $link "ui-tools" }
+ { $link "ui-listener" }
}
{ $heading "Recently visited" }
{ $table
io.files io.files.temp io.directories html.streams help kernel
assocs sequences make words accessors arrays help.topics vocabs
tools.vocabs help.vocabs namespaces prettyprint io
-vocabs.loader serialize fry memoize unicode.case math.order
-sorting debugger html xml.syntax xml.writer ;
+vocabs.loader serialize fry memoize ascii unicode.case math.order
+sorting debugger html xml.syntax xml.writer math.parser ;
IN: help.html
: escape-char ( ch -- )
- dup H{
- { CHAR: " "__quo__" }
- { CHAR: * "__star__" }
- { CHAR: : "__colon__" }
- { CHAR: < "__lt__" }
- { CHAR: > "__gt__" }
- { CHAR: ? "__que__" }
- { CHAR: \\ "__back__" }
- { CHAR: | "__pipe__" }
- { CHAR: / "__slash__" }
- { CHAR: , "__comma__" }
- { CHAR: @ "__at__" }
- } at [ % ] [ , ] ?if ;
+ dup ascii? [
+ dup H{
+ { CHAR: " "__quo__" }
+ { CHAR: * "__star__" }
+ { CHAR: : "__colon__" }
+ { CHAR: < "__lt__" }
+ { CHAR: > "__gt__" }
+ { CHAR: ? "__que__" }
+ { CHAR: \\ "__back__" }
+ { CHAR: | "__pipe__" }
+ { CHAR: / "__slash__" }
+ { CHAR: , "__comma__" }
+ { CHAR: @ "__at__" }
+ } at [ % ] [ , ] ?if
+ ] [ number>string "__" "__" surround % ] if ;
: escape-filename ( string -- filename )
[ [ escape-char ] each ] "" make ;
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! 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 ;
"To run help lint, use one of the following two words:"
{ $subsection help-lint }
{ $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:"
{ $list
"ensures examples run and produce stated output"
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: fry accessors sequences parser kernel help help.markup
-help.topics words strings classes tools.vocabs namespaces make
-io io.streams.string prettyprint definitions arrays vectors
-combinators combinators.short-circuit splitting debugger
-hashtables sorting effects vocabs vocabs.loader assocs editors
-continuations classes.predicate macros math sets eval
-vocabs.parser words.symbol values grouping unicode.categories
-sequences.deep ;
+USING: assocs continuations fry help help.lint.checks
+help.topics io kernel namespaces parser sequences
+source-files.errors tools.vocabs vocabs words classes
+locals tools.errors ;
+FROM: help.lint.checks => all-vocabs ;
IN: help.lint
-SYMBOL: vocabs-quot
-
-: 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" throw ] unless ;
-
-: check-nulls ( element -- )
- \ $values swap elements
- null swap deep-member?
- [ "$values should not contain null" throw ] 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" 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
+SYMBOL: lint-failures
+
+lint-failures [ H{ } clone ] initialize
+
+TUPLE: help-lint-error < source-file-error ;
+
+SYMBOL: +help-lint-failure+
+
+T{ error-type
+ { type +help-lint-failure+ }
+ { word ":lint-failures" }
+ { plural "help lint failures" }
+ { 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
+
+M: help-lint-error error-type drop +help-lint-failure+ ;
+
+<PRIVATE
+
+: <help-lint-error> ( error topic -- help-lint-error )
+ \ help-lint-error <definition-error> ;
+
+PRIVATE>
+
+: help-lint-error ( error topic -- )
+ lint-failures get pick
+ [ [ [ <help-lint-error> ] keep ] dip set-at ] [ delete-at drop ] if
+ notify-error-observers ;
+
+<PRIVATE
+
+:: check-something ( topic quot -- )
+ [ quot call( -- ) f ] [ ] recover
+ topic help-lint-error ; inline
: check-word ( word -- )
[ with-file-vocabs ] vocabs-quot set
dup word-help [
- dup '[
+ [ >link ] keep '[
_ dup word-help
[ check-values ]
[ check-class-description ]
: 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 -- )
[ with-interactive-vocabs ] vocabs-quot set
- dup '[
+ >link dup '[
_
[ check-article-title ]
[ article-content check-markup ] bi
] 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 -- )
dup '[ _ vocab-help [ article drop ] when* ] check-something ;
-: check-vocab ( vocab -- seq )
+: check-vocab ( vocab -- )
"Checking " write dup write "..." print
- [
- [ check-about ]
- [ words [ check-word ] each ]
- [ "vocab-articles" get at [ check-article ] each ]
- tri
- ] { } make ;
+ [ vocab check-about ]
+ [ words [ check-word ] each ]
+ [ vocab-articles get at [ check-article ] each ]
+ tri ;
-: run-help-lint ( prefix -- alist )
+PRIVATE>
+
+: help-lint ( prefix -- )
[
- all-vocabs-seq [ vocab-name ] map "all-vocabs" set
- group-articles "vocab-articles" set
+ all-vocabs-seq [ vocab-name ] map all-vocabs set
+ group-articles vocab-articles set
child-vocabs
- [ dup check-vocab ] { } map>assoc
- [ nip empty? not ] assoc-filter
+ [ check-vocab ] each
] 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 ;
+: :lint-failures ( -- ) lint-failures get errors. ;
+
: unlinked-words ( words -- seq )
all-word-help [ article-parent not ] filter ;
all-words
[ word-help not ] filter
[ article-parent ] filter
- [ "predicating" word-prop not ] filter ;
+ [ predicate? not ] filter ;
MAIN: help-lint
{ $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" } "."
$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
-"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
"Add the following three lines to " { $snippet "palindrome-tests.factor" } ":"
{ $code
{ "desc" "a launch descriptor" }
{ "encoding" "an encoding descriptor" }
{ "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
{ $values { "process" process } { "status" object } }
"Redirecting standard input and output to a pipe:"
{ $subsection <process-reader> }
{ $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"
"Starting a command and waiting for it to finish:"
{ $description "Creates a new " { $link input } "." } ;
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 } "." } ;
ARTICLE: "io.streams.plain" "Plain writer streams"
SYMBOL: table-gap
SYMBOL: table-border
-: standard-table-style ( -- style )
+CONSTANT: standard-table-style
H{
{ table-gap { 5 5 } }
{ table-border T{ rgba f 0.8 0.8 0.8 1.0 } }
- } ;
+ }
! Input history
TUPLE: input string ;
-USING: help.markup help.syntax kernel io system prettyprint ;
+USING: help.markup help.syntax kernel io system prettyprint continuations ;
IN: listener
ARTICLE: "listener-watch" "Watching variables in the listener"
{ $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."
{ $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 bye }
-"Finally, the multi-line expression reading word can be used independently of the rest of the listener:"
+"To exit the listener, invoke the " { $link return } " word."
+$nl
+"Multi-line quotations can be read independently of the rest of the listener:"
{ $subsection read-quot } ;
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
{ $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." } ;
-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
{ $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 } "." } ;
namespaces parser lexer sequences strings io.styles
vectors words generic system combinators continuations debugger
definitions compiler.units accessors colors prettyprint fry
-sets vocabs.parser ;
+sets vocabs.parser source-files.errors locals ;
IN: listener
GENERIC: stream-read-quot ( stream -- quot/f )
: read-quot ( -- quot/f ) input-stream get stream-read-quot ;
-<PRIVATE
-
-SYMBOL: quit-flag
-
-PRIVATE>
-
-: bye ( -- ) quit-flag on ;
-
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 ;
10 max-stack-items set-global
+SYMBOL: error-summary-hook
+
<PRIVATE
: title. ( string -- )
] dip
] when stack. ;
-: stacks. ( -- )
+: datastack. ( datastack -- )
display-stacks? get [
- datastack [ nl "--- Data stack:" title. trimmed-stack. ] unless-empty
- ] when ;
+ [ nl "--- Data stack:" title. trimmed-stack. ] unless-empty
+ ] [ drop ] if ;
: 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 ;
-: listen ( -- )
- visible-vars. stacks. prompt.
- [ read-quot [ [ call-error-hook ] recover ] [ bye ] if* ]
- [ dup lexer-error? [ call-error-hook ] [ rethrow ] if ] recover ;
+[ error-summary ] error-summary-hook set-global
+
+: call-error-summary-hook ( -- )
+ 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
-: until-quit ( -- )
- quit-flag get [ quit-flag off ] [ listen until-quit ] if ;
+ (listener) ;
PRIVATE>
: listener ( -- )
- [ until-quit ] with-interactive-vocabs ;
+ [ [ { } (listener) ] with-interactive-vocabs ] with-return ;
MAIN: listener
: invalidate-memoized ( inputs... word -- )
[ stack-effect in>> packer call ] [ "memoize" word-prop delete-at ] bi ;
+
+\ invalidate-memoized t "no-compile" set-word-prop
\ No newline at end of file
[ no-content-disposition ]
} case ;
-: assert-sequence= ( a b -- )
- 2dup sequence= [ 2drop ] [ assert ] if ;
-
: read-assert-sequence= ( sequence -- )
[ length read ] keep assert-sequence= ;
--- /dev/null
+Slava Pestov
\ No newline at end of file
{ $examples
"A model which adds the values of two existing models:"
{ $example
- "USING: models models.arrows.smart accessors math prettyprint ;"
+ "USING: models models.arrow.smart accessors kernel math prettyprint ;"
"1 <model> 2 <model> [ + ] <smart-arrow>"
"[ activate-model ] [ value>> ] bi ."
"3"
}
} ;
-ARTICLE: "models.arrows.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" } "."
+ARTICLE: "models.arrow.smart" "Smart arrow models"
+"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> } ;
-ABOUT: "models.arrows.smart"
\ No newline at end of file
+ABOUT: "models.arrow.smart"
\ No newline at end of file
--- /dev/null
+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
\ No newline at end of file
--- /dev/null
+! 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> ] ;
\ No newline at end of file
! Copyright (C) 2008, 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays fry kernel models.product models.arrow
-sequences unicode.case ;
+USING: fry kernel models.arrow.smart sequences unicode.case ;
IN: models.search
: <search> ( values search quot -- model )
- [ 2array <product> ] dip
- '[ first2 _ curry filter ] <arrow> ;
+ '[ _ curry filter ] <smart-arrow> ; inline
: <string-search> ( values search quot -- model )
- '[ swap @ [ >case-fold ] bi@ subseq? ] <search> ;
+ '[ swap @ [ >case-fold ] bi@ subseq? ] <search> ; inline
-! Copyright (C) 2008 Slava Pestov
+! Copyright (C) 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays fry kernel models.product models.arrow
-sequences sorting ;
+USING: sorting models.arrow.smart fry ;
IN: models.sort
: <sort> ( values sort -- model )
- 2array <product> [ first2 sort ] <arrow> ;
\ No newline at end of file
+ [ '[ _ call( obj1 obj2 -- <=> ) ] sort ] <smart-arrow> ; inline
\ No newline at end of file
[ back>> ] [ front>> ] bi deque boa ;
: flipped ( deque quot -- newdeque )
- [ flip ] dip call flip ;
+ [ flip ] dip call flip ; inline
PRIVATE>
: deque-empty? ( deque -- ? )
! See http://factorcode.org/license.txt for BSD license.
USING: kernel generic sequences io words arrays summary effects
continuations assocs accessors namespaces compiler.errors
-stack-checker.values stack-checker.recursive-state ;
+stack-checker.values stack-checker.recursive-state
+source-files.errors compiler.errors ;
IN: stack-checker.errors
: pretty-word ( word -- word' )
TUPLE: inference-error error type word ;
-M: inference-error compiler-error-type type>> ;
+M: inference-error error-type type>> ;
: (inference-error) ( ... class type -- * )
[ boa ] dip
\ inference-error boa rethrow ; inline
: inference-error ( ... class -- * )
- +error+ (inference-error) ; inline
+ +compiler-error+ (inference-error) ; inline
: inference-warning ( ... class -- * )
- +warning+ (inference-error) ; inline
+ +compiler-warning+ (inference-error) ; inline
TUPLE: literal-expected what ;
: unknown-primitive-error ( -- * )
\ unknown-primitive-error inference-warning ;
+
+TUPLE: transform-expansion-error word error ;
+
+: transform-expansion-error ( word error -- * )
+ \ transform-expansion-error inference-error ;
\ No newline at end of file
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel prettyprint io debugger
-sequences assocs stack-checker.errors summary effects ;
+sequences assocs stack-checker.errors summary effects make ;
IN: stack-checker.errors.prettyprint
+M: inference-error summary error>> summary ;
+
M: inference-error error-help error>> error-help ;
M: inference-error error.
[ word>> [ "In word: " write . ] when* ] [ error>> error. ] bi ;
-M: literal-expected error.
- "Got a computed value where a " write what>> write " was expected" print ;
+M: literal-expected summary
+ [ "Got a computed value where a " % what>> % " was expected" % ] "" make ;
+
+M: literal-expected error. summary print ;
+
+M: unbalanced-branches-error summary
+ drop "Unbalanced branches" ;
M: unbalanced-branches-error error.
- "Unbalanced branches:" print
+ dup summary print
[ quots>> ] [ branches>> [ length <effect> ] { } assoc>map ] bi zip
[ [ first pprint-short bl ] [ second effect>string print ] bi ] each ;
drop
"Quotation pops retain stack elements which it did not push" ;
-M: missing-effect error.
- "The word " write
- word>> pprint
- " must declare a stack effect" print ;
+M: missing-effect summary
+ [
+ "The word " %
+ word>> name>> %
+ " must declare a stack effect" %
+ ] "" make ;
-M: effect-error error.
- "Stack effects of the word " write
- [ word>> pprint " do not match." print ]
- [ "Inferred: " write inferred>> . ]
- [ "Declared: " write declared>> . ] tri ;
+M: effect-error summary
+ [
+ "Stack effect declaration of the word " %
+ word>> name>> % " is wrong" %
+ ] "" make ;
M: recursive-quotation-error error.
"The quotation " write
" calls itself." print
"Stack effect inference is undecidable when quotation-level recursion is permitted." print ;
-M: undeclared-recursion-error error.
- "The inline recursive word " write
- word>> pprint
- " must be declared recursive" print ;
+M: undeclared-recursion-error summary
+ drop
+ "Inline recursive words must be declared recursive" ;
-M: diverging-recursion-error error.
- "The recursive word " write
- word>> pprint
- " digs arbitrarily deep into the stack" print ;
+M: diverging-recursion-error summary
+ [
+ "The recursive word " %
+ word>> name>> %
+ " digs arbitrarily deep into the stack" %
+ ] "" make ;
-M: unbalanced-recursion-error error.
- "The recursive word " write
- word>> pprint
- " leaves with the stack having the wrong height" print ;
+M: unbalanced-recursion-error summary
+ [
+ "The recursive word " %
+ word>> name>> %
+ " leaves with the stack having the wrong height" %
+ ] "" make ;
-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: 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 error.
+M: unknown-primitive-error summary
drop
- "Cannot determine stack effect statically" print ;
+ "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 ;
\ No newline at end of file
alien-callback
} [ t "special" set-word-prop ] each
-{ call execute dispatch load-locals get-local drop-locals }
-[ t "no-compile" set-word-prop ] each
+\ clear t "no-compile" set-word-prop
: non-inline-word ( word -- )
dup called-dependency depends-on
IN: stack-checker.transforms.tests
USING: sequences stack-checker.transforms tools.test math kernel
-quotations stack-checker accessors combinators words arrays
+quotations stack-checker stack-checker.errors accessors combinators words arrays
classes classes.tuple ;
: compose-n-quot ( word n -- quot' ) <repetition> >quotation ;
: member?-test ( a -- ? ) { 1 2 3 10 7 58 } member? ;
[ f ] [ 1.0 member?-test ] unit-test
-[ t ] [ \ member?-test def>> first [ member?-test ] all? ] unit-test
\ No newline at end of file
+[ 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
\ No newline at end of file
[ dup infer-word apply-word/effect ]
} cond ;
+: call-transformer ( word stack quot -- newquot )
+ '[ _ _ with-datastack [ length 1 assert= ] [ first ] bi nip ]
+ [ transform-expansion-error ]
+ recover ;
+
:: ((apply-transform)) ( word quot values stack rstate -- )
rstate recursive-state
- [ stack quot with-datastack first ] with-variable
+ [ word stack quot call-transformer ] with-variable
[
word inlined-dependency depends-on
values [ length meta-d shorten-by ] [ #drop, ] bi
: finish-deploy ( final-image -- )
"Finishing up" show
- [ { } set-datastack ] dip
- { } set-retainstack
V{ } set-namestack
V{ } set-catchstack
"Saving final image" show
USING: eval ;
IN: tools.deploy.test.11
-: foo ( -- ) "USING: math prettyprint ; 2 2 + ." eval ;
+: foo ( -- ) "USING: math prettyprint ; 2 2 + ." eval( -- ) ;
MAIN: foo
\ No newline at end of file
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 ( -- )
[ 1 + ] my-var set-global
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+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"
\ No newline at end of file
--- /dev/null
+! 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 ;
IN: tools.profiler
: profile ( quot -- )
- [ t profiling call ] [ f profiling ] [ ] cleanup ;
+ [ t profiling call ] [ f profiling ] [ ] cleanup ; inline
: filter-counts ( alist -- alist' )
[ second 0 > ] filter ;
ARTICLE: "tools.test.write" "Writing unit tests"
"Assert that a quotation outputs a specific set of values:"
-{ $subsection unit-test }
+{ $subsection POSTPONE: unit-test }
"Assert that a quotation throws an error:"
-{ $subsection must-fail }
-{ $subsection must-fail-with }
+{ $subsection POSTPONE: must-fail }
+{ $subsection POSTPONE: must-fail-with }
"Assert that a quotation or word has a specific static stack effect (see " { $link "inference" } "):"
-{ $subsection must-infer }
-{ $subsection must-infer-as } ;
+{ $subsection POSTPONE: must-infer }
+{ $subsection POSTPONE: must-infer-as }
+"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"
"The following words run test harness files; any test failures are collected and printed at the end:"
{ $subsection test }
-{ $subsection test-all } ;
-
-ARTICLE: "tools.test.failure" "Handling test failures"
-"Most of the time the words documented in " { $link "tools.test.run" } " are used because they print all test failures in human-readable form. Some tools inspect the test failures and takes some kind of action instead, for example, " { $vocab-link "mason" } "."
-$nl
-"The following words output an association list mapping vocabulary names to sequences of failures; a failure is an array having the shape " { $snippet "{ error test continuation }" } ", and the elements are as follows:"
-{ $list
- { { $snippet "error" } " - the error thrown by the unit test" }
- { { $snippet "test" } " - a pair " { $snippet "{ output input }" } " containing expected output and a unit test quotation which didn't produce this output" }
- { { $snippet "continuation" } " - the traceback at the point of the error" }
-}
-"The following words run test harness files and output failures:"
-{ $subsection run-tests }
-{ $subsection run-all-tests }
+{ $subsection test-all }
"The following word prints failures:"
-{ $subsection test-failures. } ;
+{ $subsection :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"
"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."
$nl
"If the test harness needs to define words, they should be placed in a vocabulary named " { $snippet { $emphasis "vocab" } ".tests" } " where " { $emphasis "vocab" } " is the vocab being tested."
{ $subsection "tools.test.write" }
-{ $subsection "tools.test.run" }
-{ $subsection "tools.test.failure" } ;
+{ $subsection "tools.test.run" } ;
ABOUT: "tools.test"
HELP: unit-test
+{ $syntax "[ output ] [ input ] unit-test" }
{ $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." } ;
{ $values { "prefix" "a vocabulary name" } }
{ $description "Runs unit tests for the vocabulary named " { $snippet "prefix" } " and all of its child vocabularies." } ;
-HELP: run-tests
-{ $values { "prefix" "a vocabulary name" } { "failures" "an association list of unit test failures" } }
-{ $description "Runs unit tests for the vocabulary named " { $snippet "prefix" } " and all of its child vocabularies. Outputs unit test failures as documented in " { $link "tools.test.failure" } "." } ;
-
HELP: test-all
{ $description "Runs unit tests for all loaded vocabularies." } ;
-HELP: run-all-tests
-{ $values { "failures" "an association list of unit test failures" } }
-{ $description "Runs unit tests for all loaded vocabularies and outputs unit test failures as documented in " { $link "tools.test.failure" } "." } ;
-
-HELP: test-failures.
-{ $values { "assoc" "an association list of unit test failures" } }
-{ $description "Prints unit test failures output by " { $link run-tests } " or " { $link run-all-tests } " to " { $link output-stream } "." } ;
+HELP: :test-failures
+{ $description "Prints all pending unit test failures." } ;
-! Copyright (C) 2003, 2008 Slava Pestov.
+! Copyright (C) 2003, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors namespaces arrays prettyprint sequences kernel
-vectors quotations words parser assocs combinators continuations
-debugger io io.styles io.files vocabs vocabs.loader source-files
-compiler.units summary stack-checker effects tools.vocabs fry ;
+USING: accessors arrays assocs combinators compiler.units
+continuations debugger effects fry generalizations io io.files
+io.styles kernel lexer locals macros math.parser namespaces
+parser prettyprint quotations sequences source-files splitting
+stack-checker summary unicode.case vectors vocabs vocabs.loader words
+tools.vocabs tools.errors source-files.errors io.streams.string make
+compiler.errors ;
IN: tools.test
-SYMBOL: failures
+TUPLE: test-failure < source-file-error continuation ;
-: <failure> ( error what -- triple )
- error-continuation get 3array ;
+SYMBOL: +test-failure+
-: failure ( error what -- )
+M: test-failure 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
- <failure> failures get push ;
+ <test-failure> test-failures get push
+ notify-error-observers ;
-SYMBOL: this-test
+SYMBOL: file
-: (unit-test) ( what quot -- )
- swap dup . flush this-test set
- failures get [
- [ this-test get failure ] recover
- ] [
- call
- ] if ; inline
+: file-failure ( error -- )
+ f file get f failure ;
-: unit-test ( output input -- )
- [ 2array ] 2keep '[
- _ { } _ with-datastack swap >array assert=
- ] (unit-test) ;
+:: (unit-test) ( output input -- error ? )
+ [ { } input with-datastack output assert-sequence= f f ] [ t ] recover ; inline
: short-effect ( effect -- pair )
[ in>> length ] [ out>> length ] bi 2array ;
-: must-infer-as ( effect quot -- )
- [ 1quotation ] dip '[ _ infer short-effect ] unit-test ;
+:: (must-infer-as) ( effect quot -- error ? )
+ [ quot infer short-effect effect assert= f f ] [ t ] recover ; inline
+
+:: (must-infer) ( word/quot -- error ? )
+ word/quot dup word? [ '[ _ execute ] ] when :> quot
+ [ quot infer drop f f ] [ t ] recover ; inline
+
+TUPLE: did-not-fail ;
+CONSTANT: did-not-fail T{ did-not-fail }
+
+M: did-not-fail summary drop "Did not fail" ;
+
+:: (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 ;
-: must-infer ( word/quot -- )
- dup word? [ 1quotation ] when
- '[ _ infer drop ] [ ] swap unit-test ;
+MACRO: <experiment> ( word -- )
+ [ stack-effect in>> length dup ]
+ [ name>> experiment-title ] bi
+ '[ _ ndup _ narray _ prefix ] ;
-: must-fail-with ( quot pred -- )
- [ '[ @ f ] ] dip '[ _ _ recover ] [ t ] swap unit-test ;
+: experiment. ( seq -- )
+ [ first write ": " write ] [ rest . ] bi ;
-: must-fail ( quot -- )
- [ drop t ] must-fail-with ;
+:: experiment ( word: ( -- error ? ) line# -- )
+ word <experiment> :> e
+ e experiment.
+ word execute [
+ file get [
+ e file get line# failure
+ ] [ rethrow ] if
+ ] [ drop ] if ; inline
-: (run-test) ( vocab -- )
+: 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?>> [
- vocab-tests [ run-file ] each
+ vocab-tests [ run-test-file ] each
] [ drop ] if ;
-: run-test ( vocab -- failures )
- V{ } clone [
- failures [
- [ (run-test) ] [ swap failure ] recover
- ] with-variable
- ] keep ;
-
-: failure. ( triple -- )
- dup second .
- dup first print-error
- "Traceback" swap third write-object ;
-
-: test-failures. ( assoc -- )
- [
- nl
- [
- "==== ALL TESTS PASSED" print
- ] [
- "==== FAILING TESTS:" print
- [
- swap vocab-heading.
- [ failure. nl ] each
- ] assoc-each
- ] if-empty
- ] [
- "==== NOTHING TO TEST" print
- ] if* ;
-
-: run-tests ( prefix -- failures )
- child-vocabs [ f ] [
- [ dup run-test ] { } map>assoc
- [ second empty? not ] filter
- ] if-empty ;
+: traceback-button. ( failure -- )
+ "[" write [ "Traceback" ] dip continuation>> write-object "]" print ;
-: test ( prefix -- )
- run-tests test-failures. ;
+PRIVATE>
-: run-all-tests ( -- failures )
- "" run-tests ;
+TEST: unit-test
+TEST: must-infer-as
+TEST: must-infer
+TEST: must-fail-with
+TEST: must-fail
+
+M: test-failure summary
+ asset>> [ [ experiment. ] with-string-writer ] [ "Top-level form" ] if* ;
+
+M: test-failure error. ( error -- )
+ [ call-next-method ]
+ [ traceback-button. ]
+ bi ;
+
+: :test-failures ( -- ) test-failures get errors. ;
+
+: test ( prefix -- )
+ child-vocabs [ run-vocab-tests ] each ;
-: test-all ( -- )
- run-all-tests test-failures. ;
+: test-all ( -- ) "" test ;
recover\r
] each\r
failures get\r
- ] with-compiler-errors ;\r
+ ] with-scope ;\r
\r
: source-modified? ( path -- ? )\r
dup source-files get at [\r
]
] initialize
+<< {
+ (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 >>
+
! Messages sent to walker thread
SYMBOL: step
SYMBOL: step-out
! Service support; evaluate Factor code from other apps
:: do-service ( pboard error quot -- )
pboard error ?pasteboard-string
- dup [ quot call ] when
+ dup [ quot call( string -- result/f ) ] when
[ pboard set-pasteboard-string ] when* ;
CLASS: {
! Copyright (C) 2009 Slava Pestov.
! 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 ;
IN: ui.baseline-alignment
[ dup [ 2dup - ] [ f ] if ] dip
gadget-metrics boa ; inline
+: ?supremum ( seq -- n/f )
+ sift [ f ] [ supremum ] if-empty ;
+
: max-ascent ( seq -- n )
- 0 [ ascent>> [ max ] when* ] reduce ; inline
+ [ ascent>> ] map ?supremum ;
: max-cap-height ( seq -- n )
- 0 [ cap-height>> [ max ] when* ] reduce ; inline
+ [ cap-height>> ] map ?supremum ;
: max-descent ( seq -- n )
- 0 [ descent>> [ max ] when* ] reduce ; inline
+ [ descent>> ] map ?supremum ;
: max-text-height ( seq -- y )
- 0 [ [ height>> ] [ ascent>> ] bi [ max ] [ drop ] if ] reduce ;
+ [ ascent>> ] filter [ height>> ] map ?supremum ;
: max-graphics-height ( seq -- y )
- 0 [ [ height>> ] [ ascent>> ] bi [ drop ] [ max ] if ] reduce ;
-
-: (align-baselines) ( y max leading -- y' ) [ swap - ] dip + ;
+ [ ascent>> not ] filter [ height>> ] map ?supremum 0 or ;
:: combine-metrics ( graphics-height ascent descent cap-height -- ascent' descent' )
- cap-height 2 / :> mid-line
- graphics-height 2 /
- [ ascent mid-line - max mid-line + >integer ]
- [ descent mid-line + max mid-line - >integer ] bi ;
+ ascent [
+ cap-height 2 / :> mid-line
+ graphics-height 2 /
+ [ ascent mid-line - max mid-line + 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>
:: align-baselines ( gadgets -- ys )
gadgets [ dup pref-dim <gadget-metrics> ] map
- dup max-ascent :> max-ascent
- dup max-cap-height :> max-cap-height
+ dup max-ascent 0 or :> max-ascent
+ dup max-cap-height 0 or :> max-cap-height
dup max-graphics-height :> max-graphics-height
max-cap-height max-graphics-height + 2 /i :> critical-line
[
dup ascent>>
- [ ascent>> max-ascent text-leading ]
- [ height>> max-graphics-height graphics-leading ] if
- (align-baselines)
+ [ ascent>> max-ascent swap - text-leading ]
+ [ height>> max-graphics-height swap - 2/ graphics-leading ] if +
] map ;
: measure-metrics ( children sizes -- ascent descent )
- [ <gadget-metrics> ] 2map
- {
- [ max-graphics-height ]
- [ max-ascent ]
- [ max-descent ]
- [ max-cap-height ]
- } cleave
- combine-metrics ;
+ (measure-metrics) combine-metrics ;
: measure-height ( children sizes -- height )
- measure-metrics + ;
\ No newline at end of file
+ (measure-metrics) dup [ combine-metrics + ] [ 3drop ] if ;
\ No newline at end of file
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors ui.images ui.pens
-ui.pens.image ui.gadgets ;
+ui.pens.image ui.gadgets ui.gadgets.labels ;
IN: ui.gadgets.icons
TUPLE: icon < gadget ;
: <icon> ( image-name -- icon )
icon new swap <image-pen> t >>fill? >>interior ;
-M: icon pref-dim* dup interior>> pen-pref-dim ;
\ No newline at end of file
+M: icon pref-dim* dup interior>> pen-pref-dim ;
+
+M: image-name >label <icon> ;
\ No newline at end of file
[ ] [ "g" get prefer ] unit-test
-[ ] [ "g" get layout ] unit-test
\ No newline at end of file
+[ ] [ "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
\ No newline at end of file
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: sequences ui.gadgets ui.baseline-alignment kernel math
-math.functions math.vectors math.order math.rectangles namespaces
-accessors fry combinators arrays ;
+USING: sequences ui.gadgets ui.baseline-alignment
+ui.baseline-alignment.private kernel math math.functions math.vectors
+math.order math.rectangles namespaces accessors fry combinators arrays ;
IN: ui.gadgets.packs
TUPLE: pack < gadget
children>> dup pref-dims measure-metrics drop ;
: pack-cap-height ( pack -- n )
- children>> [ cap-height ] map sift
- [ f ] [ supremum ] if-empty ;
+ children>> [ cap-height ] map ?supremum ;
PRIVATE>
kernel sequences io io.styles io.streams.string tools.test
prettyprint definitions help help.syntax help.markup
help.stylesheet splitting ui.gadgets.debug models math summary
-inspector accessors help.topics see ;
+inspector accessors help.topics see fry ;
IN: ui.gadgets.panes.tests
: #children ( -- n ) "pane" get children>> length ;
[ t ] [ #children "num-children" get = ] unit-test
: test-gadget-text ( quot -- ? )
- dup make-pane gadget-text dup print "======" print
- swap with-string-writer dup print = ;
+ '[ _ call( -- ) ]
+ [ make-pane gadget-text dup print "======" print ]
+ [ with-string-writer dup print ] bi = ;
[ t ] [ [ "hello" write ] test-gadget-text ] unit-test
[ t ] [ [ "hello" pprint ] test-gadget-text ] unit-test
TUPLE: presentation < button object hook ;
: invoke-presentation ( presentation command -- )
- [ [ dup hook>> call ] [ object>> ] bi ] dip
+ [ [ dup hook>> call( presentation -- ) ] [ object>> ] bi ] dip
invoke-command ;
: invoke-primary ( presentation -- )
dup field>> { 2 2 } <filled-border> f track-add
values search 500 milliseconds <delay> quot <string-search>
renderer <table> f >>takes-focus? >>table
- dup table>> <scroller> 1 track-add ;
+ dup table>> <scroller> 1 track-add ; inline
M: search-table model-changed
nip field>> clear-search-field ;
} define-command
: close ( slot-editor -- )
- dup close-hook>> call ;
+ dup close-hook>> call( slot-editor -- ) ;
\ close H{
{ +description+ "Close the slot editor without saving changes." }
} define-command
: close-and-update ( slot-editor -- )
- [ update-hook>> call ] [ close ] bi ;
+ [ update-hook>> call( -- ) ] [ close ] bi ;
: slot-editor-value ( slot-editor -- object )
text>> control-value parse-fresh first ;
{ +description+ "Parse the object being edited, and store the result back into the edited slot." }
} define-command
-: eval-1 ( string -- object )
- 1array [ eval ] with-datastack first ;
-
: 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 ]
bi ;
GENERIC: cell-width ( font cell -- x )
GENERIC: cell-height ( font cell -- y )
+GENERIC: cell-padding ( cell -- y )
GENERIC: draw-cell ( font cell -- )
M: string cell-width text-width ;
M: string cell-height text-height ceiling ;
+M: string cell-padding drop 0 ;
M: string draw-cell draw-text ;
+CONSTANT: image-padding 2
+
M: image-name cell-width nip image-dim first ;
M: image-name cell-height nip image-dim second ;
+M: image-name cell-padding drop image-padding ;
M: image-name draw-cell nip draw-image ;
: table-rows ( table -- rows )
if ;
: row-column-widths ( table row -- widths )
- [ font>> ] dip [ cell-width ] with map ;
+ [ font>> ] dip [ [ cell-width ] [ cell-padding ] bi + ] with map ;
: compute-total-width ( gap widths -- total )
swap [ column-offsets drop ] keep - ;
'[ [ 0 2array ] [ _ 2array ] bi gl-line ] each
] bi ;
-: column-loc ( font column width align -- loc )
- [ [ cell-width ] dip swap - ] dip
- * >integer 0 2array ;
+:: column-loc ( font column width align -- loc )
+ font column cell-width width swap - align * column cell-padding 2 / 1 align - * +
+ font column cell-height \ line-height get swap - 2 /
+ [ >integer ] bi@ 2array ;
: translate-column ( width gap -- )
+ 0 2array gl-translate ;
M: table draw-gadget*
dup control-value empty? [ drop ] [
- {
- [ draw-selected-row ]
- [ draw-lines ]
- [ draw-column-lines ]
- [ draw-focused-row ]
- [ draw-moused-row ]
- } cleave
+ dup line-height \ line-height [
+ {
+ [ draw-selected-row ]
+ [ draw-lines ]
+ [ draw-column-lines ]
+ [ draw-focused-row ]
+ [ draw-moused-row ]
+ } cleave
+ ] with-variable
] if ;
M: table line-height ( table -- y )
[ font>> ] [ renderer>> prototype-row ] bi
- [ cell-height ] with [ max ] map-reduce ;
+ [ [ cell-height ] [ cell-padding ] bi + ] with
+ [ max ] map-reduce ;
M: table pref-dim*
[ compute-column-widths drop ] keep
column-title-background <solid> >>interior ;
: draw-column-titles ( table -- )
- {
- [ renderer>> column-titles ]
- [ column-widths>> ]
- [ table-column-alignment ]
- [ font>> column-title-font ]
- [ gap>> ]
- } cleave
- draw-columns ;
+ dup font>> font-metrics height>> \ line-height [
+ {
+ [ renderer>> column-titles ]
+ [ column-widths>> ]
+ [ table-column-alignment ]
+ [ font>> column-title-font ]
+ [ gap>> ]
+ } cleave
+ draw-columns
+ ] with-variable ;
M: column-headers draw-gadget*
table>> draw-column-titles ;
IN: ui.operations
: $operations ( element -- )
- >quotation call
+ >quotation call( -- obj )
f operations>commands
command-map. ;
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: debugger help help.topics help.crossref help.home kernel models
+USING: debugger classes help help.topics help.crossref help.home kernel models
compiler.units assocs words vocabs accessors fry arrays
combinators.short-circuit namespaces sequences models help.apropos
combinators ui ui.commands ui.gadgets ui.gadgets.panes
: browser-window ( -- )
"help.home" (browser-window) ;
+: error-help-window ( error -- )
+ [ error-help ]
+ [ dup tuple? [ class ] [ drop "errors" ] if ] bi or (browser-window) ;
+
\ browser-window H{ { +nullary+ t } } define-command
: com-browse ( link -- )
: show-links-popup ( browser-gadget quot title -- )
[ dup model>> ] 2dip <links-popup>
- [ hand-loc get { 0 0 } <rect> show-glass ] [ request-focus ] bi ;
+ [ hand-loc get { 0 0 } <rect> show-glass ] [ request-focus ] bi ; inline
: com-show-outgoing-links ( browser-gadget -- )
[ uses ] "Outgoing links" show-links-popup ;
ui.gadgets.presentations ui.gadgets.viewports ui.gadgets.tables
ui.gadgets.tracks ui.gadgets.scrollers ui.gadgets.panes
ui.gadgets.borders ui.gadgets.status-bar ui.tools.traceback
-ui.tools.inspector ;
+ui.tools.inspector ui.tools.browser ;
IN: ui.tools.debugger
TUPLE: debugger < track error restarts restart-hook restart-list continuation ;
: com-traceback ( debugger -- ) continuation>> traceback-window ;
-: com-help ( debugger -- ) error>> (:help) ;
-
-\ com-help H{ { +listener+ t } } define-command
+: com-help ( debugger -- ) error>> error-help-window ;
: com-edit ( debugger -- ) error>> (:edit) ;
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+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"
--- /dev/null
+! 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
USING: help.markup help.syntax ui.commands ui.gadgets.slots
-ui.gadgets.editors ;
+ui.gadgets.editors kernel ;
IN: ui.tools.inspector
ARTICLE: "ui-inspector-edit" "Editing slot values in the inspector"
"The UI inspector is an instance of " { $link inspector-gadget } "."
{ $subsection "ui-inspector-edit" } ;
+HELP: inspector
+{ $values { "obj" object } }
+{ $description "Opens a new inspector window displaying the slots of " { $snippet "obj" } "." } ;
+
ABOUT: "ui-inspector"
\ No newline at end of file
{ $command-map interactor "quotation" }
{ $heading "Editing 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" }
"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" } "." ;
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs calendar combinators locals
-colors.constants combinators.short-circuit compiler.units
-help.tips concurrency.flags concurrency.mailboxes continuations
-destructors documents documents.elements fry hashtables help
-help.markup io io.styles kernel lexer listener math models
+source-files.errors colors.constants combinators.short-circuit
+compiler.units help.tips concurrency.flags concurrency.mailboxes
+continuations destructors documents documents.elements fry hashtables
+help help.markup io io.styles kernel lexer listener math models sets
models.delay models.arrow namespaces parser prettyprint quotations
sequences strings threads tools.vocabs vocabs vocabs.loader
vocabs.parser words debugger ui ui.commands ui.pens.solid ui.gadgets
ui.gadgets.status-bar ui.gadgets.tracks ui.gadgets.borders ui.gestures
ui.operations ui.tools.browser ui.tools.common ui.tools.debugger
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
! If waiting is t, we're waiting for user input, and invoking
{ T{ key-down f { C+ } "r" } history-completion-popup }
} 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 -- )
dup listener-streams [
[ com-browse ] help-hook set
'[ [ _ input>> ] 2dip debugger-popup ] error-hook set
+ [ ui-error-summary ] error-summary-hook set
tip-of-the-day. nl
listener
] with-streams* ;
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: continuations definitions generic help.topics threads
-stack-checker summary io.pathnames io.styles kernel namespaces
-parser prettyprint quotations tools.crossref tools.annotations
-editors tools.profiler tools.test tools.time tools.walker vocabs
-vocabs.loader words sequences tools.vocabs classes
-compiler.units accessors vocabs.parser macros.expander ui
-ui.tools.browser ui.tools.listener ui.tools.listener.completion
-ui.tools.profiler ui.tools.inspector ui.tools.traceback
-ui.commands ui.gadgets.editors ui.gestures ui.operations
-ui.tools.deploy models help.tips ;
+stack-checker summary io.pathnames io.styles kernel namespaces parser
+prettyprint quotations tools.crossref tools.annotations editors
+tools.profiler tools.test tools.time tools.walker vocabs vocabs.loader
+words sequences tools.vocabs classes compiler.errors compiler.units
+accessors vocabs.parser macros.expander ui ui.tools.browser
+ui.tools.listener ui.tools.listener.completion ui.tools.profiler
+ui.tools.inspector ui.tools.traceback ui.commands ui.gadgets.editors
+ui.gestures ui.operations ui.tools.deploy models help.tips
+source-files.errors ;
IN: ui.tools.operations
! Objects
{ +listener+ t }
} 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 -- )
[ forget ] with-compilation-unit ;
"These commands operate on the entire contents of the input area."
[ ]
[ quot-action ]
-define-operation-map
+define-operation-map
\ No newline at end of file
--- /dev/null
+USING: ui.tools.profiler tools.test ;
+
+\ profiler-window must-infer
ui.tools.browser ui.tools.common ui.baseline-alignment
ui.operations ui.images ;
FROM: models.arrow => <arrow> ;
+FROM: models.arrow.smart => <smart-arrow> ;
FROM: models.product => <product> ;
IN: ui.tools.profiler
: <methods-model> ( profiler -- model )
[
[ method-counters <model> ] dip
- [ generic>> ] [ class>> ] bi 3array <product>
- [ first3 '[ _ _ method-matches? ] filter ] <arrow>
+ [ generic>> ] [ class>> ] bi
+ [ '[ _ _ method-matches? ] filter ] <smart-arrow>
] keep <profiler-model> ;
: sort-by-name ( obj1 obj2 -- <=> )
: profiler-window ( -- )
<profiler-gadget> "Profiling results" open-status-window ;
-: com-profile ( quot -- ) profile profiler-window ;
+: com-profile ( quot -- ) profile profiler-window ; inline
MAIN: profiler-window
{ $subsection "ui-listener" }
{ $subsection "ui-browser" }
{ $subsection "ui-inspector" }
+{ $subsection "ui.tools.error-list" }
{ $subsection "ui.tools.profiler" }
{ $subsection "ui-walker" }
{ $subsection "ui.tools.deploy" }
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: memory system kernel tools.vocabs ui.tools.operations
-ui.tools.listener ui.tools.browser ui.tools.common
+ui.tools.listener ui.tools.browser ui.tools.common ui.tools.error-list
ui.tools.walker ui.commands ui.gestures ui ui.private ;
IN: ui.tools
{ T{ key-down f { A+ } "w" } close-window }
{ T{ key-down f { A+ } "q" } com-exit }
{ T{ key-down f f "F2" } refresh-all }
+ { T{ key-down f f "F3" } show-error-list }
} define-command-map
\ No newline at end of file
--- /dev/null
+unportable
+bindings
xim get-global XCloseIM drop f xim set-global ;
: with-xim ( quot -- )
- [ "Factor" init-xim ] dip [ close-xim ] [ ] cleanup ;
+ [ "Factor" init-xim ] dip [ close-xim ] [ ] cleanup ; inline
: create-xic ( window classname -- xic )
[
: close-x ( -- ) dpy get XCloseDisplay drop ;
: with-x ( display-string quot -- )
- [ initialize-x ] dip [ close-x ] [ ] cleanup ;
+ [ initialize-x ] dip [ close-x ] [ ] cleanup ; inline
{ $subsection set-alien-float }
{ $subsection set-alien-double } ;
-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 } ;
-
ARTICLE: "alien-invoke" "Calling C from Factor"
"The easiest way to call into a C library is to define bindings using a pair of parsing words:"
{ $subsection POSTPONE: LIBRARY: }
] [ callable? ] if
] find nip ;
+\ case-find t "no-compile" set-word-prop
+
: case ( obj assoc -- )
case-find {
{ [ dup array? ] [ nip second call ] }
+++ /dev/null
-Slava Pestov
+++ /dev/null
-IN: compiler.errors
-USING: help.markup help.syntax vocabs.loader words io
-quotations words.symbol ;
-
-ARTICLE: "compiler-errors" "Compiler warnings and errors"
-"After loading a vocabulary, you might see messages like:"
-{ $code
- ":errors - print 2 compiler errors."
- ":warnings - print 50 compiler warnings."
-}
-"These warnings arise from the compiler's stack effect checker. Warnings are non-fatal conditions -- not all code has a static stack effect, so you try to minimize warnings but understand that in many cases they cannot be eliminated. Errors indicate programming mistakes, such as erroneous stack effect declarations."
-$nl
-"The precise warning and error conditions are documented in " { $link "inference-errors" } "."
-$nl
-"Words to view warnings and errors:"
-{ $subsection :errors }
-{ $subsection :warnings }
-{ $subsection :linkage }
-"Words such as " { $link require } " use a combinator which counts errors and prints a report at the end:"
-{ $subsection with-compiler-errors } ;
-
-HELP: compiler-errors
-{ $var-description "Global variable holding an assoc mapping words to compiler errors. This variable is set by " { $link with-compiler-errors } "." } ;
-
-ABOUT: "compiler-errors"
-
-HELP: compiler-error
-{ $values { "error" "an error" } { "word" word } }
-{ $description "If inside a " { $link with-compiler-errors } ", saves the error for future persual via " { $link :errors } ", " { $link :warnings } " and " { $link :linkage } ". If not inside a " { $link with-compiler-errors } ", ignores the error." } ;
-
-HELP: compiler-error.
-{ $values { "error" "an error" } { "word" word } }
-{ $description "Prints a compiler error to " { $link output-stream } "." } ;
-
-HELP: compiler-errors.
-{ $values { "type" symbol } }
-{ $description "Prints compiler errors to " { $link output-stream } ". The type parameter is one of " { $link +error+ } ", " { $link +warning+ } ", or " { $link +linkage+ } "." } ;
-HELP: :errors
-{ $description "Prints all serious compiler errors from the most recent compile to " { $link output-stream } "." } ;
-
-HELP: :warnings
-{ $description "Prints all ignorable compiler warnings from the most recent compile to " { $link output-stream } "." } ;
-
-HELP: :linkage
-{ $description "Prints all C library interface linkage errors from the most recent compile to " { $link output-stream } "." } ;
-
-{ :errors :warnings } related-words
-
-HELP: with-compiler-errors
-{ $values { "quot" quotation } }
-{ $description "Calls the quotation and collects any compiler warnings and errors. Compiler warnings and errors are summarized at the end and can be viewed with " { $link :errors } ", " { $link :warnings } ", and " { $link :linkage } "." }
-{ $notes "Nested calls to " { $link with-compiler-errors } " are ignored, and only the outermost call collects warnings and errors." } ;
+++ /dev/null
-! Copyright (C) 2007, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces make assocs io sequences
-sorting continuations math math.parser ;
-IN: compiler.errors
-
-SYMBOL: +error+
-SYMBOL: +warning+
-SYMBOL: +linkage+
-
-GENERIC: compiler-error-type ( error -- ? )
-
-M: object compiler-error-type drop +error+ ;
-
-GENERIC# compiler-error. 1 ( error word -- )
-
-SYMBOL: compiler-errors
-
-SYMBOL: with-compiler-errors?
-
-: errors-of-type ( type -- assoc )
- compiler-errors get-global
- swap [ [ nip compiler-error-type ] dip eq? ] curry
- assoc-filter ;
-
-: compiler-errors. ( type -- )
- errors-of-type >alist sort-keys
- [ swap compiler-error. ] assoc-each ;
-
-: (compiler-report) ( what type word -- )
- over errors-of-type assoc-empty? [ 3drop ] [
- [
- ":" %
- %
- " - print " %
- errors-of-type assoc-size #
- " " %
- %
- "." %
- ] "" make print
- ] if ;
-
-: compiler-report ( -- )
- "semantic errors" +error+ "errors" (compiler-report)
- "semantic warnings" +warning+ "warnings" (compiler-report)
- "linkage errors" +linkage+ "linkage" (compiler-report) ;
-
-: :errors ( -- ) +error+ compiler-errors. ;
-
-: :warnings ( -- ) +warning+ compiler-errors. ;
-
-: :linkage ( -- ) +linkage+ compiler-errors. ;
-
-: compiler-error ( error word -- )
- with-compiler-errors? get [
- compiler-errors get pick
- [ set-at ] [ delete-at drop ] if
- ] [ 2drop ] if ;
-
-: with-compiler-errors ( quot -- )
- with-compiler-errors? get "quiet" get or [ call ] [
- [
- with-compiler-errors? on
- V{ } clone compiler-errors set-global
- [ compiler-report ] [ ] cleanup
- ] with-scope
- ] if ; inline
+++ /dev/null
-Compiler warning and error reporting
-IN: compiler.units.tests
USING: definitions compiler.units tools.test arrays sequences words kernel
-accessors namespaces fry ;
+accessors namespaces fry eval ;
+IN: compiler.units.tests
[ [ [ ] define-temp ] with-compilation-unit ] must-infer
[ [ [ ] define-temp ] with-nested-compilation-unit ] must-infer
"a" get [ "B" ] define
] with-compilation-unit
"b" get execute
-] unit-test
\ No newline at end of file
+] unit-test
+
+! Notify observers even if compilation unit did nothing
+SINGLETON: observer
+
+observer add-definition-observer
+
+SYMBOL: counter
+
+0 counter set-global
+
+M: observer definitions-changed 2drop global [ counter inc ] bind ;
+
+[ ] with-compilation-unit
+
+[ 1 ] [ counter get-global ] unit-test
+
+observer remove-definition-observer
+
+! Notify observers with nested compilation units
+observer add-definition-observer
+
+0 counter set-global
+
+DEFER: nesting-test
+
+[ ] [ "IN: compiler.units.tests << : nesting-test ( -- ) ; >>" eval ] unit-test
+
+observer remove-definition-observer
\ No newline at end of file
USING: accessors arrays kernel continuations assocs namespaces
sequences words vocabs definitions hashtables init sets
math math.order classes classes.algebra classes.tuple
-classes.tuple.private generic ;
+classes.tuple.private generic source-files.errors ;
IN: compiler.units
SYMBOL: old-definitions
definition-observers get push ;
: remove-definition-observer ( obj -- )
- definition-observers get delete ;
+ definition-observers get delq ;
: notify-definition-observers ( assoc -- )
definition-observers get
changed-generics get compiled-generic-usages
append assoc-combine keys ;
-: unxref-forgotten-definitions ( -- )
- forgotten-definitions get
- keys [ word? ] filter
- [ delete-compiled-xref ] each ;
+: process-forgotten-definitions ( -- )
+ forgotten-definitions get keys
+ [ [ word? ] filter [ delete-compiled-xref ] each ]
+ [ [ delete-definition-errors ] each ]
+ bi ;
: finish-compilation-unit ( -- )
remake-generics
to-recompile recompile
update-tuples
- unxref-forgotten-definitions
- modify-code-heap ;
+ process-forgotten-definitions
+ modify-code-heap
+ updated-definitions notify-definition-observers
+ notify-error-observers ;
: with-nested-compilation-unit ( quot -- )
[
H{ } clone new-classes set
<definitions> new-definitions set
<definitions> old-definitions set
- [
- finish-compilation-unit
- updated-definitions
- notify-definition-observers
- ] [ ] cleanup
+ [ finish-compilation-unit ] [ ] cleanup
] with-scope ; inline
{ $heading "Anti-pattern #4: Logging and rethrowing" }
"If you are going to rethrow an error, do not log a message. If you do so, the user will see two log messages for the same error, which will clutter logs without adding any useful information." ;
-ARTICLE: "errors" "Error handling"
+ARTICLE: "errors" "Exception handling"
"Support for handling exceptional situations such as bad user input, implementation bugs, and input/output errors is provided by a set of words built using continuations."
$nl
"Two words raise an error in the innermost error handler for the current dynamic extent:"
! See http://factorcode.org/license.txt for BSD license.
USING: arrays vectors kernel kernel.private sequences
namespaces make math splitting sorting quotations assocs
-combinators combinators.private accessors ;
+combinators combinators.private accessors words ;
IN: continuations
SYMBOL: error
[ set-datastack ] dip
set-callstack ;
+\ (continue) t "no-compile" set-word-prop
+
PRIVATE>
: continue-with ( obj continuation -- * )
GENERIC: effective-method ( generic -- method )
+\ effective-method t "no-compile" set-word-prop
+
: next-method-class ( class generic -- class/f )
order [ class<= ] with filter reverse dup length 1 =
[ drop f ] [ second ] if ;
effect boa
] [ 2drop f ] if ;
+M: engine-word where "tuple-dispatch-generic" word-prop where ;
+
M: engine-word crossref? "forgotten" word-prop not ;
M: engine-word irrelevant? drop t ;
sequences strings io.files io.pathnames definitions
continuations sorting classes.tuple compiler.units debugger
vocabs vocabs.loader accessors eval combinators lexer
-vocabs.parser words.symbol multiline ;
+vocabs.parser words.symbol multiline source-files.errors ;
IN: parser.tests
\ run-file must-infer
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays definitions generic assocs kernel math namespaces
-sequences strings vectors words words.symbol quotations io combinators
-sorting splitting math.parser effects continuations io.files vocabs
-io.encodings.utf8 source-files classes hashtables compiler.errors
-compiler.units accessors sets lexer vocabs.parser effects.parser slots ;
+sequences strings vectors words words.symbol quotations io
+combinators sorting splitting math.parser effects continuations
+io.files vocabs io.encodings.utf8 source-files classes
+hashtables compiler.units accessors sets lexer vocabs.parser
+effects.parser slots ;
IN: parser
: location ( -- loc )
: parse-file ( file -- quot )
[
- [
- [ parsing-file ] keep
- [ utf8 <file-reader> ] keep
- parse-stream
- ] with-compiler-errors
+ [ parsing-file ] keep
+ [ utf8 <file-reader> ] keep
+ parse-stream
] [
over parse-file-restarts rethrow-restarts
drop parse-file
"Wrappers are used to push words on the data stack; they evaluate to the object being wrapped:"
{ $subsection wrapper }
{ $subsection literalize }
+"Wrapper literal syntax is documented in " { $link "syntax-words" } "."
{ $see-also "combinators" } ;
ABOUT: "quotations"
2dup [ length ] bi@ =
[ mismatch not ] [ 2drop f ] if ; inline
+ERROR: assert-sequence got expected ;
+
+: assert-sequence= ( a b -- )
+ 2dup sequence= [ 2drop ] [ assert-sequence ] if ;
+
: sequence-hashcode-step ( oldhash newpart -- newhash )
>fixnum swap [
[ -2 fixnum-shift-fast ] [ 5 fixnum-shift-fast ] bi
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+USING: assocs compiler.errors compiler.units definitions
+namespaces source-files.errors tools.test words ;
+IN: source-files.errors.tests
+
+DEFER: forget-test
+
+[ ] [ [ \ forget-test [ 1 ] (( -- )) define-declared ] with-compilation-unit ] unit-test
+[ t ] [ \ forget-test compiler-errors get key? ] unit-test
+[ ] [ [ \ forget-test forget ] with-compilation-unit ] unit-test
+[ f ] [ \ forget-test compiler-errors get key? ] unit-test
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs kernel math.order sorting sequences definitions
+namespaces arrays splitting io math.parser math init ;
+IN: source-files.errors
+
+TUPLE: source-file-error error asset file line# ;
+
+: sort-errors ( errors -- alist )
+ [ [ [ line#>> ] compare ] sort ] { } assoc-map-as sort-keys ;
+
+: group-by-source-file ( errors -- assoc )
+ H{ } clone [ [ push-at ] curry [ dup file>> ] prepose each ] keep ;
+
+TUPLE: error-type type word plural icon quot forget-quot ;
+
+GENERIC: error-type ( error -- type )
+
+: <definition-error> ( error definition class -- source-file-error )
+ new
+ swap
+ [ >>asset ]
+ [ where [ first2 [ >>file ] [ >>line# ] bi* ] when* ] bi
+ swap >>error ; inline
+
+SYMBOL: error-types
+
+error-types [ V{ } clone ] initialize
+
+: define-error-type ( error-type -- )
+ dup type>> error-types get set-at ;
+
+: error-icon-path ( type -- icon )
+ error-types get at icon>> ;
+
+: error-counts ( -- alist )
+ error-types get [ nip dup quot>> call( -- seq ) length ] assoc-map ;
+
+: error-summary ( -- )
+ error-counts
+ [ nip 0 > ] assoc-filter
+ [
+ over
+ [ word>> write ]
+ [ " - show " write number>string write bl ]
+ [ plural>> print ] tri*
+ ] assoc-each ;
+
+: all-errors ( -- errors )
+ error-types get values
+ [ quot>> call( -- seq ) ] map
+ concat ;
+
+GENERIC: errors-changed ( observer -- )
+
+SYMBOL: error-observers
+
+[ V{ } clone error-observers set-global ] "source-files.errors" add-init-hook
+
+: add-error-observer ( observer -- ) error-observers get push ;
+
+: remove-error-observer ( observer -- ) error-observers get delq ;
+
+: notify-error-observers ( -- ) error-observers get [ errors-changed ] each ;
+
+: delete-file-errors ( seq file type -- )
+ [
+ [ swap file>> = ] [ swap error-type = ]
+ bi-curry* bi and not
+ ] 2curry filter-here
+ notify-error-observers ;
+
+: delete-definition-errors ( definition -- )
+ error-types get [
+ second forget-quot>> dup
+ [ call( definition -- ) ] [ 2drop ] if
+ ] with each ;
\ No newline at end of file
sequences strings vectors words quotations io io.files
io.pathnames combinators sorting splitting math.parser effects
continuations checksums checksums.crc32 vocabs hashtables graphs
-compiler.units io.encodings.utf8 accessors ;
+compiler.units io.encodings.utf8 accessors source-files.errors ;
IN: source-files
SYMBOL: source-files
[
source-file
[ unxref-source ]
- [ definitions>> [ keys forget-all ] each ]
- bi
+ [ definitions>> [ keys forget-all ] each ] bi
]
[ source-files get delete-at ]
bi ;
SYMBOL: file
-TUPLE: source-file-error error file ;
-
-: <source-file-error> ( msg -- error )
+: wrap-source-file-error ( error -- * )
+ file get rollback-source-file
\ source-file-error new
- file get >>file
- swap >>error ;
+ f >>line#
+ file get path>> >>file
+ swap >>error rethrow ;
: with-source-file ( name quot -- )
#! Should be called from inside with-compilation-unit.
[
- swap source-file
- dup file set
- definitions>> old-definitions set
[
- file get rollback-source-file
- <source-file-error> rethrow
- ] recover
+ source-file
+ [ file set ]
+ [ definitions>> old-definitions set ] bi
+ ] dip
+ [ wrap-source-file-error ] recover
] with-scope ; inline
USING: namespaces make sequences io io.files io.pathnames kernel
assocs words vocabs definitions parser continuations hashtables
sorting source-files arrays combinators strings system
-math.parser compiler.errors splitting init accessors sets ;
+math.parser splitting init accessors sets ;
IN: vocabs.loader
SYMBOL: vocab-roots
PRIVATE>
: require ( vocab -- )
- [ load-vocab drop ] with-compiler-errors ;
+ load-vocab drop ;
: reload ( name -- )
dup vocab
- [ [ [ load-source ] [ load-docs ] bi ] with-compiler-errors ]
+ [ [ load-source ] [ load-docs ] bi ]
[ require ]
?if ;
[
dup vocab-name blacklist get at* [ rethrow ] [
drop dup find-vocab-root
- [ [ (load-vocab) ] with-compiler-errors ]
- [ dup vocab [ ] [ no-vocab ] ?if ]
- if
+ [ (load-vocab) ] [ dup vocab [ ] [ no-vocab ] ?if ] if
] if
] load-vocab-hook set-global
--- /dev/null
+USING: help.markup help.syntax words.constant ;
+IN: words.constant
+
+ARTICLE: "words.constant" "Constants"
+"There is a syntax for defining words which push literals on the stack."
+$nl
+"Define a new word that pushes a literal on the stack:"
+{ $subsection POSTPONE: CONSTANT: }
+"Define an constant at run-time:"
+{ $subsection define-constant } ;
+
+ABOUT: "words.constant"
{ $subsection define }
{ $subsection define-declared }
{ $subsection define-inline }
-"Word definitions should declare their stack effect, unless the definition is completely trivial. See " { $link "effect-declaration" } "."
+"Word definitions must declare their stack effect. See " { $link "effect-declaration" } "."
$nl
"All other types of word definitions, such as " { $link "words.symbol" } " and " { $link "generic" } ", are just special cases of the above." ;
{ $subsection "colon-definition" }
{ $subsection "words.symbol" }
{ $subsection "words.alias" }
+{ $subsection "words.constant" }
{ $subsection "primitives" }
{ $subsection "deferred" }
{ $subsection "declarations" }
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
\r
! namespace utilities\r
- \r
-: make* ( seq -- seq ) [ dup quotation? [ call ] [ ] if ] map ;\r
\r
: closed-quot ( quot -- quot )\r
namestack swap '[ namestack [ _ set-namestack @ ] dip set-namestack ] ;\r
3 model-projection <model> view4> (>>model) ;\r
\r
: camera-action ( quot -- quot ) \r
- [ drop [ ] observer3d> \r
+ '[ drop _ observer3d> \r
with-self update-observer-projections ] \r
- make* closed-quot ;\r
+ closed-quot ;\r
\r
: win3D ( text gadget -- ) \r
"navigateur 4D : " rot append open-window ;\r
\r
: add-keyboard-delegate ( obj -- obj )\r
<handler>\r
-{\r
+H{\r
{ T{ key-down f f "LEFT" } \r
[ [ rotation-step turn-left ] camera-action ] }\r
{ T{ key-down f f "RIGHT" } \r
{ T{ key-down f f "3" } [ mvt-3D-3 camera-action ] }\r
{ T{ key-down f f "4" } [ mvt-3D-4 camera-action ] }\r
\r
- } [ make* ] map >hashtable >>table\r
+ } >>table\r
; \r
\r
! --------------------------------------------\r
: init-filelist-model ( file-chooser -- file-chooser )\r
dup list-of-files <model> >>model ; \r
\r
-: (fc-go) ( file-chooser quot -- )\r
+: (fc-go) ( file-chooser button quot -- )\r
[ [ file-chooser? ] find-parent dup path>> ] dip\r
call\r
normalize-path swap set-model\r
update-filelist-model\r
- drop ;\r
+ drop ; inline\r
\r
-: fc-go-parent ( file-chooser -- )\r
+: fc-go-parent ( file-chooser button -- )\r
[ dup value>> parent-directory ] (fc-go) ;\r
\r
-: fc-go-home ( file-chooser -- )\r
+: fc-go-home ( file-chooser button -- )\r
[ home ] (fc-go) ;\r
\r
: fc-change-directory ( file-chooser file -- )\r
USING: accessors arrays classes.tuple combinators continuations io
kernel lexer math prettyprint quotations sequences source-files
-strings words ;
+source-files.errors strings words ;
IN: fuel.pprint
-! Copyright (C) 2007 Doug Coleman.
+! Copyright (C) 2007, 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors images images.loader io.pathnames kernel namespaces
opengl opengl.gl opengl.textures sequences strings ui ui.gadgets
GENERIC: image. ( object -- )
-: default-image. ( path -- )
- <image-gadget> gadget. ;
+M: string image. ( image -- ) load-image image. ;
-M: string image. ( image -- ) load-image default-image. ;
+M: pathname image. ( image -- ) load-image image. ;
-M: pathname image. ( image -- ) load-image default-image. ;
-
-M: image image. ( image -- ) default-image. ;
+M: image image. ( image -- ) <image-gadget> gadget. ;
M: ast-op infix-codegen
[ left>> infix-codegen ] [ right>> infix-codegen ]
[ op>> select-op ] tri
- 2over [ number? ] both? [ call ] [
+ 2over [ number? ] both? [ call( a b -- c ) ] [
[ [ prepare-operand ] bi@ ] dip '[ @ @ @ ]
] if ;
! Server message handling
-GENERIC: forward-message ( irc-message -- )
-M: irc-message forward-message +server-chat+ chat-put ;
-M: to-one-chat forward-message dup chat> chat-put ;
-M: to-all-chats forward-message chats> chat-put ;
-M: to-many-chats forward-message dup sender>> participant-chats chat-put ;
+GENERIC: message-forwards ( irc-message -- seq )
+M: irc-message message-forwards drop +server-chat+ ;
+M: to-one-chat message-forwards chat> ;
+M: to-all-chats message-forwards drop chats> ;
+M: to-many-chats message-forwards sender>> participant-chats ;
GENERIC: process-message ( irc-message -- )
M: object process-message drop ;
: handle-reader-message ( irc-message -- ) irc> in-messages>> mailbox-put ;
: (handle-disconnect) ( -- )
- irc> in-messages>> irc-disconnected swap mailbox-put
+ irc-disconnected irc> in-messages>> mailbox-put
irc> reconnect-time>> sleep
(connect-irc)
(do-login) ;
! Processing loops
: in-multiplexer-loop ( -- ? )
- irc> in-messages>> mailbox-get
- [ process-message ] [ forward-message ] [ irc-end? not ] tri ;
+ irc> in-messages>> mailbox-get {
+ [ message-forwards ]
+ [ process-message ]
+ [ swap chat-put ]
+ [ irc-end? not ]
+ } cleave ;
: strings>privmsg ( name string -- privmsg )
" :" prepend append "PRIVMSG " prepend string>irc-message ;
--- /dev/null
+Bruno Deferrari
--- /dev/null
+Bruno Deferrari
--- /dev/null
+! Copyright (C) 2009 Bruno Deferrari.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors irc.messages irc.messages.base kernel make ;
+EXCLUDE: sequences => join ;
+IN: irc.logbot.log-line
+
+: dot-or-parens ( string -- string )
+ [ "." ] [ " (" prepend ")." append ] if-empty ;
+
+GENERIC: >log-line ( object -- line )
+
+M: irc-message >log-line line>> ;
+
+M: privmsg >log-line
+ [ "<" % dup sender>> % "> " % text>> % ] "" make ;
+
+M: join >log-line
+ [ "* " % sender>> % " has joined the channel." % ] "" make ;
+
+M: part >log-line
+ [ "* " % dup sender>> % " has left the channel" %
+ comment>> dot-or-parens % ] "" make ;
+
+M: quit >log-line
+ [ "* " % dup sender>> % " has quit" %
+ comment>> dot-or-parens % ] "" make ;
+
+M: kick >log-line
+ [ "* " % dup sender>> % " has kicked " % dup user>> %
+ " from the channel" % comment>> dot-or-parens % ] "" make ;
+
+M: participant-mode >log-line
+ [ "* " % dup sender>> % " has set mode " % dup mode>> %
+ " to " % parameter>> % ] "" make ;
+
+M: nick >log-line
+ [ "* " % dup sender>> % " is now known as " % nickname>> % ] "" make ;
--- /dev/null
+IRC message formatting for logs
--- /dev/null
+! Copyright (C) 2009 Bruno Deferrari.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors calendar calendar.format destructors fry io io.encodings.8-bit
+io.files io.pathnames irc.client irc.client.chats irc.messages
+irc.messages.base kernel make namespaces sequences threads
+irc.logbot.log-line ;
+IN: irc.logbot
+
+CONSTANT: bot-channel "#concatenative"
+CONSTANT: log-directory "/tmp/logs"
+
+SYMBOL: current-day
+SYMBOL: current-stream
+
+: bot-profile ( -- obj )
+ "irc.freenode.org" 6667 "flogger" f <irc-profile> ;
+
+: add-timestamp ( string timestamp -- string )
+ timestamp>hms "[" prepend "] " append prepend ;
+
+: timestamp-path ( timestamp -- path )
+ timestamp>ymd ".log" append log-directory prepend-path ;
+
+: timestamp>stream ( timestamp -- stream )
+ dup day-of-year current-day get = [
+ drop
+ ] [
+ current-stream get [ dispose ] when*
+ [ day-of-year current-day set ]
+ [ timestamp-path latin1 <file-writer> ] bi
+ current-stream set
+ ] if current-stream get ;
+
+: log-message ( string timestamp -- )
+ [ add-timestamp ] [ timestamp>stream ] bi
+ [ stream-print ] [ stream-flush ] bi ;
+
+GENERIC: handle-message ( msg -- )
+
+M: object handle-message drop ;
+M: irc-message handle-message [ >log-line ] [ timestamp>> ] bi log-message ;
+
+: bot-loop ( chat -- ) dup hear handle-message bot-loop ;
+
+: start-bot ( -- )
+ bot-profile <irc-client>
+ [ connect-irc ]
+ [
+ [ bot-channel <irc-channel-chat> ] dip
+ '[ _ [ _ attach-chat ] [ bot-loop ] bi ]
+ "LogBot" spawn drop
+ ] bi ;
+
+: logbot ( -- ) start-bot ;
+
+MAIN: logbot
--- /dev/null
+An IRC logging bot
{ command "NICK" }
{ parameters { } }
{ trailing "someuser2" }
- { sender "someuser" } } }
+ { sender "someuser" }
+ { nickname "someuser2" } } }
[ ":someuser!n=user@some.where NICK :someuser2"
string>irc-message f >>timestamp ] unit-test
! connection
IRC: pass "PASS" password ;
-IRC: nick "NICK" nickname ;
+IRC: nick "NICK" : nickname ;
IRC: user "USER" user mode _ : realname ;
IRC: oper "OPER" name password ;
IRC: mode "MODE" name mode parameter ;
swap [
" " [ drop ] <border-button>
swap [ first >>loc ] [ second >>dim ] bi
- ] [ execute ] bi*
+ ] [ execute( -- value ) ] bi*
] dip set-nth ;
: add-keys-gadgets ( gadget -- gadget )
swap call [ at 0 or ] curry map ; inline
: op-matrix ( domain range quot -- matrix )
- rot [ [ 2dup ] dip (op-matrix) ] map 2nip ; inline
+ rot [ (op-matrix) ] with with map ; inline
: d-matrix ( domain range -- matrix )
[ (d) ] op-matrix ;
CONSTANT: help-lint-vocabs-file "help-lint-vocabs"
CONSTANT: help-lint-errors-file "help-lint-errors"
+CONSTANT: compiler-errors-file "compiler-errors"
+CONSTANT: compiler-error-messages-file "compiler-error-messages"
+
CONSTANT: boot-time-file "boot-time"
CONSTANT: load-time-file "load-time"
-CONSTANT: compiler-errors-file "compiler-errors"
CONSTANT: test-time-file "test-time"
CONSTANT: help-lint-time-file "help-lint-time"
CONSTANT: benchmark-time-file "benchmark-time"
compiler.errors generic help.html help.lint io.directories
io.encodings.utf8 io.files kernel mason.common math namespaces
prettyprint sequences sets sorting tools.test tools.time
-tools.vocabs words system io ;
+tools.vocabs words system io tools.errors locals ;
IN: mason.test
: do-load ( -- )
M: method-body word-vocabulary "method-generic" word-prop word-vocabulary ;
+:: do-step ( errors summary-file details-file -- )
+ errors [ file>> ] map prune natural-sort summary-file to-file
+ errors details-file utf8 [ errors. ] with-file-writer ;
+
: do-compile-errors ( -- )
- compiler-errors-file utf8 [
- +error+ errors-of-type keys
- [ word-vocabulary ] map
- prune natural-sort .
- ] with-file-writer ;
+ compiler-errors get values
+ compiler-error-messages-file
+ compiler-errors-file
+ do-step ;
: do-tests ( -- )
- run-all-tests
- [ keys test-all-vocabs-file to-file ]
- [ test-all-errors-file utf8 [ test-failures. ] with-file-writer ]
- bi ;
+ test-all test-failures get
+ test-all-vocabs-file
+ test-all-errors-file
+ do-step ;
: do-help-lint ( -- )
- "" run-help-lint
- [ keys help-lint-vocabs-file to-file ]
- [ help-lint-errors-file utf8 [ typos. ] with-file-writer ]
- bi ;
+ help-lint-all lint-failures get values
+ help-lint-vocabs-file
+ help-lint-errors-file
+ do-step ;
: do-benchmarks ( -- )
run-benchmarks benchmarks-file to-file ;
[ dup zip ] dip binpack [ keys ] map ;
: binpack! ( items quot n -- bins )
- [ dupd map zip ] dip binpack [ keys ] map ;
+ [ dupd map zip ] dip binpack [ keys ] map ; inline
over empty? [
2drop nil
] [
- quot>> [ unclip-slice dup ] dip call
+ quot>> [ unclip-slice dup ] dip call( char -- ? )
[ swap <parse-results> ] [ 2drop nil ] if
] if ;
USING: kernel continuations arrays sequences quotations ;
: breset ( quot -- )
- [ 1array swap keep first continue-with ] callcc1 nip ;
+ [ 1array swap keep first continue-with ] callcc1 nip ; inline
: (bshift) ( v r k -- obj )
[ dup first -rot ] dip
: parse* ( parser -- ast )
compile
- [ execute [ error-stack get first throw ] unless* ] with-global-lexer
+ [ execute( -- result ) [ error-stack get first throw ] unless* ] with-global-lexer
ast>> ;
: create-bnf ( name parser -- )
: euler011 ( -- answer )
[
{ [ horizontal ] [ vertical ] [ diagonal/ ] [ diagonal\ ] }
- [ call 4 max-product , ] each
+ [ call( -- matrix ) 4 max-product , ] each
] { } make supremum ;
! [ euler011 ] 100 ave-time
[ ]
if ;
-METHOD: expand { factor-expr } expr>> eval unparse ;
+METHOD: expand { factor-expr } expr>> eval>string ;
DEFER: expansion
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: run-sword ( basic-expr -- )
- command>> expansion unclip "shell" lookup execute ;
+ command>> expansion unclip "shell" lookup execute( arguments -- ) ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: invoke-value-action ( list -- )
dup list-empty? [
- dup hook>> call
+ dup hook>> call( list -- )
] [
[ index>> ] keep nth-gadget invoke-secondary
] if ;
dup class
{
{ \ string [ ] }
- { \ quotation [ call ] }
- { \ word [ execute ] }
+ { \ quotation [ call( -- string ) ] }
+ { \ word [ execute( -- string ) ] }
{ \ fixnum [ number>string ] }
{ \ array [ to-strings concat ] }
}
main-responder set-global
M: site-watcher-app init-user-profile
- drop B
- "username" value "email" value <account> insert-tuple ;
+ drop "username" value "email" value <account> insert-tuple ;
: init-db ( -- )
site-watcher-db [
{ site-watcher-app "spider-list" } >>template
[
! Silly query
- username B spidering-sites [ site>> ] map
+ username spidering-sites [ site>> ] map
"sites" set-value
] >>init
<protected>
swap [ * - ] keep 2array ;
: change-global ( variable quot -- )
- global swap change-at ;
+ global swap change-at ; inline
: (correct-for-timing-overhead) ( timingshash -- timingshash )
time-dummy-word [ subtract-overhead ] curry assoc-map ;
correct-for-timing-overhead
"total time:" write
] dip pprint nl
- print-word-timings nl ;
+ print-word-timings nl ; inline
: profile-vocab ( vocab quot -- )
"annotating vocab..." print flush
correct-for-timing-overhead
"total time:" write
] dip pprint
- print-word-timings ;
+ print-word-timings ; inline
(declaration keyword "declaration words")
(ebnf-form constant "EBNF: ... ;EBNF form")
(parsing-word keyword "parsing words")
+ (postpone-body comment "postponed form")
(setter-word function-name "setter words (>>foo)")
(getter-word function-name "getter words (foo>>)")
(stack-effect comment "stack effect specifications")
(defun fuel-font-lock--syntactic-face (state)
(if (nth 3 state) 'factor-font-lock-string
(let ((c (char-after (nth 8 state))))
- (cond ((or (char-equal c ?\ )
- (char-equal c ?\n)
- (char-equal c ?E))
+ (cond ((memq c '(?\ ?\n ?E ?P))
(save-excursion
(goto-char (nth 8 state))
(beginning-of-line)
- (cond ((looking-at-p "USING: ")
+ (cond ((looking-at "E") 'factor-font-lock-ebnf-form)
+ ((looking-at "P") 'factor-font-lock-postpone-body)
+ ((looking-at-p "USING: ")
'factor-font-lock-vocabulary-name)
- ((looking-at-p "\\(TUPLE\\|SYMBOLS\\|VARS\\|SINGLETONS\\):")
+ ((looking-at-p
+ "\\(TUPLE\\|SYMBOLS\\|VARS\\|SINGLETONS\\):")
'factor-font-lock-symbol)
((looking-at-p "C-ENUM:\\( \\|\n\\)")
'factor-font-lock-constant)
- ((looking-at-p "E")
- 'factor-font-lock-ebnf-form)
(t 'default))))
((or (char-equal c ?U) (char-equal c ?C))
'factor-font-lock-parsing-word)
(,fuel-syntax--alien-function-regex (1 'factor-font-lock-type-name)
(2 'factor-font-lock-word))
(,fuel-syntax--vocab-ref-regexp 2 'factor-font-lock-vocabulary-name)
- (,fuel-syntax--constructor-decl-regex (1 'factor-font-lock-word)
- (2 'factor-font-lock-type-name)
- (3 'factor-font-lock-invalid-syntax nil t))
+ (,fuel-syntax--constructor-decl-regex
+ (1 'factor-font-lock-word)
+ (2 'factor-font-lock-type-name)
+ (3 'factor-font-lock-invalid-syntax nil t))
(,fuel-syntax--typedef-regex (1 'factor-font-lock-type-name)
(2 'factor-font-lock-type-name)
(3 'factor-font-lock-invalid-syntax nil t))
;; Strings and chars
("CHAR: \\(\"\\) [^\\\"]*?\\(\"\\)\\([^\\\"]\\|\\\\.\\)*?\\(\"\\)"
(1 "w") (2 "\"") (4 "\""))
- ("\\(CHAR:\\|POSTPONE:\\|\\\\\\) \\(.\\)\\( \\|$\\)" (2 "w"))
+ ("\\(CHAR:\\|\\\\\\) \\(.\\)\\( \\|$\\)" (2 "w"))
("\\( \\|^\\)\\(DLL\\|P\\|SBUF\\)\\(\"\\)\\([^\n\r\f\\\"]\\|\\\\.\\)*?\\(\"\\)"
(3 "\"") (5 "\""))
("\\_<\\(\"\\)\\([^\n\r\f\\\"]\\|\\\\.\\)*?\\(\"\\)" (1 "\"") (3 "\""))
("\\_<<\\(\"\\)\\_>" (1 "<b"))
("\\_<\\(\"\\)>\\_>" (1 ">b"))
+ ;; postpone
+ ("\\_<POSTPONE:\\( \\).*\\(\n\\)" (1 "<b") (2 ">b"))
;; Multiline constructs
("\\_<\\(E\\)BNF:\\( \\|\n\\)" (1 "<b"))
("\\_<;EBN\\(F\\)\\_>" (1 ">b"))
projects / factor.git / commitdiff