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
 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    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).
 537
 538%!  pce_object_type(+Type)
 539%
 540%   Succeed if Type denotes an XPCE type
 541
 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]).