1/*  Part of Extended Tools for SWI-Prolog
    2
    3    Author:        Edison Mera
    4    E-mail:        efmera@gmail.com
    5    WWW:           https://github.com/edisonm/xtools
    6    Copyright (C): 2017, Process Design Center, Breda, The Netherlands.
    7    All rights reserved.
    8
    9    Redistribution and use in source and binary forms, with or without
   10    modification, are permitted provided that the following conditions
   11    are met:
   12
   13    1. Redistributions of source code must retain the above copyright
   14       notice, this list of conditions and the following disclaimer.
   15
   16    2. Redistributions in binary form must reproduce the above copyright
   17       notice, this list of conditions and the following disclaimer in
   18       the documentation and/or other materials provided with the
   19       distribution.
   20
   21    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
   22    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
   23    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
   24    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
   25    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
   26    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
   27    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
   28    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
   29    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
   30    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
   31    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
   32    POSSIBILITY OF SUCH DAMAGE.
   33*/
   34
   35:- module(codewalk_clause, []).   36
   37:- use_module(library(prolog_xref), []).   38:- use_module(library(apply)).   39:- use_module(library(lists)).   40:- use_module(library(option)).   41:- use_module(library(ordsets)).   42:- use_module(library(prolog_metainference)).   43:- use_module(library(assertions)).   44:- use_module(library(extend_args)).   45:- use_module(library(extra_location)).   46:- use_module(library(file_clause)).   47:- use_module(library(from_utils)).   48:- use_module(library(meta_args)).   49:- use_module(library(option_utils)).   50:- use_module(library(with_location)).   51:- use_module(library(condconc)).   52:- init_expansors.   53
   54:- multifile
   55    codewalk:walk_code/2.   56
   57codewalk:walk_code(clause, Options1) :-
   58    foldl(select_option_default,
   59          [on_trace(OnTrace)-(codewalk:true_3),
   60           on_head(OnHead)-(codewalk:true_2),
   61           trace_reference(To)-To,
   62           undefined(Undefined)-ignore,
   63           trace_variables(TraceVars)-[],
   64           concurrent(Concurrent)-true,
   65           walkextras(Extras)-[initialization,
   66                               declaration,
   67                               asrparts([body])],
   68           variable_names(VNL)-VNL],
   69          Options1, Options),
   70    option(module(Module), Options, Module),
   71    option_files(Options, FileD),
   72    Data = data{from:_,
   73                on_trace:OnTrace,
   74                on_head:OnHead,
   75                module:Module,
   76                trace_variables:TraceVars,
   77                trace_reference:To,
   78                concurrent:Concurrent,
   79                undefined:Undefined},
   80    cond_maplist(Concurrent, walk_extras_c(FileD, Data), [clause|Extras]).
   81
   82walk_extras_c(FileD, Opts, Extra) :-
   83    walk_extras_(Extra, FileD, Opts).
   84
   85walk_extras_(clause,         FileD, Opts) :- walk_clause(              FileD, Opts).
   86walk_extras_(initialization, FileD, Opts) :- walk_from_initialization( FileD, Opts).
   87walk_extras_(declaration,    FileD, Opts) :- walk_from_loc_declaration(FileD, Opts).
   88walk_extras_(asrparts(L),    FileD, Opts) :- walk_from_assertion(      FileD, Opts, L).
   89
   90walk_from_initialization(FileD, Opts) :-
   91    forall(( '$init_goal'(_File, Goal, File:Line),
   92             get_dict(File, FileD, _),
   93             From = file(File, Line, -1, _),
   94             option(from(From), Opts)
   95           ),
   96           walk_head_body('<initialization>', Goal, Opts)).
   97
   98walk_from_loc_declaration(FileD, Opts) :-
   99    forall(( option(from(From), Opts),
  100             loc_declaration(Body, M, body, From),
  101             from_to_file(From, File),
  102             get_dict(File, FileD, _)
  103           ),
  104           walk_head_body('<declaration>', M:Body, Opts)).
  105
  106current_assertion_goal(FileD, Opts, AsrPartL, M:Head, CM:Goal) :-
  107    assertions:asr_head_prop(Asr, HM, Head, _, _, VNL, _, AFrom),
  108    from_to_file(AFrom, File),
  109    get_dict(File, FileD, _),
  110    b_setval('$variable_names', VNL),
  111    predicate_property(HM:Head, implementation_module(M)),
  112    member(AsrPart, AsrPartL),
  113    option(from(From), Opts),
  114    assertion_goal(AsrPart, Asr, Goal, CM, From),
  115    option(trace_variables(TraceVars), Opts),
  116    maplist(trace_var(M:Head), TraceVars).
  117
  118walk_from_assertion(FileD, Opts, AsrPartL) :-
  119    forall(current_assertion_goal(FileD, Opts, AsrPartL, Head, Goal),
  120           walk_head_body('<assertion>'(Head), Goal, Opts)).
  121
  122assertion_goal(AsrPart, Asr, Prop, PM, From) :-
  123    member(AsrPart-PartL,
  124           [head-[head],
  125            body-[comp, call, succ, glob]]),
  126    member(Part, PartL),
  127    % For glob, actually is arg(1, Prop, HM:Head), but we keep it uninstantiated for optimization
  128    curr_prop_asr(Part, PM:Prop, From, Asr).
  129
  130walk_clause(FileD, Opts) :-
  131    option(trace_variables(TraceVars), Opts),
  132    option(from(From), Opts),
  133    option(concurrent(Concurrent), Opts),
  134    collect_file_clause_db,
  135    cond_forall(
  136        Concurrent,
  137        get_dict(File, FileD, _),
  138        walk_clause_file(File, TraceVars, From, Opts)).
  139
  140walk_clause_file(File, TraceVars, From, Opts) :-
  141        forall(file_clause(File, Head, Body, From),
  142               ( maplist(trace_var(Head), TraceVars),
  143                 walk_head_body(Head, Body, Opts)
  144               )).
  145
  146trace_var(Goal, TV) :- var_trace(TV, Goal).
  147
  148var_trace(non_fresh, Head) :-
  149    term_variables(Head, Vars),
  150    '$expand':mark_vars_non_fresh(Vars).
  151var_trace(meta_arg, Head) :-
  152    mark_meta_arguments(Head).
  153
  154walk_head_body(Head, Body, Opts) :-
  155    option(on_head(OnHead), Opts),
  156    option(from(From), Opts),
  157    ignore(call(OnHead, Head, From)),
  158    with_location(From, walk_called(Body, Head, user, Opts)),
  159    !.
  160walk_head_body(Head, Body, _) :-
  161    writeln(user_error, walk_head_body(Head, Body, -)),
  162    fail.
  163
  164walk_called_mod(G, C, M, CM, Opts) :-
  165    ( atom(M),
  166      ( atom(CM)
  167      ->NC = CM
  168      ; var(CM) % We know the predicate being called, but not the context, assume user
  169      ->NC = user
  170      )
  171    ->ignore(option(module(NC), Opts, NC)),
  172      setup_call_cleanup(
  173          ( '$current_source_module'(OldM),
  174            '$set_source_module'(NC)
  175          ),
  176          walk_called(G, C, M, Opts),
  177          '$set_source_module'(OldM))
  178    ; true
  179    ).
  180
  181walk_called(G, _, _, _) :-
  182    var(G),
  183    !.
  184walk_called(true, _, _, _) :- !.
  185walk_called(@(G,CM), C, N, Opts) :-
  186    !,
  187    strip_module(N:G, M, H),
  188    walk_called_mod(H, C, M, CM, Opts).
  189walk_called(M:G, C, _, Opts) :-
  190    !,
  191    walk_called_mod(G, C, M, M, Opts).
  192walk_called((A,B), C, M, O) :-
  193    !,
  194    walk_called(A, C, M, O),
  195    walk_called(B, C, M, O).
  196walk_called((A->B), C, M, O) :-
  197    !,
  198    walk_called(A, C, M, O),
  199    walk_called(B, C, M, O).
  200walk_called((A*->B), C, M, O) :-
  201    !,
  202    walk_called(A, C, M, O),
  203    walk_called(B, C, M, O).
  204walk_called(\+(A), C, M, O) :-
  205    !,
  206    \+ \+ walk_called(A, C, M, O).
  207walk_called((A;B), C, M, O) :-
  208    !,
  209    term_variables(A, VA),
  210    term_variables(B, VB),
  211    sort(VA, SA),
  212    sort(VB, SB),
  213    ord_union(SA, SB, L),
  214    findall(L-V-Att,
  215            ( member(E, [A, B]),
  216              walk_called(E, C, M, O),
  217              term_attvars(L, V),
  218              maplist(get_attrs, V, Att)
  219            ), LVA),
  220    maplist(put_attrs_(L), LVA).
  221walk_called(Goal, C, M, O) :-
  222    walk_called_3(Goal, C, M, O),
  223    fail.
  224walk_called(Goal, C, M, O) :-
  225    % \+/1 to revert unintended bindings:
  226    ignore(\+ walk_called_ontrace(Goal, C, M, O)),
  227    option(trace_variables(TraceVars), O),
  228    maplist(trace_var(M:Goal), TraceVars).
  229
  230put_attrs_(L, L-V-A) :- maplist(put_attrs, V, A).
  231
  232walk_called_ontrace(Goal, Caller, M, Opts) :-
  233    option(trace_reference(To), Opts),
  234    To \== (-),
  235    (   subsumes_term(To, M:Goal)
  236    ->  M2 = M
  237    ;   predicate_property(M:Goal, implementation_module(M2)),
  238        subsumes_term(To, M2:Goal)
  239    ),
  240    option(on_trace(OnTrace), Opts),
  241    option(from(From), Opts),
  242    call(OnTrace, M2:Goal, Caller, From).
  243
  244walk_called_3(Goal, _, M, Opts) :-
  245    (   predicate_property(M:Goal, implementation_module(IM)),
  246        prolog:called_by(Goal, IM, M, Called)
  247    ;   prolog:called_by(Goal, Called)
  248    ),
  249    Called \== [],
  250    !,
  251    walk_called_by(Called, M:Goal, M, Opts).
  252walk_called_3(Meta, Caller, M, Opts) :-
  253    (   inferred_meta_predicate(M:Meta, Head)
  254    ;   predicate_property(M:Meta, meta_predicate(Head))
  255    ),
  256    !,
  257    mark_args_non_fresh(1, Head, Meta),
  258    '$current_source_module'(CM),
  259    walk_meta_call(1, Head, Meta, Caller, CM, Opts).
  260walk_called_3(Goal, _, Module, _) :-
  261    nonvar(Module),
  262    '$get_predicate_attribute'(Module:Goal, defined, 1),
  263    !.
  264walk_called_3(Goal, Caller, Module, Opts) :-
  265    callable(Goal),
  266    nonvar(Module),
  267    !,
  268    undefined(Module:Goal, Caller, Opts).
  269walk_called_3(_, _, _, _).
  270
  271undefined(_, _, Opts) :-
  272    option(undefined(ignore), Opts),
  273    !.
  274undefined(Goal, _, _) :-
  275    predicate_property(Goal, autoload(_)),
  276    !.
  277undefined(Goal, Caller, Opts) :-
  278    option(undefined(trace), Opts),
  279    option(on_trace(OnTrace), Opts),
  280    option(from(From), Opts),
  281    call(OnTrace, Goal, Caller, From),
  282    fail.
  283undefined(_, _, _).
  284
  285walk_called_by([], _, _, _).
  286walk_called_by([H|T], C, CM, O) :-
  287    (   H = G+N
  288    ->  (   extend(G, N, G1, O)
  289        ->  walk_called(G1, C, CM, O)
  290        ;   true
  291        )
  292    ;   walk_called(H, C, CM, O)
  293    ),
  294    walk_called_by(T, C, CM, O).
  295
  296walk_meta_call(I, Head, Meta, Caller, M, Opts) :-
  297    arg(I, Head, AS),
  298    !,
  299    (   integer(AS)
  300    ->  arg(I, Meta, MA),
  301        ( extend(MA, AS, Goal, Opts)
  302        ->walk_called(Goal, Caller, M, Opts)
  303        ; true
  304        )
  305    ;   AS == (^)
  306    ->  arg(I, Meta, MA),
  307        remove_quantifier(MA, Goal, M, MG),
  308        walk_called(Goal, Caller, MG, Opts)
  309    ;   AS == (//)
  310    ->  arg(I, Meta, DCG),
  311        walk_dcg_body(DCG, Caller, M, Opts)
  312    ;   true
  313    ),
  314    succ(I, I2),
  315    walk_meta_call(I2, Head, Meta, Caller, M, Opts).
  316walk_meta_call(_, _, _, _, _, _).
  317
  318mark_args_non_fresh(I, Head, Meta) :-
  319    arg(I, Head, AS),
  320    !,
  321    ( ( integer(AS)
  322      ; AS == (^)
  323      ; AS == (//)
  324      )
  325    ->true
  326    ; arg(I, Meta, MA),
  327      term_variables(MA, Vars),
  328      '$expand':mark_vars_non_fresh(Vars)
  329    ),
  330    succ(I, I2),
  331    mark_args_non_fresh(I2, Head, Meta).
  332mark_args_non_fresh(_, _, _).
  333
  334walk_dcg_body(Var, _, _, _) :-
  335    var(Var),
  336    !.
  337walk_dcg_body([], _, _, _) :- !.
  338walk_dcg_body([_|_], _, _, _) :- !.
  339walk_dcg_body(String, _, _, _) :-
  340    string(String),
  341    !.
  342walk_dcg_body(!, _, _, _) :- !.
  343walk_dcg_body(M:G, C, _, O) :-
  344    !,
  345    (   nonvar(M)
  346    ->  walk_dcg_body(G, C, M, O)
  347    ;   fail
  348    ).
  349walk_dcg_body((A,B), C, M, O) :-
  350    !,
  351    walk_dcg_body(A, C, M, O),
  352    walk_dcg_body(B, C, M, O).
  353walk_dcg_body((A->B), C, M, O) :-
  354    !,
  355    walk_dcg_body(A, C, M, O),
  356    walk_dcg_body(B, C, M, O).
  357walk_dcg_body((A*->B), C, M, O) :-
  358    !,
  359    walk_dcg_body(A, C, M, O),
  360    walk_dcg_body(B, C, M, O).
  361walk_dcg_body((A;B), C, M, O) :-
  362    !,
  363    \+ \+ walk_dcg_body(A, C, M, O),
  364    \+ \+ walk_dcg_body(B, C, M, O).
  365walk_dcg_body((A|B), C, M, O) :-
  366    !,
  367    \+ \+ walk_dcg_body(A, C, M, O),
  368    \+ \+ walk_dcg_body(B, C, M, O).
  369walk_dcg_body({G}, C, M, O) :-
  370    !,
  371    walk_called(G, C, M, O).
  372walk_dcg_body(G, C, M, O) :-
  373    extend_args(G, [_, _], G2),
  374    walk_called(G2, C, M, O).
  375
  376extend(Goal, _, _, _) :-
  377    var(Goal),
  378    !,
  379    fail.
  380extend(Goal, 0, Goal, _) :- !.
  381extend(M:Goal, N, M:GoalEx, Opts) :-
  382    !,
  383    extend(Goal, N, GoalEx, Opts).
  384extend(Goal, N, GoalEx, _) :-
  385    callable(Goal),
  386    !,
  387    length(Extra, N),
  388    '$expand':mark_vars_non_fresh(Extra),
  389    extend_args(Goal, Extra, GoalEx).
  390extend(Goal, _, _, Opts) :-
  391    option(from(From), Opts),
  392    print_message(error, error(type_error(callable, Goal), From)),
  393    fail.
  394
  395remove_quantifier(Goal, Goal, M, M) :-
  396    var(Goal),
  397    !.
  398remove_quantifier(_^Goal1, Goal, M1, M) :-
  399    !,
  400    remove_quantifier(Goal1, Goal, M1, M).
  401remove_quantifier(M1:Goal1, Goal, _, M) :-
  402    !,
  403    remove_quantifier(Goal1, Goal, M1, M).
  404remove_quantifier(Goal, Goal, M, M)