1/*  Part of XPCE --- The SWI-Prolog GUI toolkit
2
3    Author:        Jan Wielemaker and Anjo Anjewierden
4    E-mail:        J.Wielemaker@vu.nl
5    WWW:           http://www.swi-prolog.org/packages/xpce/
6    Copyright (c)  1997-2018, University of Amsterdam
7                              VU University Amsterdam
8    All rights reserved.
9
10    Redistribution and use in source and binary forms, with or without
11    modification, are permitted provided that the following conditions
12    are met:
13
14    1. Redistributions of source code must retain the above copyright
15       notice, this list of conditions and the following disclaimer.
16
17    2. Redistributions in binary form must reproduce the above copyright
18       notice, this list of conditions and the following disclaimer in
19       the documentation and/or other materials provided with the
20       distribution.
21
22    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
23    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
24    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
25    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
26    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
27    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
28    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
29    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
30    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
31    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
32    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
33    POSSIBILITY OF SUCH DAMAGE.
34*/
35
36:- module(pce_config,
37          [ register_config/1,          % +PredicateName
38            register_config_type/2,     % +Type, +Attributes
39                                        % fetch/set
40            get_config/2,               % +Key, -Value
41            set_config/2,               % +Key, +Value
42            add_config/2,               % +Key, +Value
43            del_config/2,               % +Key, +Value
44                                        % edit/save/load
45            edit_config/1,              % +Graphical
46            save_config/1,              % +File
47            load_config/1,              % +File
48            ensure_loaded_config/1,     % +File
49                                        % Type conversion
50            config_term_to_object/2,    % ?Term, ?Object
51            config_term_to_object/3,    % +Type, ?Term, ?Object
52                                        % +Editor interface
53            config_attributes/2,        % ?Key, -Attributes
54            current_config_type/3       % +Type, -DefModule, -Attributes
55          ]).
56
57:- meta_predicate
58    register_config(2),
59    register_config_type(:, +),
60    current_config_type(:, -, -),
61    get_config_type(:, -),
62    get_config_term(:, -, -),
63    get_config(:, -),
64    set_config(:, +),
65    add_config(:, +),
66    del_config(:, +),
67    save_config(:),
68    load_config(:),
69    ensure_loaded_config(:),
70    edit_config(:),
71    config_attributes(:, -).
72
73:- use_module(library(pce)).
74:- use_module(library(broadcast)).
75:- require([ is_absolute_file_name/1
76           , is_list/1
77           , chain_list/2
78           , file_directory_name/2
79           , forall/2
80           , list_to_set/2
81           , member/2
82           , memberchk/2
83           , absolute_file_name/3
84           , call/3
85           , delete/3
86           , maplist/3
87           , strip_module/3
88           ]).
89
90:- pce_autoload(pce_config_editor,      library(pce_configeditor)).
91
92:- multifile user:file_search_path/2.
93:- dynamic   user:file_search_path/2.
94
95user:file_search_path(config, Dir) :-
96    get(@pce, application_data, AppDir),
97    get(AppDir, path, Dir).
98
99config_version(1).                      % version of the config package
100
101/** <module> XPCE congifuration database
102
103This module deals with saving and   loading application settings such as
104preferences and the layout of windows.
105
106@see    library(settings) provides the Prolog equivalent
107*/
108
109:- dynamic
110    config_type/3,                  % Type, Module, Attributes
111    config_db/2,                    % DB, Predicate
112    config_store/4.                 % DB, Path, Value, Type
113
114
115                 /*******************************
116                 *           REGISTER           *
117                 *******************************/
118
119%!  register_config(:Pred) is det.
120%
121%   Register  Pred  to  provide  metadata  about  the  configuration
122%   handled in the calling module.  Pred   is  called  as call(Pred,
123%   Path, Attributes).
124
125register_config(Spec) :-
126    strip_module(Spec, Module, Pred),
127    (   config_db(Module, Pred)
128    ->  true
129    ;   asserta(config_db(Module, Pred))
130    ).
131
132
133                 /*******************************
134                 *              QUERY           *
135                 *******************************/
136
137get_config_type(Key, Type) :-
138    strip_module(Key, DB, Path),
139    config_db(DB, Pred),
140    call(DB:Pred, Path, Attributes),
141    memberchk(type(Type), Attributes).
142
143%!  get_config(:Key, -Value) is det.
144%
145%   Get configuration for Key as Value.
146
147get_config(Key, Value) :-
148    strip_module(Key, DB, Path),
149    config_store(DB, Path, Value0, Type),
150    !,
151    config_term_to_object(Type, Value0, Value).
152get_config(Key, Value) :-
153    config_attribute(Key, default(Default)),
154    !,
155    (   config_attribute(Key, type(Type))
156    ->  strip_module(Key, DB, Path),
157        asserta(config_store(DB, Path, Default, Type)),
158        config_term_to_object(Type, Default, Value)
159    ;   Value = Default
160    ).
161
162
163get_config_term(Key, Term, Type) :-
164    strip_module(Key, DB, Path),
165    config_store(DB, Path, Term, Type).
166
167
168                 /*******************************
169                 *             MODIFY           *
170                 *******************************/
171
172%!  set_config(:Key, +Value) is det.
173%
174%   Set the configuration parameter Key to   Value.  If the value is
175%   modified, a broadcast message set_config(Key, Value) is issued.
176
177set_config(Key, Value) :-
178    get_config(Key, Current),
179    Value == Current,
180    !.
181set_config(Key, Value) :-
182    strip_module(Key, DB, Path),
183    set_config_(DB, Path, Value),
184    set_modified(DB),
185    broadcast(set_config(Key, Value)).
186
187set_config_(DB, Path, Value) :-         % local version
188    (   retract(config_store(DB, Path, _, Type))
189    ->  true
190    ;   get_config_type(DB:Path, Type)
191    ),
192    config_term_to_object(Type, TermValue, Value),
193    asserta(config_store(DB, Path, TermValue, Type)).
194
195set_config_term(DB, Path, Term, Type) :- % loaded keys
196    retractall(config_store(DB, Path, _, _)),
197    asserta(config_store(DB, Path, Term, Type)),
198    config_term_to_object(Type, Term, Value), % should we broadcast?
199    broadcast(set_config(DB:Path, Value)).
200
201set_config_(DB, Path, Value, Type) :-   % local version
202    retractall(config_store(DB, Path, _, _)),
203    asserta(config_store(DB, Path, Value, Type)).
204
205add_config(Key, Value) :-
206    strip_module(Key, DB, Path),
207    (   retract(config_store(DB, Path, Set0, Type)),
208        is_list(Set0)
209    ->  (   delete(Set0, Value, Set1)
210        ->  Set = [Value|Set1]
211        ;   Set = [Value|Set0]
212        )
213    ;   retractall(config_store(DB, Path, _, _)), % make sure
214        get_config_type(Key, Type),
215        Set = [Value]
216    ),
217    asserta(config_store(DB, Path, Set, Type)),
218    set_modified(DB).
219
220del_config(Key, Value) :-
221    strip_module(Key, DB, Path),
222    config_store(DB, Path, Set0, Type),
223    delete(Set0, Value, Set),
224    retract(config_store(DB, Path, Set0, Type)),
225    !,
226    asserta(config_store(DB, Path, Set, Type)),
227    set_modified(DB).
228
229set_modified(DB) :-
230    config_store(DB, '$modified', true, _),
231    !.
232set_modified(DB) :-
233    asserta(config_store(DB, '$modified', true, bool)).
234
235clear_modified(DB) :-
236    retractall(config_store(DB, '$modified', _, _)).
237
238
239                 /*******************************
240                 *            META              *
241                 *******************************/
242
243%!  config_attributes(+Key, -Attributes)
244%
245%   Fetch the (meta) attributes of the given config key.  The special
246%   path `config' returns information on the config database itself.
247%   The path of the key may be partly instantiated.
248
249config_attributes(Key, Attributes) :-
250    strip_module(Key, DB, Path),
251    config_db(DB, Pred),
252    call(DB:Pred, Path, Attributes).
253
254config_attribute(Key, Attribute) :-
255    var(Attribute),
256    !,
257    config_attributes(Key, Attributes),
258    member(Attribute, Attributes).
259config_attribute(Key, Attribute) :-
260    config_attributes(Key, Attributes),
261    memberchk(Attribute, Attributes),
262    !.
263
264current_config_path(Key) :-
265    strip_module(Key, DB, Path),
266    findall(P, config_path(DB, P), Ps0),
267    list_to_set(Ps0, Ps),
268    member(Path, Ps).
269
270config_path(DB, Path) :-
271    config_db(DB, Pred),
272    call(DB:Pred, Path, Attributes),
273    memberchk(type(_), Attributes).
274
275
276
277
278                 /*******************************
279                 *             SAVE             *
280                 *******************************/
281
282save_file(Key, File) :-
283    is_absolute_file_name(Key),
284    !,
285    File = Key.
286save_file(Key, File) :-
287    absolute_file_name(config(Key), File,
288                       [ access(write),
289                         extensions([cnf]),
290                         file_errors(fail)
291                       ]),
292    !.
293save_file(Key, File) :-
294    absolute_file_name(config(Key), File,
295                       [ extensions([cnf])
296                       ]),
297    !,
298    file_directory_name(File, Dir),
299    (   send(directory(Dir), exists)
300    ->  send(@pce, report, error, 'Cannot write config directory %s', Dir),
301        fail
302    ;   send(directory(Dir), make)
303    ).
304
305
306save_config(Spec) :-
307    strip_module(Spec, M, Key),
308    (   var(Key)
309    ->  get_config(M:config/file, Key)
310    ;   true
311    ),
312    save_file(Key, File),
313    save_config(File, M).
314
315save_config(File, M) :-
316    catch(do_save_config(File, M), E,
317          print_message(warning, E)).
318
319do_save_config(File, M) :-
320    setup_call_cleanup(
321        open(File, write, Fd, [encoding(utf8)]),
322        ( save_config_header(Fd, M),
323          save_config_body(Fd, M)
324        ),
325        close(Fd)).
326
327save_config_header(Fd, M) :-
328    get(@pce?date, value, Date),
329    get(@pce, user, User),
330    config_version(Version),
331    format(Fd, '/*  XPCE configuration file for "~w"~n', [M]),
332    format(Fd, '    Saved ~w by ~w~n', [Date, User]),
333    format(Fd, '*/~n~n', []),
334    format(Fd, 'configversion(~q).~n', [Version]),
335    format(Fd, '[~q].~n~n', [M]),
336    format(Fd, '%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%~n', []),
337    format(Fd, '% Option lines starting with a `%'' indicate      %~n',[]),
338    format(Fd, '% the value is equal to the application default. %~n', []),
339    format(Fd, '%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%~n', []).
340
341save_config_body(Fd, M) :-
342    forall(current_config_path(M:Path),
343           save_config_key(Fd, M:Path)).
344
345save_config_key(Fd, Key) :-
346    config_attribute(Key, comment(Comment)),
347    nl(Fd),
348    (   is_list(Comment)
349    ->  format_comment(Comment, Fd)
350    ;   format_comment([Comment], Fd)
351    ),
352    fail.
353save_config_key(Fd, Key) :-
354    strip_module(Key, _, Path),
355    Options = [quoted(true), module(pce)],
356    (   get_config_term(Key, Value, _Type),
357        (   (   config_attribute(Key, default(Value0))
358            ->  Value == Value0
359            )
360        ->  format(Fd, '%~q = ~t~32|~W.~n', [Path, Value, Options])
361        ;   format(Fd, '~q = ~t~32|~W.~n',  [Path, Value, Options])
362        ),
363        fail
364    ;   true
365    ).
366
367format_comment([], _).
368format_comment([H|T], Fd) :-
369    format(Fd, '/* ~w */~n', [H]),
370    format_comment(T, Fd).
371
372save_modified_configs :-
373    config_db(DB, _Pred),
374    get_config(DB:'$modified', true),
375    clear_modified(DB),
376    get_config(DB:config/file, Key),
377    send(@pce, report, status, 'Saving config database %s', Key),
378    save_config(DB:_DefaultFile),
379    fail.
380save_modified_configs.
381
382:- initialization
383   send(@pce, exit_message, message(@prolog, save_modified_configs)).
384
385
386                 /*******************************
387                 *             LOAD             *
388                 *******************************/
389
390ensure_loaded_config(Spec) :-
391    strip_module(Spec, M, _Key),
392    config_store(M, _Path, _Value, _Type),
393    !.
394ensure_loaded_config(Spec) :-
395    load_config(Spec).
396
397load_file(Key, File) :-
398    is_absolute_file_name(Key),
399    !,
400    File = Key.
401load_file(Key, File) :-
402    absolute_file_name(config(Key), File,
403                       [ access(read),
404                         extensions([cnf]),
405                         file_errors(fail)
406                       ]).
407
408load_key(_DB, Key) :-
409    nonvar(Key),
410    !.
411load_key(DB, Key) :-
412    get_config(DB:config/file, Key),
413    !.
414
415
416load_config(Spec) :-
417    strip_module(Spec, M, Key),
418    catch(pce_config:load_config(M, Key), E,
419          print_message(warning, E)).
420
421load_config(M, Key) :-
422    load_key(M, Key),
423    load_file(Key, File),
424    !,
425    setup_call_cleanup(
426        ( '$push_input_context'(pce_config),
427          open(File, read, Fd, [encoding(utf8)])
428        ),
429        read_config_file(Fd, _SaveVersion, _SaveModule, Bindings),
430        ( close(Fd),
431          '$pop_input_context'
432        )),
433    load_config_keys(M, Bindings),
434    set_config_(M, config/file, File, file),
435    clear_modified(M).
436load_config(M, Key) :-                  % no config file, use defaults
437    load_key(M, Key),
438    set_config_(M, config/file, Key, file),
439    clear_modified(M).              % or not, so we save first time?
440
441
442read_config_file(Fd, SaveVersion, SaveModule, Bindings) :-
443    read(Fd, configversion(SaveVersion)),
444    read(Fd, [SaveModule]),
445    read_term(Fd, Term, [module(pce)]),
446    read_config_file(Term, Fd, Bindings).
447
448read_config_file(end_of_file, _, []) :- !.
449read_config_file(Binding, Fd, [Binding|T]) :-
450    read_term(Fd, Term, [module(pce)]),
451    read_config_file(Term, Fd, T).
452
453load_config_keys(DB, Bindings) :-
454    forall(current_config_path(DB:Path),
455           load_config_key(DB:Path, Bindings)).
456
457load_config_key(Key, Bindings) :-
458    strip_module(Key, DB, Path),
459    config_attribute(Key, type(Type)),
460    (   member(Path=Value, Bindings)
461    *-> set_config_term(DB, Path, Value, Type),
462        fail
463    ;   config_attribute(Key, default(Value))
464    ->  set_config_term(DB, Path, Value, Type)
465    ),
466    !.
467load_config_key(_, _).
468
469
470                 /*******************************
471                 *             EDIT             *
472                 *******************************/
473
474edit_config(Spec) :-
475    strip_module(Spec, M, Graphical),
476    make_config_editor(M, Editor),
477    (   object(Graphical),
478        send(Graphical, instance_of, visual),
479        get(Graphical, frame, Frame)
480    ->  send(Editor, transient_for, Frame),
481        send(Editor, modal, transient),
482        send(Editor, open_centered, Frame?area?center)
483    ;   send(Editor, open_centered)
484    ).
485
486make_config_editor(M, Editor) :-
487    new(Editor, pce_config_editor(M)).
488
489
490                 /*******************************
491                 *             TYPES            *
492                 *******************************/
493
494resource(font,          image,  image('16x16/font.xpm')).
495resource(cpalette2,     image,  image('16x16/cpalette2.xpm')).
496
497builtin_config_type(bool,               [ editor(config_bool_item),
498                                          term(map([@off=false, @on=true]))
499                                        ]).
500builtin_config_type(font,               [ editor(font_item),
501                                          term([family, style, points]),
502                                          icon(font)
503                                        ]).
504builtin_config_type(colour,             [ editor(colour_item),
505                                          term(if(@arg1?kind == named, name)),
506                                          term([@default, red, green, blue])
507                                        ]).
508builtin_config_type(setof(colour),      [ editor(colour_palette_item),
509                                          icon(cpalette2)
510                                        ]).
511builtin_config_type(image,              [ editor(image_item),
512                                          term(if(@arg1?name \== @nil, name)),
513                                          term(@arg1?file?absolute_path)
514                                        ]).
515builtin_config_type(file,               [ editor(file_item)
516                                        ]).
517builtin_config_type(directory,          [ editor(directory_item)
518                                        ]).
519builtin_config_type({}(_),              [ editor(config_one_of_item)
520                                        ]).
521builtin_config_type(_,                  [ editor(config_generic_item)
522                                        ]).
523
524register_config_type(TypeSpec, Attributes) :-
525    strip_module(TypeSpec, Module, Type),
526    (   config_type(Type, Module, Attributes)
527    ->  true
528    ;   asserta(config_type(Type, Module, Attributes))
529    ).
530
531current_config_type(TypeSpec, DefModule, Attributes) :-
532    strip_module(TypeSpec, Module, Type),
533    (   config_type(Type, Module, Attributes)
534    ->  DefModule = Module
535    ;   config_type(Type, DefModule, Attributes)
536    ).
537current_config_type(TypeSpec, pce_config, Attributes) :-
538    strip_module(TypeSpec, _Module, Type),
539    builtin_config_type(Type, Attributes).
540
541%!  pce_object_type(+Type)
542%
543%   Succeed if Type denotes an XPCE type
544
545pce_object_type(Var) :-
546    var(Var),
547    !,
548    fail.
549pce_object_type(setof(Type)) :-
550    !,
551    pce_object_type(Type).
552pce_object_type(Type) :-
553    current_config_type(Type, _, Attributes),
554    memberchk(term(_), Attributes).
555
556
557                 /*******************************
558                 *       TERM <-> OBJECT        *
559                 *******************************/
560
561config_term_to_object(Type, Term, Object) :-
562    pce_object_type(Type),
563    !,
564    config_term_to_object(Term, Object).
565config_term_to_object(_, Value, Value).
566
567
568config_term_to_object(Term, Object) :-
569    nonvar(Object),
570    !,
571    config_object_to_term(Object, Term).
572config_term_to_object(Term, _Object) :-
573    var(Term),
574    fail.                           % raise error!
575config_term_to_object(List, Chain) :-
576    is_list(List),
577    !,
578    maplist(config_term_to_object, List, Objects),
579    chain_list(Chain, Objects).
580config_term_to_object(Atomic, Atomic) :-
581    atomic(Atomic),
582    !.
583config_term_to_object(Term+Attribute, Object) :-
584    !,
585    Attribute =.. [AttName, AttTerm],
586    config_term_to_object(AttTerm, AttObject),
587    config_term_to_object(Term, Object),
588    send(Object, AttName, AttObject).
589config_term_to_object(Term, Object) :-
590    new(Object, Term).
591
592%       Object --> Term
593
594config_object_to_term(@off, false) :- !.
595config_object_to_term(@on, true) :- !.
596config_object_to_term(@Ref, @Ref) :-
597    atom(Ref),
598    !.                   % global objects!
599config_object_to_term(Chain, List) :-
600    send(Chain, instance_of, chain),
601    !,
602    chain_list(Chain, List0),
603    maplist(config_object_to_term, List0, List).
604config_object_to_term(Obj, Term) :-
605    object(Obj),
606    get(Obj, class_name, ClassName),
607    term_description(ClassName, Attributes, Condition),
608    send(Condition, forward, Obj),
609    config_attributes_to_term(Attributes, Obj, Term).
610config_object_to_term(Obj, Term) :-
611    object(Obj),
612    get(Obj, class_name, ClassName),
613    term_description(ClassName, Attributes),
614    config_attributes_to_term(Attributes, Obj, Term).
615config_object_to_term(V, V).
616
617config_attributes_to_term(map(Mapping), Obj, Term) :-
618    !,
619    memberchk(Obj=Term, Mapping).
620config_attributes_to_term(NewAtts+Att, Obj, Term+AttTerm) :-
621    !,
622    config_attributes_to_term(NewAtts, Obj, Term),
623    prolog_value_argument(Obj, Att, AttTermVal),
624    AttTerm =.. [Att, AttTermVal].
625config_attributes_to_term(Attributes, Obj, Term) :-
626    is_list(Attributes),
627    !,
628    get(Obj, class_name, ClassName),
629    maplist(prolog_value_argument(Obj), Attributes, InitArgs),
630    Term =.. [ClassName|InitArgs].
631config_attributes_to_term(Attribute, Obj, Term) :-
632    prolog_value_argument(Obj, Attribute, Term).
633
634                                        % unconditional term descriptions
635term_description(Type, TermDescription) :-
636    current_config_type(Type, _, Attributes),
637    member(term(TermDescription), Attributes),
638    \+ TermDescription = if(_,_).
639term_description(Type, TermDescription, Condition) :-
640    current_config_type(Type, _, Attributes),
641    member(term(if(Condition, TermDescription)), Attributes).
642
643prolog_value_argument(Obj, Arg, ArgTerm) :-
644    atom(Arg),
645    !,
646    get(Obj, Arg, V0),
647    config_object_to_term(V0, ArgTerm).
648prolog_value_argument(Obj, Arg, Value) :-
649    functor(Arg, ?, _),
650    get(Arg, '_forward', Obj, Value).
651prolog_value_argument(_, Arg, Arg).
652
653
654                 /*******************************
655                 *         XREF SUPPORT         *
656                 *******************************/
657
658:- multifile
659    prolog:called_by/2.
660
661prolog:called_by(register_config(G), [G+2]).
662