1/*  Part of XPCE --- The SWI-Prolog GUI toolkit
2
3    Author:        Jan Wielemaker and Anjo Anjewierden
4    E-mail:        jan@swi.psy.uva.nl
5    WWW:           http://www.swi.psy.uva.nl/projects/xpce/
6    Copyright (c)  1985-2002, University of Amsterdam
7    All rights reserved.
8
9    Redistribution and use in source and binary forms, with or without
10    modification, are permitted provided that the following conditions
11    are met:
12
13    1. Redistributions of source code must retain the above copyright
14       notice, this list of conditions and the following disclaimer.
15
16    2. Redistributions in binary form must reproduce the above copyright
17       notice, this list of conditions and the following disclaimer in
18       the documentation and/or other materials provided with the
19       distribution.
20
21    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
22    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
23    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
24    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
25    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
26    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
27    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
28    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
29    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
30    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
31    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
32    POSSIBILITY OF SUCH DAMAGE.
33*/
34
35:- module(emacs_annotate_mode, []).
36:- use_module(library(pce)).
37
38
39                 /*******************************
40                 *          THE BUFFER          *
41                 *******************************/
42
43:- pce_begin_class(emacs_annotate_buffer, emacs_buffer,
44                   "Emacs Buffer with associated styles").
45
46variable(font,          [font]  := @default, get, "Main Font").
47variable(styles,        [sheet] := @default, get, "Sheet with styles").
48variable(margin_width,  int := 75,           get, "Width of annotate margin").
49
50attach(B, Editor:editor) :->
51    "Load <-font and <-styles"::
52    send(B, send_super, attach, Editor),
53    get(B, font, Font),
54    get(B, styles, Styles),
55%   get(B, margin_width, Width),            % See ->setup_mode
56    (   Font \== @default
57    ->  send(Editor, font, Font)
58    ;   send(B, slot, font, Editor?font)
59    ),
60    (   Styles \== @default
61    ->  send(Editor, styles, Styles)
62    ;   send(B, slot, styles, Editor?styles)
63    ),
64%   send(Editor, margin_width, Width).
65    true.
66
67detach(B, Editor:editor) :->
68    "Save <-font and <-styles"::
69    send(B, send_super, detach, Editor),
70    get(Editor, font, Font),
71    get(Editor, styles, Styles),
72    get(Editor, margin_width, Width),
73    send(B, slot, font, Font),
74    send(B, slot, styles, Styles),
75    send(B, slot, margin_width, Width).
76
77
78loaded(B) :->
79    "Called after it has been reloaded (register style-names)"::
80    get(B, styles, Styles),
81    (   Styles \== @default
82    ->  annotate_style_name_type(Type),
83        send(Styles, for_all, message(Type?context, add, @arg1?name))
84    ;   true
85    ).
86
87
88do_save(B, File:file) :->
89    "Do the actual saving (as an XPCE object)"::
90    send(B, save_in_file, File),
91    send(B, check_point_undo),
92    send(B, modified, @off).
93
94:- pce_end_class.
95
96
97                 /*******************************
98                 *         EDITING MODE         *
99                 *******************************/
100
101:- pce_autoload(style_item, library(pce_style_item)).
102
103:- initialization
104    new(KB, emacs_key_binding(emacs_annotate, emacs_text)),
105    send(KB, function, '\\C-c\\C-d', define_style).
106
107:- initialization
108    new(_, syntax_table(annotate)).
109
110:- initialization
111    new(MM, emacs_mode_menu(annotate, text)),
112
113    send(MM, append, annotate, define_style),
114    send(MM, append, annotate,
115         emacs_argument_item(make_fragment, @emacs_mode?style_names)),
116    send(MM, append, annotate, delete_fragment),
117    send(MM, append, annotate, margin_width).
118
119
120annotate_style_name_type(Type) :-
121    get(@types, member, annotate_style_name, Type),
122    !.
123annotate_style_name_type(Type) :-
124    new(Type, type(annotate_style_name, name_of, new(chain))).
125
126:- initialization
127    annotate_style_name_type(_).
128
129
130:- pce_begin_class(emacs_annotate_mode, emacs_text_mode).
131
132setup_mode(E) :->
133    "little hack ..."::
134    send(E, margin_width, E?text_buffer?margin_width).
135
136
137style_names(E, Names:chain) :<-
138    "Return a list of associated styles"::
139    get(E?styles?members, map, @arg1?name, Names),
140    send(Names, sort).
141
142:- pce_global(@emacs_annotate_margin_recogniser,
143              make_emacs_annotate_margin_recogniser).
144
145make_emacs_annotate_margin_recogniser(R) :-
146    new(Editor, @receiver?device),
147    new(Fragment, ?(@receiver, fragment, @event)),
148    new(Mode, Editor?mode),
149
150    new(S1, click_gesture(left, '', single,
151                          or(message(Mode, selected_fragment,
152                                     Fragment),
153                             message(Mode, selected_fragment, @nil)))),
154    new(O1, click_gesture(left, '', double,
155                          message(Mode, open_fragment, Fragment))),
156
157    new(R, handler_group(S1, O1)).
158
159
160margin_width(E, Width:int) :->
161    "Set margin and attach event-handling"::
162    send(E?editor, margin_width, Width),
163    (   Width \== 0
164    ->  send(E?margin, recogniser, @emacs_annotate_margin_recogniser)
165    ;   true
166    ).
167
168
169define_style(E, Name:'annotate_style_name|name') :->
170    "Define a (new) fragment style"::
171    (   get(E?styles, value, Name, Style)
172    ->  true
173    ;   new(Style, style)
174    ),
175    new(D, dialog('Define Fragment Style')),
176    send(D, append, new(NI, text_item(name, Name))),
177    send(D, append, new(SI, style_item(style, Style))),
178    send(SI, pen, 1),
179    send(SI, border, 5),
180    send(SI, radius, 7),
181    send(D, append,
182         button(ok, message(D, return,
183                            create(tuple, NI?selection, SI?selection)))),
184    send(D, append,
185         button(cancel, message(D, return, @nil))),
186    send(D, default_button, ok),
187    get(D, confirm_centered, RVal),
188    send(D, destroy),
189    (   RVal \== @nil
190    ->  get(RVal, first, StyleName),
191        get(RVal, second, StyleObject),
192        send(E, style, StyleName, StyleObject),
193        annotate_style_name_type(Type),
194        send(Type?context, add, StyleName),
195        send(E, modified, @on)
196    ;   fail
197    ).
198
199
200make_fragment(E, Style:annotate_style_name) :->
201    "Create a fragment from the current selection"::
202    get(E, selection, point(Start, End)),
203    Length is End - Start,
204    get(E, text_buffer, TB),
205    new(_, fragment(TB, Start, Length, Style)),
206    send(E, modified, @on).
207
208
209fragment(E, F:fragment) :<-
210    "Find most local fragment around <-caret"::
211    get(E, caret, Caret),
212    get(E, find_all_fragments, message(@arg1, overlap, Caret), Frags),
213    send(Frags, sort, ?(@arg1?size, compare, @arg2?size)),
214    get(Frags, head, F).
215
216
217delete_fragment(E) :->
218    "Delete most smallest fragment around caret"::
219    get(E, fragment, F),
220    send(F, free),
221    send(E, modified, @on).
222
223
224selected_fragment(E, F:fragment*) :->
225    "Make argument the current fragment"::
226    send(E?editor, selected_fragment, F),
227    (   F \== @nil
228    ->  send(E, report, status, '"%s" fragment', F?style)
229    ;   send(E, report, status, '')
230    ).
231
232
233open_fragment(_E, _F:fragment) :->
234    "To be implemented"::
235    true.
236
237
238:- pce_end_class.
239
240