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-2013, 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    open(File, write, Fd),
  321    save_config_header(Fd, M),
  322    save_config_body(Fd, M),
  323    close(Fd).
  324
  325save_config_header(Fd, M) :-
  326    get(@pce?date, value, Date),
  327    get(@pce, user, User),
  328    config_version(Version),
  329    format(Fd, '/*  XPCE configuration file for "~w"~n', [M]),
  330    format(Fd, '    Saved ~w by ~w~n', [Date, User]),
  331    format(Fd, '*/~n~n', []),
  332    format(Fd, 'configversion(~q).~n', [Version]),
  333    format(Fd, '[~q].~n~n', [M]),
  334    format(Fd, '%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%~n', []),
  335    format(Fd, '% Option lines starting with a `%'' indicate      %~n',[]),
  336    format(Fd, '% the value is equal to the application default. %~n', []),
  337    format(Fd, '%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%~n', []).
  338
  339save_config_body(Fd, M) :-
  340    forall(current_config_path(M:Path),
  341           save_config_key(Fd, M:Path)).
  342
  343save_config_key(Fd, Key) :-
  344    config_attribute(Key, comment(Comment)),
  345    nl(Fd),
  346    (   is_list(Comment)
  347    ->  format_comment(Comment, Fd)
  348    ;   format_comment([Comment], Fd)
  349    ),
  350    fail.
  351save_config_key(Fd, Key) :-
  352    strip_module(Key, _, Path),
  353    (   get_config_term(Key, Value, _Type),
  354        (   (   config_attribute(Key, default(Value0))
  355            ->  Value == Value0
  356            )
  357        ->  format(Fd, '%~q = ~t~32|~q.~n', [Path, Value])
  358        ;   format(Fd, '~q = ~t~32|~q.~n',  [Path, Value])
  359        ),
  360        fail
  361    ;   true
  362    ).
  363
  364format_comment([], _).
  365format_comment([H|T], Fd) :-
  366    format(Fd, '/* ~w */~n', [H]),
  367    format_comment(T, Fd).
  368
  369save_modified_configs :-
  370    config_db(DB, _Pred),
  371    get_config(DB:'$modified', true),
  372    clear_modified(DB),
  373    get_config(DB:config/file, Key),
  374    send(@pce, report, status, 'Saving config database %s', Key),
  375    save_config(DB:_DefaultFile),
  376    fail.
  377save_modified_configs.
  378
  379:- initialization
  380   send(@pce, exit_message, message(@prolog, save_modified_configs)).  381
  382
  383                 /*******************************
  384                 *             LOAD             *
  385                 *******************************/
  386
  387ensure_loaded_config(Spec) :-
  388    strip_module(Spec, M, _Key),
  389    config_store(M, _Path, _Value, _Type),
  390    !.
  391ensure_loaded_config(Spec) :-
  392    load_config(Spec).
  393
  394load_file(Key, File) :-
  395    is_absolute_file_name(Key),
  396    !,
  397    File = Key.
  398load_file(Key, File) :-
  399    absolute_file_name(config(Key), File,
  400                       [ access(read),
  401                         extensions([cnf]),
  402                         file_errors(fail)
  403                       ]).
  404
  405load_key(_DB, Key) :-
  406    nonvar(Key),
  407    !.
  408load_key(DB, Key) :-
  409    get_config(DB:config/file, Key),
  410    !.
  411
  412
  413load_config(Spec) :-
  414    strip_module(Spec, M, Key),
  415    catch(pce_config:load_config(M, Key), E,
  416          print_message(warning, E)).
  417
  418load_config(M, Key) :-
  419    load_key(M, Key),
  420    load_file(Key, File),
  421    !,
  422    setup_call_cleanup(
  423        ( '$push_input_context'(pce_config),
  424          open(File, read, Fd)
  425        ),
  426        read_config_file(Fd, _SaveVersion, _SaveModule, Bindings),
  427        ( close(Fd),
  428          '$pop_input_context'
  429        )),
  430    load_config_keys(M, Bindings),
  431    set_config_(M, config/file, File, file),
  432    clear_modified(M).
  433load_config(M, Key) :-                  % no config file, use defaults
  434    load_key(M, Key),
  435    set_config_(M, config/file, Key, file),
  436    clear_modified(M).              % or not, so we save first time?
  437
  438
  439read_config_file(Fd, SaveVersion, SaveModule, Bindings) :-
  440    read(Fd, configversion(SaveVersion)),
  441    read(Fd, [SaveModule]),
  442    read(Fd, Term),
  443    read_config_file(Term, Fd, Bindings).
  444
  445read_config_file(end_of_file, _, []) :- !.
  446read_config_file(Binding, Fd, [Binding|T]) :-
  447    read(Fd, Term),
  448    read_config_file(Term, Fd, T).
  449
  450load_config_keys(DB, Bindings) :-
  451    forall(current_config_path(DB:Path),
  452           load_config_key(DB:Path, Bindings)).
  453
  454load_config_key(Key, Bindings) :-
  455    strip_module(Key, DB, Path),
  456    config_attribute(Key, type(Type)),
  457    (   member(Path=Value, Bindings)
  458    *-> set_config_term(DB, Path, Value, Type),
  459        fail
  460    ;   config_attribute(Key, default(Value))
  461    ->  set_config_term(DB, Path, Value, Type)
  462    ),
  463    !.
  464load_config_key(_, _).
  465
  466
  467                 /*******************************
  468                 *             EDIT             *
  469                 *******************************/
  470
  471edit_config(Spec) :-
  472    strip_module(Spec, M, Graphical),
  473    make_config_editor(M, Editor),
  474    (   object(Graphical),
  475        send(Graphical, instance_of, visual),
  476        get(Graphical, frame, Frame)
  477    ->  send(Editor, transient_for, Frame),
  478        send(Editor, modal, transient),
  479        send(Editor, open_centered, Frame?area?center)
  480    ;   send(Editor, open_centered)
  481    ).
  482
  483make_config_editor(M, Editor) :-
  484    new(Editor, pce_config_editor(M)).
  485
  486
  487                 /*******************************
  488                 *             TYPES            *
  489                 *******************************/
  490
  491resource(font,          image,  image('16x16/font.xpm')).
  492resource(cpalette2,     image,  image('16x16/cpalette2.xpm')).
  493
  494builtin_config_type(bool,               [ editor(config_bool_item),
  495                                          term(map([@off=false, @on=true]))
  496                                        ]).
  497builtin_config_type(font,               [ editor(font_item),
  498                                          term([family, style, points]),
  499                                          icon(font)
  500                                        ]).
  501builtin_config_type(colour,             [ editor(colour_item),
  502                                          term(if(@arg1?kind == named, name)),
  503                                          term([@default, red, green, blue])
  504                                        ]).
  505builtin_config_type(setof(colour),      [ editor(colour_palette_item),
  506                                          icon(cpalette2)
  507                                        ]).
  508builtin_config_type(image,              [ editor(image_item),
  509                                          term(if(@arg1?name \== @nil, name)),
  510                                          term(@arg1?file?absolute_path)
  511                                        ]).
  512builtin_config_type(file,               [ editor(file_item)
  513                                        ]).
  514builtin_config_type(directory,          [ editor(directory_item)
  515                                        ]).
  516builtin_config_type({}(_),              [ editor(config_one_of_item)
  517                                        ]).
  518builtin_config_type(_,                  [ editor(config_generic_item)
  519                                        ]).
  520
  521register_config_type(TypeSpec, Attributes) :-
  522    strip_module(TypeSpec, Module, Type),
  523    (   config_type(Type, Module, Attributes)
  524    ->  true
  525    ;   asserta(config_type(Type, Module, Attributes))
  526    ).
  527
  528current_config_type(TypeSpec, DefModule, Attributes) :-
  529    strip_module(TypeSpec, Module, Type),
  530    (   config_type(Type, Module, Attributes)
  531    ->  DefModule = Module
  532    ;   config_type(Type, DefModule, Attributes)
  533    ).
  534current_config_type(TypeSpec, pce_config, Attributes) :-
  535    strip_module(TypeSpec, _Module, Type),
  536    builtin_config_type(Type, Attributes).

 pce_object_type(+Type)

