/*  Part of SWI-Prolog

    Author:        Jan Wielemaker
    E-mail:        J.Wielemaker@vu.nl
    WWW:           http://www.swi-prolog.org
    Copyright (c)  1995-2020, University of Amsterdam
                              VU University Amsterdam
                              CWI, Amsterdam
    All rights reserved.

    Redistribution and use in source and binary forms, with or without
    modification, are permitted provided that the following conditions
    are met:

    1. Redistributions of source code must retain the above copyright
       notice, this list of conditions and the following disclaimer.

    2. Redistributions in binary form must reproduce the above copyright
       notice, this list of conditions and the following disclaimer in
       the documentation and/or other materials provided with the
       distribution.

    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
    POSSIBILITY OF SUCH DAMAGE.
*/

:- module(qsave,
          [ qsave_program/1,                    % +File
            qsave_program/2                     % +File, +Options
          ]).
:- use_module(library(zip)).
:- use_module(library(lists)).
:- use_module(library(option)).
:- use_module(library(error)).
:- use_module(library(apply)).

/** <module> Save current program as a state or executable

This library provides qsave_program/1  and   qsave_program/2,  which are
also used by the commandline sequence below.

  ==
  swipl -o exe -c file.pl ...
  ==
*/

:- meta_predicate
    qsave_program(+, :).

:- multifile error:has_type/2.
error:has_type(qsave_foreign_option, Term) :-
    is_of_type(oneof([save, no_save]), Term),
    !.
error:has_type(qsave_foreign_option, arch(Archs)) :-
    is_of_type(list(atom), Archs),
    !.

save_option(stack_limit, integer,
            "Stack limit (bytes)").
save_option(goal,        callable,
            "Main initialization goal").
save_option(toplevel,    callable,
            "Toplevel goal").
save_option(init_file,   atom,
            "Application init file").
save_option(packs,       boolean,
            "Do (not) attach packs").
save_option(class,       oneof([runtime,development]),
            "Development state").
save_option(op,          oneof([save,standard]),
            "Save operators").
save_option(autoload,    boolean,
            "Resolve autoloadable predicates").
save_option(map,         atom,
            "File to report content of the state").
save_option(stand_alone, boolean,
            "Add emulator at start").
save_option(traditional, boolean,
            "Use traditional mode").
save_option(emulator,    ground,
            "Emulator to use").
save_option(foreign,     qsave_foreign_option,
            "Include foreign code in state").
save_option(obfuscate,   boolean,
            "Obfuscate identifiers").
save_option(verbose,     boolean,
            "Be more verbose about the state creation").
save_option(undefined,   oneof([ignore,error]),
            "How to handle undefined predicates").
save_option(on_error,    oneof([print,halt,status]),
            "How to handle errors").
save_option(on_warning,  oneof([print,halt,status]),
            "How to handle warnings").

term_expansion(save_pred_options,
               (:- predicate_options(qsave_program/2, 2, Options))) :-
    findall(O,
            ( save_option(Name, Type, _),
              O =.. [Name,Type]
            ),
            Options).

save_pred_options.

:- set_prolog_flag(generate_debug_info, false).

:- dynamic
    verbose/1,
    saved_resource_file/1.
:- volatile
    verbose/1,                  % contains a stream-handle
    saved_resource_file/1.

