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

  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                 *******************************/

 register_config(:Pred) is det

Register Pred to provide metadata about the configuration handled in the calling module. Pred is called as call(Pred, Path, Attributes).

  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).

 get_config(:Key, -Value) is det

Get configuration for Key as Value.

  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                 *******************************/

 set_config(:Key, +Value) is det

Set the configuration parameter Key to Value. If the value is modified, a broadcast message set_config(Key, Value) is issued.

  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                 *******************************/

 config_attributes(+Key, -Attributes)

Fetch the (meta) attributes of the given config key. The special path `config' returns information on the config database itself. The path of the key may be partly instantiated.

  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).

 pce_object_type(+Type)

Succeed if Type denotes an XPCE type

  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])