Succeed if Type denotes an XPCE type

  542pce_object_type(Var) :-
  543    var(Var),
  544    !,
  545    fail.
  546pce_object_type(setof(Type)) :-
  547    !,
  548    pce_object_type(Type).
  549pce_object_type(Type) :-
  550    current_config_type(Type, _, Attributes),
  551    memberchk(term(_), Attributes).
  552
  553
  554                 /*******************************
  555                 *       TERM <-> OBJECT        *
  556                 *******************************/
  557
  558config_term_to_object(Type, Term, Object) :-
  559    pce_object_type(Type),
  560    !,
  561    config_term_to_object(Term, Object).
  562config_term_to_object(_, Value, Value).
  563
  564
  565config_term_to_object(Term, Object) :-
  566    nonvar(Object),
  567    !,
  568    config_object_to_term(Object, Term).
  569config_term_to_object(Term, _Object) :-
  570    var(Term),
  571    fail.                           % raise error!
  572config_term_to_object(List, Chain) :-
  573    is_list(List),
  574    !,
  575    maplist(config_term_to_object, List, Objects),
  576    chain_list(Chain, Objects).
  577config_term_to_object(Atomic, Atomic) :-
  578    atomic(Atomic),
  579    !.
  580config_term_to_object(Term+Attribute, Object) :-
  581    !,
  582    Attribute =.. [AttName, AttTerm],
  583    config_term_to_object(AttTerm, AttObject),
  584    config_term_to_object(Term, Object),
  585    send(Object, AttName, AttObject).
  586config_term_to_object(Term, Object) :-
  587    new(Object, Term).
  588
  589%       Object --> Term
  590
  591config_object_to_term(@off, false) :- !.
  592config_object_to_term(@on, true) :- !.
  593config_object_to_term(@Ref, @Ref) :-
  594    atom(Ref),
  595    !.                   % global objects!
  596config_object_to_term(Chain, List) :-
  597    send(Chain, instance_of, chain),
  598    !,
  599    chain_list(Chain, List0),
  600    maplist(config_object_to_term, List0, List).
  601config_object_to_term(Obj, Term) :-
  602    object(Obj),
  603    get(Obj, class_name, ClassName),
  604    term_description(ClassName, Attributes, Condition),
  605    send(Condition, forward, Obj),
  606    config_attributes_to_term(Attributes, Obj, Term).
  607config_object_to_term(Obj, Term) :-
  608    object(Obj),
  609    get(Obj, class_name, ClassName),
  610    term_description(ClassName, Attributes),
  611    config_attributes_to_term(Attributes, Obj, Term).
  612config_object_to_term(V, V).
  613
  614config_attributes_to_term(map(Mapping), Obj, Term) :-
  615    !,
  616    memberchk(Obj=Term, Mapping).
  617config_attributes_to_term(NewAtts+Att, Obj, Term+AttTerm) :-
  618    !,
  619    config_attributes_to_term(NewAtts, Obj, Term),
  620    prolog_value_argument(Obj, Att, AttTermVal),
  621    AttTerm =.. [Att, AttTermVal].
  622config_attributes_to_term(Attributes, Obj, Term) :-
  623    is_list(Attributes),
  624    !,
  625    get(Obj, class_name, ClassName),
  626    maplist(prolog_value_argument(Obj), Attributes, InitArgs),
  627    Term =.. [ClassName|InitArgs].
  628config_attributes_to_term(Attribute, Obj, Term) :-
  629    prolog_value_argument(Obj, Attribute, Term).
  630
  631                                        % unconditional term descriptions
  632term_description(Type, TermDescription) :-
  633    current_config_type(Type, _, Attributes),
  634    member(term(TermDescription), Attributes),
  635    \+ TermDescription = if(_,_).
  636term_description(Type, TermDescription, Condition) :-
  637    current_config_type(Type, _, Attributes),
  638    member(term(if(Condition, TermDescription)), Attributes).
  639
  640prolog_value_argument(Obj, Arg, ArgTerm) :-
  641    atom(Arg),
  642    !,
  643    get(Obj, Arg, V0),
  644    config_object_to_term(V0, ArgTerm).
  645prolog_value_argument(Obj, Arg, Value) :-
  646    functor(Arg, ?, _),
  647    get(Arg, '_forward', Obj, Value).
  648prolog_value_argument(_, Arg, Arg).
  649
  650
  651                 /*******************************
  652                 *         XREF SUPPORT         *
  653                 *******************************/
  654
  655:- multifile
  656    prolog:called_by/2.  657
  658prolog:called_by(register_config(G), [G+2])