%!  qsave_program(+File) is det.
%!  qsave_program(+File, :Options) is det.
%
%   Make a saved state in file `File'.

qsave_program(File) :-
    qsave_program(File, []).

qsave_program(FileBase, Options0) :-
    meta_options(is_meta, Options0, Options),
    check_options(Options),
    exe_file(FileBase, File, Options),
    option(class(SaveClass),    Options, runtime),
    option(init_file(InitFile), Options, DefInit),
    default_init_file(SaveClass, DefInit),
    prepare_entry_points(Options),
    save_autoload(Options),
    setup_call_cleanup(
        open_map(Options),
        ( prepare_state(Options),
          create_prolog_flag(saved_program, true, []),
          create_prolog_flag(saved_program_class, SaveClass, []),
          delete_if_exists(File),    % truncate will crash a Prolog
                                     % running on this state
          setup_call_catcher_cleanup(
              open(File, write, StateOut, [type(binary)]),
              write_state(StateOut, SaveClass, InitFile, Options),
              Reason,
              finalize_state(Reason, StateOut, File))
        ),
        close_map),
    cleanup,
    !.

write_state(StateOut, SaveClass, InitFile, Options) :-
    make_header(StateOut, SaveClass, Options),
    setup_call_cleanup(
        zip_open_stream(StateOut, RC, []),
        write_zip_state(RC, SaveClass, InitFile, Options),
        zip_close(RC, [comment('SWI-Prolog saved state')])),
    flush_output(StateOut).

write_zip_state(RC, SaveClass, InitFile, Options) :-
    save_options(RC, SaveClass,
                 [ init_file(InitFile)
                 | Options
                 ]),
    save_resources(RC, SaveClass),
    lock_files(SaveClass),
    save_program(RC, SaveClass, Options),
    save_foreign_libraries(RC, Options).

finalize_state(exit, StateOut, File) :-
    close(StateOut),
    '$mark_executable'(File).
finalize_state(!, StateOut, File) :-
    print_message(warning, qsave(nondet)),
    finalize_state(exit, StateOut, File).
finalize_state(_, StateOut, File) :-
    close(StateOut, [force(true)]),
    catch(delete_file(File),
          Error,
          print_message(error, Error)).

cleanup :-
    retractall(saved_resource_file(_)).

is_meta(goal).
is_meta(toplevel).

exe_file(Base, Exe, Options) :-
    current_prolog_flag(windows, true),
    option(stand_alone(true), Options, true),
    file_name_extension(_, '', Base),
    !,
    file_name_extension(Base, exe, Exe).
exe_file(Exe, Exe, _).

default_init_file(runtime, none) :- !.
default_init_file(_,       InitFile) :-
    '$cmd_option_val'(init_file, InitFile).

delete_if_exists(File) :-
    (   exists_file(File)
    ->  delete_file(File)
    ;   true
    ).

                 /*******************************
                 *           HEADER             *
                 *******************************/

%!  make_header(+Out:stream, +SaveClass, +Options) is det.

make_header(Out, _, Options) :-
    option(emulator(OptVal), Options),
    !,
    absolute_file_name(OptVal, [access(read)], Emulator),
    setup_call_cleanup(
        open(Emulator, read, In, [type(binary)]),
        copy_stream_data(In, Out),
        close(In)).
make_header(Out, _, Options) :-
    (   current_prolog_flag(windows, true)
    ->  DefStandAlone = true
    ;   DefStandAlone = false
    ),
    option(stand_alone(true), Options, DefStandAlone),
    !,
    current_prolog_flag(executable, Executable),
    setup_call_cleanup(
        open(Executable, read, In, [type(binary)]),
        copy_stream_data(In, Out),
        close(In)).
make_header(Out, SaveClass, _Options) :-
    current_prolog_flag(unix, true),
    !,
    current_prolog_flag(executable, Executable),
    current_prolog_flag(posix_shell, Shell),
    format(Out, '#!~w~n', [Shell]),
    format(Out, '# SWI-Prolog saved state~n', []),
    (   SaveClass == runtime
    ->  ArgSep = ' -- '
    ;   ArgSep = ' '
    ),
    format(Out, 'exec ${SWIPL-~w} -x "$0"~w"$@"~n~n', [Executable, ArgSep]).
make_header(_, _, _).


                 /*******************************
                 *           OPTIONS            *
                 *******************************/

min_stack(stack_limit, 100_000).

convert_option(Stack, Val, NewVal, '~w') :-     % stack-sizes are in K-bytes
    min_stack(Stack, Min),
    !,
    (   Val == 0
    ->  NewVal = Val
    ;   NewVal is max(Min, Val)
    ).
convert_option(toplevel, Callable, Callable, '~q') :- !.
convert_option(_, Value, Value, '~w').

doption(Name) :- min_stack(Name, _).
doption(init_file).
doption(system_init_file).
doption(class).
doption(home).
doption(nosignals).

%!  save_options(+ArchiveHandle, +SaveClass, +Options)
%
%   Save the options in the '$options'   resource. The home directory is
%   saved for development  states  to  make   it  keep  refering  to the
%   development home.
%
%   The script files (-s script) are not saved   at all. I think this is
%   fine to avoid a save-script loading itself.

save_options(RC, SaveClass, Options) :-
    zipper_open_new_file_in_zip(RC, '$prolog/options.txt', Fd, []),
    (   doption(OptionName),
            '$cmd_option_val'(OptionName, OptionVal0),
            save_option_value(SaveClass, OptionName, OptionVal0, OptionVal1),
            OptTerm =.. [OptionName,OptionVal2],
            (   option(OptTerm, Options)
            ->  convert_option(OptionName, OptionVal2, OptionVal, FmtVal)
            ;   OptionVal = OptionVal1,
                FmtVal = '~w'
            ),
            atomics_to_string(['~w=', FmtVal, '~n'], Fmt),
            format(Fd, Fmt, [OptionName, OptionVal]),
        fail
    ;   true
    ),
    save_init_goals(Fd, Options),
    close(Fd).

%!  save_option_value(+SaveClass, +OptionName, +OptionValue, -FinalValue)

save_option_value(Class,   class, _,     Class) :- !.
save_option_value(runtime, home,  _,     _) :- !, fail.
save_option_value(_,       _,     Value, Value).

%!  save_init_goals(+Stream, +Options)
%
%   Save initialization goals. If there  is   a  goal(Goal)  option, use
%   that, else save the goals from '$cmd_option_val'/2.

save_init_goals(Out, Options) :-
    option(goal(Goal), Options),
    !,
    format(Out, 'goal=~q~n', [Goal]),
    save_toplevel_goal(Out, halt, Options).
save_init_goals(Out, Options) :-
    '$cmd_option_val'(goals, Goals),
    forall(member(Goal, Goals),
           format(Out, 'goal=~w~n', [Goal])),
    (   Goals == []
    ->  DefToplevel = default
    ;   DefToplevel = halt
    ),
    save_toplevel_goal(Out, DefToplevel, Options).

save_toplevel_goal(Out, _Default, Options) :-
    option(toplevel(Goal), Options),
    !,
    unqualify_reserved_goal(Goal, Goal1),
    format(Out, 'toplevel=~q~n', [Goal1]).
save_toplevel_goal(Out, _Default, _Options) :-
    '$cmd_option_val'(toplevel, Toplevel),
    Toplevel \== default,
    !,
    format(Out, 'toplevel=~w~n', [Toplevel]).
save_toplevel_goal(Out, Default, _Options) :-
    format(Out, 'toplevel=~q~n', [Default]).

unqualify_reserved_goal(_:prolog, prolog) :- !.
unqualify_reserved_goal(_:default, default) :- !.
unqualify_reserved_goal(Goal, Goal).


                 /*******************************
                 *           RESOURCES          *
                 *******************************/

save_resources(_RC, development) :- !.
save_resources(RC, _SaveClass) :-
    feedback('~nRESOURCES~n~n', []),
    copy_resources(RC),
    forall(declared_resource(Name, FileSpec, Options),
           save_resource(RC, Name, FileSpec, Options)).

declared_resource(RcName, FileSpec, []) :-
    current_predicate(_, M:resource(_,_)),
    M:resource(Name, FileSpec),
    mkrcname(M, Name, RcName).
declared_resource(RcName, FileSpec, Options) :-
    current_predicate(_, M:resource(_,_,_)),
    M:resource(Name, A2, A3),
    (   is_list(A3)
    ->  FileSpec = A2,
        Options = A3
    ;   FileSpec = A3
    ),
    mkrcname(M, Name, RcName).

%!  mkrcname(+Module, +NameSpec, -Name)
%
%   Turn a resource name term into a resource name atom.

mkrcname(user, Name0, Name) :-
    !,
    path_segments_to_atom(Name0, Name).
mkrcname(M, Name0, RcName) :-
    path_segments_to_atom(Name0, Name),
    atomic_list_concat([M, :, Name], RcName).

path_segments_to_atom(Name0, Name) :-
    phrase(segments_to_atom(Name0), Atoms),
    atomic_list_concat(Atoms, /, Name).

segments_to_atom(Var) -->
    { var(Var), !,
      instantiation_error(Var)
    }.
segments_to_atom(A/B) -->
    !,
    segments_to_atom(A),
    segments_to_atom(B).
segments_to_atom(A) -->
    [A].

%!  save_resource(+Zipper, +Name, +FileSpec, +Options) is det.
%
%   Add the content represented by FileSpec to Zipper under Name.

save_resource(RC, Name, FileSpec, _Options) :-
    absolute_file_name(FileSpec,
                       [ access(read),
                         file_errors(fail)
                       ], File),
    !,
    feedback('~t~8|~w~t~32|~w~n',
             [Name, File]),
    zipper_append_file(RC, Name, File, []).
save_resource(RC, Name, FileSpec, Options) :-
    findall(Dir,
            absolute_file_name(FileSpec, Dir,
                               [ access(read),
                                 file_type(directory),
                                 file_errors(fail),
                                 solutions(all)
                               ]),
            Dirs),
    Dirs \== [],
    !,
    forall(member(Dir, Dirs),
           ( feedback('~t~8|~w~t~32|~w~n',
                      [Name, Dir]),
             zipper_append_directory(RC, Name, Dir, Options))).
save_resource(RC, Name, _, _Options) :-
    '$rc_handle'(SystemRC),
    copy_resource(SystemRC, RC, Name),
    !.
save_resource(_, Name, FileSpec, _Options) :-
    print_message(warning,
                  error(existence_error(resource,
                                        resource(Name, FileSpec)),
                        _)).

copy_resources(ToRC) :-
    '$rc_handle'(FromRC),
    zipper_members(FromRC, List),
    (   member(Name, List),
        \+ declared_resource(Name, _, _),
        \+ reserved_resource(Name),
        copy_resource(FromRC, ToRC, Name),
        fail
    ;   true
    ).

reserved_resource('$prolog/state.qlf').
reserved_resource('$prolog/options.txt').

copy_resource(FromRC, ToRC, Name) :-
    (   zipper_goto(FromRC, file(Name))
    ->  true
    ;   existence_error(resource, Name)
    ),
    zipper_file_info(FromRC, _Name, Attrs),
    get_dict(time, Attrs, Time),
    setup_call_cleanup(
        zipper_open_current(FromRC, FdIn,
                            [ type(binary),
                              time(Time)
                            ]),
        setup_call_cleanup(
            zipper_open_new_file_in_zip(ToRC, Name, FdOut, []),
            ( feedback('~t~8|~w~t~24|~w~n',
                       [Name, '<Copied from running state>']),
              copy_stream_data(FdIn, FdOut)
            ),
            close(FdOut)),
        close(FdIn)).


		 /*******************************
		 *           OBFUSCATE		*
		 *******************************/

%!  create_mapping(+Options) is det.
%
%   Call hook to obfuscate symbols.

:- multifile prolog:obfuscate_identifiers/1.

create_mapping(Options) :-
    option(obfuscate(true), Options),
    !,
    (   predicate_property(prolog:obfuscate_identifiers(_), number_of_clauses(N)),
        N > 0
    ->  true
    ;   use_module(library(obfuscate))
    ),
    (   catch(prolog:obfuscate_identifiers(Options), E,
              print_message(error, E))
    ->  true
    ;   print_message(warning, failed(obfuscate_identifiers))
    ).
create_mapping(_).

%!  lock_files(+SaveClass) is det.
%
%   When saving as `runtime`, lock all files  such that when running the
%   program the system stops checking existence and modification time on
%   the filesystem.
%
%   @tbd `system` is a poor name.  Maybe use `resource`?

lock_files(runtime) :-
    !,
    '$set_source_files'(system).                % implies from_state
lock_files(_) :-
    '$set_source_files'(from_state).

%!  save_program(+Zipper, +SaveClass, +Options) is det.
%
%   Save the program itself as virtual machine code to Zipper.

save_program(RC, SaveClass, Options) :-
    setup_call_cleanup(
        ( zipper_open_new_file_in_zip(RC, '$prolog/state.qlf', StateFd,
                                      [ zip64(true)
                                      ]),
          current_prolog_flag(access_level, OldLevel),
          set_prolog_flag(access_level, system), % generate system modules
          '$open_wic'(StateFd, Options)
        ),
        ( create_mapping(Options),
          save_modules(SaveClass),
          save_records,
          save_flags,
          save_prompt,
          save_imports,
          save_prolog_flags(Options),
          save_operators(Options),
          save_format_predicates
        ),
        ( '$close_wic',
          set_prolog_flag(access_level, OldLevel),
          close(StateFd)
        )).


                 /*******************************
                 *            MODULES           *
                 *******************************/

save_modules(SaveClass) :-
    forall(special_module(X),
           save_module(X, SaveClass)),
    forall((current_module(X), \+ special_module(X)),
           save_module(X, SaveClass)).

special_module(system).
special_module(user).


%!  prepare_entry_points(+Options)
%
%   Prepare  the  --goal=Goal  and  --toplevel=Goal  options.  Preparing
%   implies autoloading the definition and declaring it _public_ such at
%   it doesn't get obfuscated.

prepare_entry_points(Options) :-
    define_init_goal(Options),
    define_toplevel_goal(Options).

define_init_goal(Options) :-
    option(goal(Goal), Options),
    !,
    entry_point(Goal).
define_init_goal(_).

define_toplevel_goal(Options) :-
    option(toplevel(Goal), Options),
    !,
    entry_point(Goal).
define_toplevel_goal(_).

entry_point(Goal) :-
    define_predicate(Goal),
    (   \+ predicate_property(Goal, built_in),
        \+ predicate_property(Goal, imported_from(_))
    ->  goal_pi(Goal, PI),
        public(PI)
    ;   true
    ).

define_predicate(Head) :-
    '$define_predicate'(Head),
    !.   % autoloader
define_predicate(Head) :-
    strip_module(Head, _, Term),
    functor(Term, Name, Arity),
    throw(error(existence_error(procedure, Name/Arity), _)).

goal_pi(M:G, QPI) :-
    !,
    strip_module(M:G, Module, Goal),
    functor(Goal, Name, Arity),
    QPI = Module:Name/Arity.
goal_pi(Goal, Name/Arity) :-
    functor(Goal, Name, Arity).

%!  prepare_state(+Options) is det.
%
%   Prepare the executable by  running   the  `prepare_state` registered
%   initialization hooks.

prepare_state(_) :-
    forall('$init_goal'(when(prepare_state), Goal, Ctx),
           run_initialize(Goal, Ctx)).

run_initialize(Goal, Ctx) :-
    (   catch(Goal, E, true),
        (   var(E)
        ->  true
        ;   throw(error(initialization_error(E, Goal, Ctx), _))
        )
    ;   throw(error(initialization_error(failed, Goal, Ctx), _))
    ).


                 /*******************************
                 *            AUTOLOAD          *
                 *******************************/

%!  save_autoload(+Options) is det.
%
%   Resolve all autoload dependencies.
%
%   @error existence_error(procedures, List) if undefined(true) is
%   in Options and there are undefined predicates.

save_autoload(Options) :-
    option(autoload(true),  Options, true),
    !,
    setup_call_cleanup(
        current_prolog_flag(autoload, Old),
        prolog_autoload:autoload_all(Options),
        set_prolog_flag(autoload, Old)).
save_autoload(_).


                 /*******************************
                 *             MODULES          *
                 *******************************/

%!  save_module(+Module, +SaveClass)
%
%   Saves a module

save_module(M, SaveClass) :-
    '$qlf_start_module'(M),
    feedback('~n~nMODULE ~w~n', [M]),
    save_unknown(M),
    (   P = (M:_H),
        current_predicate(_, P),
        \+ predicate_property(P, imported_from(_)),
        save_predicate(P, SaveClass),
        fail
    ;   '$qlf_end_part',
        feedback('~n', [])
    ).

save_predicate(P, _SaveClass) :-
    predicate_property(P, foreign),
    !,
    P = (M:H),
    functor(H, Name, Arity),
    feedback('~npre-defining foreign ~w/~d ', [Name, Arity]),
    '$add_directive_wic'('$predefine_foreign'(M:Name/Arity)).
save_predicate(P, SaveClass) :-
    P = (M:H),
    functor(H, F, A),
    feedback('~nsaving ~w/~d ', [F, A]),
    (   (   H = resource(_,_)
        ;   H = resource(_,_,_)
        ),
        SaveClass \== development
    ->  save_attribute(P, (dynamic)),
        (   M == user
        ->  save_attribute(P, (multifile))
        ),
        feedback('(Skipped clauses)', []),
        fail
    ;   true
    ),
    (   no_save(P)
    ->  true
    ;   save_attributes(P),
        \+ predicate_property(P, (volatile)),
        (   nth_clause(P, _, Ref),
            feedback('.', []),
            '$qlf_assert_clause'(Ref, SaveClass),
            fail
        ;   true
        )
    ).

no_save(P) :-
    predicate_property(P, volatile),
    \+ predicate_property(P, dynamic),
    \+ predicate_property(P, multifile).

pred_attrib(meta_predicate(Term), Head, meta_predicate(M:Term)) :-
    !,
    strip_module(Head, M, _).
pred_attrib(Attrib, Head,
            '$set_predicate_attribute'(M:Name/Arity, AttName, Val)) :-
    attrib_name(Attrib, AttName, Val),
    strip_module(Head, M, Term),
    functor(Term, Name, Arity).

attrib_name(dynamic,                dynamic,                true).
attrib_name(volatile,               volatile,               true).
attrib_name(thread_local,           thread_local,           true).
attrib_name(multifile,              multifile,              true).
attrib_name(public,                 public,                 true).
attrib_name(transparent,            transparent,            true).
attrib_name(discontiguous,          discontiguous,          true).
attrib_name(notrace,                trace,                  false).
attrib_name(show_childs,            hide_childs,            false).
attrib_name(built_in,               system,                 true).
attrib_name(nodebug,                hide_childs,            true).
attrib_name(quasi_quotation_syntax, quasi_quotation_syntax, true).
attrib_name(iso,                    iso,                    true).


save_attribute(P, Attribute) :-
    pred_attrib(Attribute, P, D),
    (   Attribute == built_in       % no need if there are clauses
    ->  (   predicate_property(P, number_of_clauses(0))
        ->  true
        ;   predicate_property(P, volatile)
        )
    ;   Attribute == (dynamic)      % no need if predicate is thread_local
    ->  \+ predicate_property(P, thread_local)
    ;   true
    ),
    '$add_directive_wic'(D),
    feedback('(~w) ', [Attribute]).

save_attributes(P) :-
    (   predicate_property(P, Attribute),
        save_attribute(P, Attribute),
        fail
    ;   true
    ).

%       Save status of the unknown flag

save_unknown(M) :-
    current_prolog_flag(M:unknown, Unknown),
    (   Unknown == error
    ->  true
    ;   '$add_directive_wic'(set_prolog_flag(M:unknown, Unknown))
    ).

                 /*******************************
                 *            RECORDS           *
                 *******************************/

save_records :-
    feedback('~nRECORDS~n', []),
    (   current_key(X),
        X \== '$topvar',                        % do not safe toplevel variables
        feedback('~n~t~8|~w ', [X]),
        recorded(X, V, _),
        feedback('.', []),
        '$add_directive_wic'(recordz(X, V, _)),
        fail
    ;   true
    ).


                 /*******************************
                 *            FLAGS             *
                 *******************************/

save_flags :-
    feedback('~nFLAGS~n~n', []),
    (   current_flag(X),
        flag(X, V, V),
        feedback('~t~8|~w = ~w~n', [X, V]),
        '$add_directive_wic'(set_flag(X, V)),
        fail
    ;   true
    ).

save_prompt :-
    feedback('~nPROMPT~n~n', []),
    prompt(Prompt, Prompt),
    '$add_directive_wic'(prompt(_, Prompt)).


                 /*******************************
                 *           IMPORTS            *
                 *******************************/

%!  save_imports
%
%   Save  import  relations.  An  import  relation  is  saved  if  a
%   predicate is imported from a module that is not a default module
%   for the destination module. If  the   predicate  is  dynamic, we
%   always define the explicit import relation to make clear that an
%   assert must assert on the imported predicate.

save_imports :-
    feedback('~nIMPORTS~n~n', []),
    (   predicate_property(M:H, imported_from(I)),
        \+ default_import(M, H, I),
        functor(H, F, A),
        feedback('~t~8|~w:~w/~d <-- ~w~n', [M, F, A, I]),
        '$add_directive_wic'(qsave:restore_import(M, I, F/A)),
        fail
    ;   true
    ).

default_import(To, Head, From) :-
    '$get_predicate_attribute'(To:Head, (dynamic), 1),
    predicate_property(From:Head, exported),
    !,
    fail.
default_import(Into, _, From) :-
    default_module(Into, From).

%!  restore_import(+TargetModule, +SourceModule, +PI) is det.
%
%   Restore import relation. This notably   deals  with imports from
%   the module =user=, avoiding a message  that the predicate is not
%   exported.

restore_import(To, user, PI) :-
    !,
    export(user:PI),
    To:import(user:PI).
restore_import(To, From, PI) :-
    To:import(From:PI).

                 /*******************************
                 *         PROLOG FLAGS         *
                 *******************************/

save_prolog_flags(Options) :-
    feedback('~nPROLOG FLAGS~n~n', []),
    '$current_prolog_flag'(Flag, Value0, _Scope, write, Type),
    \+ no_save_flag(Flag),
    map_flag(Flag, Value0, Value, Options),
    feedback('~t~8|~w: ~w (type ~q)~n', [Flag, Value, Type]),
    '$add_directive_wic'(qsave:restore_prolog_flag(Flag, Value, Type)),
    fail.
save_prolog_flags(_).

no_save_flag(argv).
no_save_flag(os_argv).
no_save_flag(access_level).
no_save_flag(tty_control).
no_save_flag(readline).
no_save_flag(associated_file).
no_save_flag(cpu_count).
no_save_flag(tmp_dir).
no_save_flag(file_name_case_handling).
no_save_flag(hwnd).                     % should be read-only, but comes
                                        % from user-code
map_flag(autoload, true, false, Options) :-
    option(class(runtime), Options, runtime),
    option(autoload(true), Options, true),
    !.
map_flag(_, Value, Value, _).


%!  restore_prolog_flag(+Name, +Value, +Type)
%
%   Deal  with  possibly   protected    flags   (debug_on_error  and
%   report_error are protected flags for the runtime kernel).

restore_prolog_flag(Flag, Value, _Type) :-
    current_prolog_flag(Flag, Value),
    !.
restore_prolog_flag(Flag, Value, _Type) :-
    current_prolog_flag(Flag, _),
    !,
    catch(set_prolog_flag(Flag, Value), _, true).
restore_prolog_flag(Flag, Value, Type) :-
    create_prolog_flag(Flag, Value, [type(Type)]).


                 /*******************************
                 *           OPERATORS          *
                 *******************************/

%!  save_operators(+Options) is det.
%
%   Save operators for all modules.   Operators for =system= are
%   not saved because these are read-only anyway.

save_operators(Options) :-
    !,
    option(op(save), Options, save),
    feedback('~nOPERATORS~n', []),
    forall(current_module(M), save_module_operators(M)),
    feedback('~n', []).
save_operators(_).

save_module_operators(system) :- !.
save_module_operators(M) :-
    forall('$local_op'(P,T,M:N),
           (   feedback('~n~t~8|~w ', [op(P,T,M:N)]),
               '$add_directive_wic'(op(P,T,M:N))
           )).


                 /*******************************
                 *       FORMAT PREDICATES      *
                 *******************************/

save_format_predicates :-
    feedback('~nFORMAT PREDICATES~n', []),
    current_format_predicate(Code, Head),
    qualify_head(Head, QHead),
    D = format_predicate(Code, QHead),
    feedback('~n~t~8|~w ', [D]),
    '$add_directive_wic'(D),
    fail.
save_format_predicates.

qualify_head(T, T) :-
    functor(T, :, 2),
    !.
qualify_head(T, user:T).


                 /*******************************
                 *       FOREIGN LIBRARIES      *
                 *******************************/

%!  save_foreign_libraries(+Archive, +Options) is det.
%
%   Save current foreign libraries into the archive.

save_foreign_libraries(RC, Options) :-
    option(foreign(save), Options),
    !,
    current_prolog_flag(arch, HostArch),
    feedback('~nHOST(~w) FOREIGN LIBRARIES~n', [HostArch]),
    save_foreign_libraries1(HostArch, RC, Options).
save_foreign_libraries(RC, Options) :-
    option(foreign(arch(Archs)), Options),
    !,
    forall(member(Arch, Archs),
           ( feedback('~n~w FOREIGN LIBRARIES~n', [Arch]),
             save_foreign_libraries1(Arch, RC, Options)
           )).
save_foreign_libraries(_, _).

save_foreign_libraries1(Arch, RC, _Options) :-
    forall(current_foreign_library(FileSpec, _Predicates),
           ( find_foreign_library(Arch, FileSpec, EntryName, File, Time),
             term_to_atom(EntryName, Name),
             zipper_append_file(RC, Name, File, [time(Time)])
           )).

%!  find_foreign_library(+Architecture, +FileSpec, -EntryName, -File, -Time)
%!								is det.
%
%   Find  the  shared  object  specified  by   FileSpec  for  the  named
%   Architecture. EntryName will be the  name   of  the  file within the
%   saved state archive. If posible, the   shared  object is stripped to
%   reduce its size. This  is  achieved   by  calling  =|strip  -o <tmp>
%   <shared-object>|=. Note that (if stripped) the  file is a Prolog tmp
%   file and will be deleted on halt.
%
%   @bug    Should perform OS search on failure

find_foreign_library(Arch, FileSpec, shlib(Arch,Name), SharedObject, Time) :-
    FileSpec = foreign(Name),
    (   catch(arch_find_shlib(Arch, FileSpec, File),
              E,
              print_message(error, E)),
        exists_file(File)
    ->  true
    ;   throw(error(existence_error(architecture_shlib(Arch), FileSpec),_))
    ),
    time_file(File, Time),
    strip_file(File, SharedObject).

%!  strip_file(+File, -Stripped) is det.
%
%   Try to strip File. Unify Stripped with   File if stripping fails for
%   some reason.

strip_file(File, Stripped) :-
    absolute_file_name(path(strip), Strip,
                       [ access(execute),
                         file_errors(fail)
                       ]),
    tmp_file(shared, Stripped),
    (   catch(do_strip_file(Strip, File, Stripped), E,
              (print_message(warning, E), fail))
    ->  true
    ;   print_message(warning, qsave(strip_failed(File))),
        fail
    ),
    !.
strip_file(File, File).

do_strip_file(Strip, File, Stripped) :-
    format(atom(Cmd), '"~w" -o "~w" "~w"',
           [Strip, Stripped, File]),
    shell(Cmd),
    exists_file(Stripped).

%!  qsave:arch_shlib(+Architecture, +FileSpec, -File) is det.
%
%   This is a user defined hook called by qsave_program/2. It is used to
%   find a shared library  for  the   specified  Architecture,  named by
%   FileSpec. FileSpec is of  the   form  foreign(Name), a specification
%   usable by absolute_file_name/2. The predicate should unify File with
%   the absolute path for the  shared   library  that corresponds to the
%   specified Architecture.
%
%   If  this  predicate  fails  to  find    a  file  for  the  specified
%   architecture an `existence_error` is thrown.

:- multifile arch_shlib/3.

arch_find_shlib(Arch, FileSpec, File) :-
    arch_shlib(Arch, FileSpec, File),
    !.
arch_find_shlib(Arch, FileSpec, File) :-
    current_prolog_flag(arch, Arch),
    absolute_file_name(FileSpec,
                       [ file_type(executable),
                         access(read),
                         file_errors(fail)
                       ], File),
    !.
arch_find_shlib(Arch, foreign(Base), File) :-
    current_prolog_flag(arch, Arch),
    current_prolog_flag(windows, true),
    current_prolog_flag(executable, WinExe),
    prolog_to_os_filename(Exe, WinExe),
    file_directory_name(Exe, BinDir),
    file_name_extension(Base, dll, DllFile),
    atomic_list_concat([BinDir, /, DllFile], File),
    exists_file(File).


                 /*******************************
                 *             UTIL             *
                 *******************************/

open_map(Options) :-
    option(map(Map), Options),
    !,
    open(Map, write, Fd),
    asserta(verbose(Fd)).
open_map(_) :-
    retractall(verbose(_)).

close_map :-
    retract(verbose(Fd)),
    close(Fd),
    !.
close_map.

feedback(Fmt, Args) :-
    verbose(Fd),
    !,
    format(Fd, Fmt, Args).
feedback(_, _).


check_options([]) :- !.
check_options([Var|_]) :-
    var(Var),
    !,
    throw(error(domain_error(save_options, Var), _)).
check_options([Name=Value|T]) :-
    !,
    (   save_option(Name, Type, _Comment)
    ->  (   must_be(Type, Value)
        ->  check_options(T)
        ;   throw(error(domain_error(Type, Value), _))
        )
    ;   throw(error(domain_error(save_option, Name), _))
    ).
check_options([Term|T]) :-
    Term =.. [Name,Arg],
    !,
    check_options([Name=Arg|T]).
check_options([Var|_]) :-
    throw(error(domain_error(save_options, Var), _)).
check_options(Opt) :-
    throw(error(domain_error(list, Opt), _)).


%!  zipper_append_file(+Zipper, +Name, +File, +Options) is det.
%
%   Append the content of File under Name to the open Zipper.

zipper_append_file(_, Name, _, _) :-
    saved_resource_file(Name),
    !.
zipper_append_file(_, _, File, _) :-
    source_file(File),
    !.
zipper_append_file(Zipper, Name, File, Options) :-
    (   option(time(_), Options)
    ->  Options1 = Options
    ;   time_file(File, Stamp),
        Options1 = [time(Stamp)|Options]
    ),
    setup_call_cleanup(
        open(File, read, In, [type(binary)]),
        setup_call_cleanup(
            zipper_open_new_file_in_zip(Zipper, Name, Out, Options1),
            copy_stream_data(In, Out),
            close(Out)),
        close(In)),
    assertz(saved_resource_file(Name)).

%!  zipper_add_directory(+Zipper, +Name, +Dir, +Options) is det.
%
%   Add a directory entry. Dir  is  only   used  if  there  is no option
%   time(Stamp).

zipper_add_directory(Zipper, Name, Dir, Options) :-
    (   option(time(Stamp), Options)
    ->  true
    ;   time_file(Dir, Stamp)
    ),
    atom_concat(Name, /, DirName),
    (   saved_resource_file(DirName)
    ->  true
    ;   setup_call_cleanup(
            zipper_open_new_file_in_zip(Zipper, DirName, Out,
                                        [ method(store),
                                          time(Stamp)
                                        | Options
                                        ]),
            true,
            close(Out)),
        assertz(saved_resource_file(DirName))
    ).

add_parent_dirs(Zipper, Name, Dir, Options) :-
    (   option(time(Stamp), Options)
    ->  true
    ;   time_file(Dir, Stamp)
    ),
    file_directory_name(Name, Parent),
    (   Parent \== Name
    ->  add_parent_dirs(Zipper, Parent, [time(Stamp)|Options])
    ;   true
    ).

add_parent_dirs(_, '.', _) :-
    !.
add_parent_dirs(Zipper, Name, Options) :-
    zipper_add_directory(Zipper, Name, _, Options),
    file_directory_name(Name, Parent),
    (   Parent \== Name
    ->  add_parent_dirs(Zipper, Parent, Options)
    ;   true
    ).


%!  zipper_append_directory(+Zipper, +Name, +Dir, +Options) is det.
%
%   Append the content of  Dir  below   Name  in  the  resource archive.
%   Options:
%
%     - include(+Patterns)
%     Only add entries that match an element from Patterns using
%     wildcard_match/2.
%     - exclude(+Patterns)
%     Ignore entries that match an element from Patterns using
%     wildcard_match/2.
%
%   @tbd Process .gitignore.  There also seem to exists other
%   standards for this.

zipper_append_directory(Zipper, Name, Dir, Options) :-
    exists_directory(Dir),
    !,
    add_parent_dirs(Zipper, Name, Dir, Options),
    zipper_add_directory(Zipper, Name, Dir, Options),
    directory_files(Dir, Members),
    forall(member(M, Members),
           (   reserved(M)
           ->  true
           ;   ignored(M, Options)
           ->  true
           ;   atomic_list_concat([Dir,M], /, Entry),
               atomic_list_concat([Name,M], /, Store),
               catch(zipper_append_directory(Zipper, Store, Entry, Options),
                     E,
                     print_message(warning, E))
           )).
zipper_append_directory(Zipper, Name, File, Options) :-
    zipper_append_file(Zipper, Name, File, Options).

reserved(.).
reserved(..).

%!  ignored(+File, +Options) is semidet.
%
%   Ignore File if there is an  include(Patterns) option that does *not*
%   match File or an exclude(Patterns) that does match File.

ignored(File, Options) :-
    option(include(Patterns), Options),
    \+ ( (   is_list(Patterns)
         ->  member(Pattern, Patterns)
         ;   Pattern = Patterns
         ),
         glob_match(Pattern, File)
       ),
    !.
ignored(File, Options) :-
    option(exclude(Patterns), Options),
    (   is_list(Patterns)
    ->  member(Pattern, Patterns)
    ;   Pattern = Patterns
    ),
    glob_match(Pattern, File),
    !.

glob_match(Pattern, File) :-
    current_prolog_flag(file_name_case_handling, case_sensitive),
    !,
    wildcard_match(Pattern, File).
glob_match(Pattern, File) :-
    wildcard_match(Pattern, File, [case_sensitive(false)]).


                /********************************
                *     SAVED STATE GENERATION    *
                *********************************/

%!  qsave_toplevel
%
%   Called to handle `-c file` compilaton.

:- public
    qsave_toplevel/0.

qsave_toplevel :-
    current_prolog_flag(os_argv, Argv),
    qsave_options(Argv, Files, Options),
    set_on_error(Options),
    '$cmd_option_val'(compileout, Out),
    user:consult(Files),
    maybe_exit_on_errors,
    qsave_program(Out, user:Options).

set_on_error(Options) :-
    option(on_error(_), Options), !.
set_on_error(_Options) :-
    set_prolog_flag(on_error, status).

maybe_exit_on_errors :-
    '$exit_code'(Code),
    (   Code =\= 0
    ->  halt
    ;   true
    ).

qsave_options([], [], []).
qsave_options([--|_], [], []) :-
    !.
qsave_options(['-c'|T0], Files, Options) :-
    !,
    argv_files(T0, T1, Files, FilesT),
    qsave_options(T1, FilesT, Options).
qsave_options([O|T0], Files, [Option|T]) :-
    string_concat(--, Opt, O),
    split_string(Opt, =, '', [NameS|Rest]),
    split_string(NameS, '-', '', NameParts),
    atomic_list_concat(NameParts, '_', Name),
    qsave_option(Name, OptName, Rest, Value),
    !,
    Option =.. [OptName, Value],
    qsave_options(T0, Files, T).
qsave_options([_|T0], Files, T) :-
    qsave_options(T0, Files, T).

argv_files([], [], Files, Files).
argv_files([H|T], [H|T], Files, Files) :-
    sub_atom(H, 0, _, _, -),
    !.
argv_files([H|T0], T, [H|Files0], Files) :-
    argv_files(T0, T, Files0, Files).

%!  qsave_option(+Name, +ValueStrings, -Value) is semidet.

qsave_option(Name, Name, [], true) :-
    save_option(Name, boolean, _),
    !.
qsave_option(NoName, Name, [], false) :-
    atom_concat('no_', Name, NoName),
    save_option(Name, boolean, _),
    !.
qsave_option(Name, Name, ValueStrings, Value) :-
    save_option(Name, Type, _),
    !,
    atomics_to_string(ValueStrings, "=", ValueString),
    convert_option_value(Type, ValueString, Value).
qsave_option(Name, Name, _Chars, _Value) :-
    existence_error(save_option, Name).

convert_option_value(integer, String, Value) :-
    (   number_string(Value, String)
    ->  true
    ;   sub_string(String, 0, _, 1, SubString),
        sub_string(String, _, 1, 0, Suffix0),
        downcase_atom(Suffix0, Suffix),
        number_string(Number, SubString),
        suffix_multiplier(Suffix, Multiplier)
    ->  Value is Number * Multiplier
    ;   domain_error(integer, String)
    ).
convert_option_value(callable, String, Value) :-
    term_string(Value, String).
convert_option_value(atom, String, Value) :-
    atom_string(Value, String).
convert_option_value(boolean, String, Value) :-
    atom_string(Value, String).
convert_option_value(oneof(_), String, Value) :-
    atom_string(Value, String).
convert_option_value(ground, String, Value) :-
    atom_string(Value, String).
convert_option_value(qsave_foreign_option, "save", save).
convert_option_value(qsave_foreign_option, StrArchList, arch(ArchList)) :-
    split_string(StrArchList, ",", ", \t", StrArchList1),
    maplist(atom_string, ArchList, StrArchList1).

suffix_multiplier(b, 1).
suffix_multiplier(k, 1024).
suffix_multiplier(m, 1024 * 1024).
suffix_multiplier(g, 1024 * 1024 * 1024).


                 /*******************************
                 *            MESSAGES          *
                 *******************************/

:- multifile prolog:message/3.

prolog:message(no_resource(Name, File)) -->
    [ 'Could not find resource ~w on ~w or system resources'-
      [Name, File] ].
prolog:message(qsave(nondet)) -->
    [ 'qsave_program/2 succeeded with a choice point'-[] ].