diff --git a/library/bootstrap/boot-stage1.factor b/library/bootstrap/boot-stage1.factor index 98d4d6eabe..4e66a55ae3 100644 --- a/library/bootstrap/boot-stage1.factor +++ b/library/bootstrap/boot-stage1.factor @@ -192,6 +192,7 @@ vectors words ; "/library/ui/ui.factor" "/library/help/database.factor" + "/library/help/stylesheet.factor" "/library/help/markup.factor" "/library/help/help.factor" "/library/help/tutorial.factor" diff --git a/library/help/database.factor b/library/help/database.factor index 70c68c53e6..7f671aaf1b 100644 --- a/library/help/database.factor +++ b/library/help/database.factor @@ -5,34 +5,8 @@ USING: arrays hashtables io kernel namespaces parser sequences strings styles words ; ! Markup -SYMBOL: style-stack - GENERIC: print-element -: with-style ( style quot -- ) - swap style-stack get push call style-stack get pop* ; inline - -: current-style ( -- style ) - H{ } clone style-stack get [ dupd hash-update ] each ; - -PREDICATE: array simple-element - dup empty? [ drop t ] [ first word? not ] if ; - -M: string print-element current-style format ; - -M: simple-element print-element [ print-element ] each ; - -M: array print-element - dup first >r 1 swap tail r> execute ; - -: default-style H{ { font "Sans Serif" } { font-size 14 } } ; - -: with-markup ( quot -- ) - [ - default-style V{ } clone [ push ] keep style-stack set - call - ] with-scope ; inline - ! Help articles SYMBOL: articles diff --git a/library/help/help.factor b/library/help/help.factor index 2852af57ee..ab13ab686d 100644 --- a/library/help/help.factor +++ b/library/help/help.factor @@ -3,16 +3,16 @@ USING: arrays gadgets-presentations hashtables io kernel namespaces parser sequences words ; : help ( topic -- ) - [ - dup article-title $heading terpri terpri - article-content print-element terpri - ] with-markup ; + default-style [ + dup article-title $heading + article-content print-element + ] with-style ; : glossary ( name -- ) help ; "Show word documentation" [ word? ] [ help ] define-command -"Show term definition" [ term? ] [ help ] define-command -"Show article" [ link? ] [ help ] define-command +"Show term definition" [ term? ] [ help ] define-default-command +"Show article" [ link? ] [ help ] define-default-command H{ } clone articles global set-hash H{ } clone terms global set-hash diff --git a/library/help/markup.factor b/library/help/markup.factor index 1e2e784d4d..654006e2b7 100644 --- a/library/help/markup.factor +++ b/library/help/markup.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: help -USING: gadgets gadgets-panes gadgets-presentations hashtables io -kernel lists namespaces prettyprint sequences styles ; +USING: arrays gadgets gadgets-panes gadgets-presentations +hashtables words io kernel lists namespaces prettyprint +sequences strings styles ; ! Simple markup language. @@ -12,27 +13,51 @@ kernel lists namespaces prettyprint sequences styles ; ! Element types are words whose name begins with $. -: ($span) ( content style -- ) - [ print-element ] with-style ; inline +PREDICATE: array simple-element + dup empty? [ drop t ] [ first word? not ] if ; -: ($block) ( content style quot -- ) - >r [ [ print-element ] make-pane ] with-style - dup r> call gadget. ; inline +M: string print-element format* ; + +M: array print-element + dup first >r 1 swap tail r> execute ; + +: ($span) ( content style -- ) + [ print-element ] with-style ; + +: ($block) ( content style -- ) + terpri dup [ + [ print-element terpri ] with-style + ] with-nesting terpri ; : $see ( content -- ) first see ; ! Some spans -: $heading H{ { font "Serif" } { font-size 24 } } ($span) ; -: $subheading H{ { font "Serif" } { font-size 18 } } ($span) ; +: $heading heading-style ($block) ; -: $parameter H{ { font "Monospaced" } { font-size 12 } } ($span) ; +: $subheading subheading-style ($block) ; + +: $parameter parameter-style ($span) ; ! Some blocks -: $code - H{ { font "Monospaced" } { font-size 12 } } - [ T{ solid f { 0.9 0.9 0.9 1 } } swap set-gadget-interior ] - ($block) ; +: wrap-string ( string -- ) + " " split [ + dup empty? [ dup format* bl ] unless drop + ] each ; + +: ($paragraph) ( element style -- ) + dup [ + [ + [ + dup string? + [ wrap-string ] [ print-element bl ] if + ] each + ] with-style + ] with-nesting terpri ; + +M: simple-element print-element paragraph-style ($paragraph) ; + +: $code code-style ($block) ; ! Some links TUPLE: link name ; @@ -43,16 +68,14 @@ M: link article-content link-name article-content ; DEFER: help +: ($link) dup article-title swap ; + : $subsection ( object -- ) - first [ - dup presented set - dup [ link-name help ] curry outline set - ] make-hash [ article-title $subheading ] with-style terpri ; + subheading-style [ + first ($link) dup [ link-name help ] curry + simple-outliner + ] with-style ; -: $link ( name -- ) - first dup presented associate - [ article-title print-element ] with-style ; +: $link ( article -- ) first ($link) simple-object ; -: $glossary ( element -- ) - first dup presented associate - [ print-element ] with-style ; +: $glossary ( element -- ) first ($link) simple-object ; diff --git a/library/help/stylesheet.factor b/library/help/stylesheet.factor new file mode 100644 index 0000000000..3f333b53fb --- /dev/null +++ b/library/help/stylesheet.factor @@ -0,0 +1,26 @@ +IN: help +USING: styles ; + +: default-style H{ { font "Sans Serif" } { font-size 14 } } ; + +: heading-style H{ { font "Serif" } { font-size 24 } } ; + +: subheading-style H{ { font "Serif" } { font-size 18 } } ; + +: parameter-style H{ { font "Monospaced" } { font-size 12 } } ; + +: paragraph-style + H{ + { font "Sans Serif" } + { font-size 14 } + { wrap-margin 300 } + } ; + +: code-style + H{ + { font "Monospaced" } + { font-size 12 } + { page-color { 0.9 0.9 0.9 1 } } + { border-color { 0.95 0.95 0.95 1 } } + { border-width 5 } + } ; diff --git a/library/io/duplex-stream.factor b/library/io/duplex-stream.factor index 17a4834201..8ed82f7c7a 100644 --- a/library/io/duplex-stream.factor +++ b/library/io/duplex-stream.factor @@ -22,8 +22,8 @@ M: duplex-stream stream-write1 M: duplex-stream stream-write duplex-stream-out stream-write ; -M: duplex-stream stream-break - duplex-stream-out stream-break ; +M: duplex-stream stream-bl + duplex-stream-out stream-bl ; M: duplex-stream stream-terpri duplex-stream-out stream-terpri ; diff --git a/library/io/files.factor b/library/io/files.factor index 38c7f1d3c3..3ee896e82d 100644 --- a/library/io/files.factor +++ b/library/io/files.factor @@ -24,18 +24,18 @@ styles ; #! Open a file path relative to the Factor source code root. resource-path ; +: (file.) ( name path -- ) + file associate [ format* ] with-style ; + DEFER: directory. -: file-style ( text path -- text style ) - [ - dup directory? [ - >r "/" append r> - dup [ directory. ] curry outline set - ] when file set - ] make-hash ; +: (directory.) ( name path -- ) + dup [ directory. ] curry + [ "/" append (file.) ] write-outliner ; : file. ( dir name -- ) - tuck path+ file-style format ; + tuck path+ + dup directory? [ (directory.) ] [ (file.) terpri ] if ; : directory. ( dir -- ) - dup directory [ file. terpri ] each-with ; + dup directory [ file. ] each-with ; diff --git a/library/io/null-stream.factor b/library/io/null-stream.factor index 01b796b00b..26c4354e72 100644 --- a/library/io/null-stream.factor +++ b/library/io/null-stream.factor @@ -15,5 +15,5 @@ M: f stream-terpri drop ; M: f stream-flush drop ; M: f stream-format 3drop ; -M: f stream-break drop ; +M: f stream-bl drop ; M: f with-nested-stream rot drop with-stream* ; diff --git a/library/io/plain-stream.factor b/library/io/plain-stream.factor index 464f1d76d8..16432c624e 100644 --- a/library/io/plain-stream.factor +++ b/library/io/plain-stream.factor @@ -7,7 +7,8 @@ TUPLE: plain-writer ; C: plain-writer ( stream -- stream ) [ set-delegate ] keep ; -M: plain-writer stream-break CHAR: \s swap stream-write1 ; +M: plain-writer stream-bl CHAR: \s swap stream-write1 ; M: plain-writer stream-terpri CHAR: \n swap stream-write1 ; M: plain-writer stream-format nip stream-write ; -M: plain-writer with-nested-stream rot drop with-stream* ; +M: plain-writer with-nested-stream ( quot style stream -- ) + nip swap with-stream* ; diff --git a/library/io/stdio.factor b/library/io/stdio.factor index b6af8b1ff7..df8d6029b4 100644 --- a/library/io/stdio.factor +++ b/library/io/stdio.factor @@ -1,22 +1,23 @@ ! Copyright (C) 2003, 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: io -USING: errors hashtables generic kernel namespaces strings -styles ; +USING: errors generic hashtables kernel namespaces sequences +strings styles ; +! Default stream SYMBOL: stdio : close ( -- ) stdio get stream-close ; -: readln ( -- string/f ) stdio get stream-readln ; -: read1 ( -- char/f ) stdio get stream-read1 ; +: readln ( -- string/f ) stdio get stream-readln ; +: read1 ( -- char/f ) stdio get stream-read1 ; : read ( count -- string ) stdio get stream-read ; : write1 ( char -- ) stdio get stream-write1 ; : write ( string -- ) stdio get stream-write ; : flush ( -- ) stdio get stream-flush ; -: break ( -- ) stdio get stream-break ; +: bl ( -- ) stdio get stream-bl ; : terpri ( -- ) stdio get stream-terpri ; : format ( string style -- ) stdio get stream-format ; @@ -25,9 +26,6 @@ SYMBOL: stdio : print ( string -- ) stdio get stream-print ; -: write-outliner ( string object quot -- ) - [ outline set presented set ] make-hash format terpri ; - : with-stream ( stream quot -- ) #! Close the stream no matter what happens. [ swap stdio set [ close ] cleanup ] with-scope ; inline @@ -36,3 +34,28 @@ SYMBOL: stdio #! Close the stream if there is an error. [ swap stdio set [ close rethrow ] recover ] with-scope ; inline + +SYMBOL: style-stack + +V{ } clone style-stack global set-hash + +: with-style ( style quot -- ) + swap style-stack get push call style-stack get pop* ; inline + +: current-style ( -- style ) style-stack get hash-concat ; + +: format* ( string -- ) current-style format ; + +: write-object ( object quot -- ) + >r presented associate r> with-style ; + +: simple-object ( string object -- ) + #! Writes a clickable presentation with the specified string. + [ format* ] write-object ; + +: write-outliner ( content caption -- ) + #! Takes a pair of quotations. + >r outline associate r> with-nesting terpri ; + +: simple-outliner ( string object content -- ) + [ simple-object ] write-outliner ; diff --git a/library/io/stream.factor b/library/io/stream.factor index 51f86f52e2..45a20ca7a4 100644 --- a/library/io/stream.factor +++ b/library/io/stream.factor @@ -19,7 +19,7 @@ GENERIC: stream-write ( string stream -- ) GENERIC: stream-flush ( stream -- ) ! Extended output protocol. -GENERIC: stream-break ( stream -- ) +GENERIC: stream-bl ( stream -- ) GENERIC: stream-terpri ( stream -- ) GENERIC: stream-format ( string style stream -- ) GENERIC: with-nested-stream ( quot style stream -- ) diff --git a/library/styles.factor b/library/styles.factor index 3dae31179c..7879c3be75 100644 --- a/library/styles.factor +++ b/library/styles.factor @@ -35,6 +35,7 @@ SYMBOL: file SYMBOL: outline ! Paragraph styles +SYMBOL: page-color SYMBOL: border-color SYMBOL: border-width SYMBOL: wrap-margin diff --git a/library/tools/describe.factor b/library/tools/describe.factor index 9a600c7ece..4593ec4e58 100644 --- a/library/tools/describe.factor +++ b/library/tools/describe.factor @@ -77,32 +77,32 @@ DEFER: describe : sheet. ( sheet -- ) dup format-sheet swap peek - [ dup [ describe ] curry write-outliner ] 2each ; + [ dup [ describe ] curry simple-outliner ] 2each ; : describe ( object -- ) dup summary print sheet sheet. ; : word. ( word -- ) - dup word-name swap dup [ see ] curry write-outliner ; + dup word-name swap dup [ see ] curry simple-outliner ; -: simple-outliner ( seq quot -- | quot: obj -- ) +: sequence-outliner ( seq quot -- | quot: obj -- ) swap [ - [ unparse-short ] keep rot dupd curry write-outliner + [ unparse-short ] keep rot dupd curry simple-outliner ] each-with ; : words. ( vocab -- ) - words word-sort [ see ] simple-outliner ; + words word-sort [ see ] sequence-outliner ; : vocabs. ( -- ) #! Outlining word browser. - vocabs [ f over [ words. ] curry write-outliner ] each ; + vocabs [ words. ] sequence-outliner ; : usage. ( word -- ) #! Outlining usages browser. - usage [ usage. ] simple-outliner ; + usage [ usage. ] sequence-outliner ; : uses. ( word -- ) #! Outlining call hierarchy browser. - uses [ uses. ] simple-outliner ; + uses [ uses. ] sequence-outliner ; : stack. ( seq -- seq ) reverse-slice >array describe ; diff --git a/library/ui/commands.factor b/library/ui/commands.factor index 95e5ebdd24..a7645e6b86 100644 --- a/library/ui/commands.factor +++ b/library/ui/commands.factor @@ -10,7 +10,9 @@ TUPLE: command name pred quot default? ; V{ } clone commands global set-hash : forget-command ( name -- ) - commands [ [ command-name = not ] subset-with ] change ; + global [ + commands [ [ command-name = not ] subset-with ] change + ] bind ; : (define-command) ( name pred quot default? -- ) dup command-name forget-command commands get push ; @@ -32,7 +34,7 @@ TUPLE: command-button object ; : command-action ( command-button -- ) #! Invoke the default action. command-button-object dup applicable - [ command-default? ] find nip command>quot call ; + [ command-default? ] find-last nip command>quot call ; : ( presented command -- item ) [ command>quot [ drop ] swap append ] keep @@ -63,8 +65,6 @@ C: command-button ( gadget object -- button ) M: command-button gadget-help ( button -- string ) command-button-object dup word? [ synopsis ] [ summary ] if ; -"Use as input" [ input? ] [ input-string pane get replace-input ] define-default-command - "Describe" [ drop t ] [ describe ] define-default-command "Prettyprint" [ drop t ] [ . ] define-command "Push on data stack" [ drop t ] [ ] define-command @@ -81,3 +81,5 @@ M: command-button gadget-help ( button -- string ) "Infer stack effect" [ word? ] [ unit infer . ] define-command "Display gadget" [ [ gadget? ] is? ] [ gadget. ] define-command + +"Use as input" [ input? ] [ input-string pane get replace-input ] define-default-command diff --git a/library/ui/panes.factor b/library/ui/panes.factor index 5f51ab46e1..4f717f834b 100644 --- a/library/ui/panes.factor +++ b/library/ui/panes.factor @@ -138,7 +138,7 @@ M: pane stream-write ( string pane -- ) M: pane stream-format ( string style pane -- ) [ rot "\n" split pane-format ] keep scroll-pane ; -M: pane stream-break ( pane -- ) pane-current stream-break ; +M: pane stream-bl ( pane -- ) pane-current stream-bl ; M: pane stream-close ( pane -- ) drop ; @@ -154,4 +154,4 @@ M: pane stream-close ( pane -- ) drop ; : make-pane ( quot -- pane ) #! Execute the quotation with output to an output-only pane. - [ with-pane ] keep ; inline + [ swap with-pane ] keep ; inline diff --git a/library/ui/paragraphs.factor b/library/ui/paragraphs.factor index 06354f29f3..dd9e98f6f1 100644 --- a/library/ui/paragraphs.factor +++ b/library/ui/paragraphs.factor @@ -3,9 +3,9 @@ USING: arrays gadgets gadgets-labels generic kernel math namespaces sequences ; ! A word break gadget -TUPLE: break ; +TUPLE: word-break ; -C: break ( -- gadget ) " "