1 ! :folding=indent:collapseFolds=1:
5 ! Copyright (C) 2003, 2004 Slava Pestov.
7 ! Redistribution and use in source and binary forms, with or without
8 ! modification, are permitted provided that the following conditions are met:
10 ! 1. Redistributions of source code must retain the above copyright notice,
11 ! this list of conditions and the following disclaimer.
13 ! 2. Redistributions in binary form must reproduce the above copyright notice,
14 ! this list of conditions and the following disclaimer in the documentation
15 ! and/or other materials provided with the distribution.
17 ! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
18 ! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
19 ! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
20 ! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
21 ! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
22 ! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
23 ! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
24 ! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
25 ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
26 ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
42 : <attribute-set> ( -- attribute-set )
43 [ ] "javax.swing.text.SimpleAttributeSet" jnew ;
45 : attribute+ ( attribute-set value key -- )
47 [ "java.lang.Object" "java.lang.Object" ]
48 "javax.swing.text.SimpleAttributeSet"
49 "addAttribute" jinvoke ;
51 : style-constant ( name -- key )
52 #! javax.swing.text.StyleConstants contains static variables
53 #! which key in an AttributeSet.
54 "javax.swing.text.StyleConstants" swap jvar-static-get
57 : swing-attribute+ ( attribute-set value key -- )
58 style-constant attribute+ ;
60 : >color ( triplet -- hex )
61 uncons uncons uncons drop
66 : link-key ( -- attr )
67 "factor.listener.FactorListener" "Link" jvar-static-get
70 : obj>listener-link ( obj -- link )
71 #! Listener links are quotations.
74 unparse " describe-object-path" cat2
77 : link-attribute ( attribute-set target -- )
78 [ dup t "Underline" swing-attribute+ ] dip
79 obj>listener-link link-key attribute+ ;
81 : style>attribute-set ( -- attribute-set )
83 "link" get [ dupd link-attribute ] when*
84 "bold" get [ dup t "Bold" swing-attribute+ ] when
85 "italics" get [ dup t "Italic" swing-attribute+ ] when
86 "underline" get [ dup t "Underline" swing-attribute+ ] when
87 "fg" get [ dupd >color "Foreground" swing-attribute+ ] when*
88 "bg" get [ dupd >color "Background" swing-attribute+ ] when*
89 "font" get [ dupd "FontFamily" swing-attribute+ ] when*
90 "size" get [ dupd "FontSize" swing-attribute+ ] when* ;
93 default-style [ style>attribute-set ] bind t
95 [ "javax.swing.text.AttributeSet" "boolean" ]
96 "javax.swing.JTextPane"
97 "setCharacterAttributes"
100 : listener-readln* ( continuation -- )
103 "factor.listener.FactorListener"
106 : listener-readln ( -- line )
107 reset-attrs [ listener-readln* suspend ] callcc1 ;
109 : listener-write-attr ( string -- )
110 style>attribute-set "listener" get
111 [ "java.lang.String" "javax.swing.text.AttributeSet" ]
112 "factor.listener.FactorListener"
116 : listener-write ( string -- )
117 default-style [ listener-write-attr ] bind ;
119 !: listener-edit ( string -- )
121 ! [ "java.lang.String" ]
122 ! "factor.listener.FactorListener"
123 ! "editLine" jinvoke ;
125 : <listener-stream> ( listener -- stream )
126 #! Creates a stream for reading/writing to the given
127 #! listener instance.
131 [ listener-readln ] "freadln" set
133 [ listener-write ] "fwrite" set
135 [ listener-write-attr ] "fwrite-attr" set
137 ![ listener-edit ] "fedit" set
143 [ this fwrite "\n" this fwrite ] "fprint" set
146 : close-listener ( listener -- )
147 #! Closes the listener. If no more listeners remain, the
150 [ "factor.listener.FactorListener" ]
151 "factor.listener.FactorDesktop" "closeListener"
154 : new-listener-hook ( listener -- )
155 #! Called when user opens a new listener in the desktop.
158 <listener-stream> "stdio" set
160 "listener" get close-listener
163 : new-listener ( -- )
164 #! Opens a new listener.
166 [ ] "factor.listener.FactorDesktop" "newListener"
169 : running-desktop? ( -- )
170 this "factor.listener.FactorDesktop" is ;