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