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    ->setup_call_cleanup(
  172          ( '$current_source_module'(OldM),
  173            '$set_source_module'(NC)
  174          ),
  175          walk_called(G, C, M, Opts),
  176          '$set_source_module'(OldM))
  177    ; true
  178    ).
  179
  180walk_called(G, _, _, _) :-
  181    var(G),
  182    !.
  183walk_called(true, _, _, _) :- !.
  184walk_called(@(G,CM), C, N, Opts) :-
  185    !,
  186    strip_module(N:G, M, H),
  187    walk_called_mod(H, C, M, CM, Opts).
  188walk_called(M:G, C, _, Opts) :-
  189    !,
  190    walk_called_mod(G, C, M, M, Opts).
  191walk_called((A,B), C, M, O) :-
  192    !,
  193    walk_called(A, C, M, O),
  194    walk_called(B, C, M, O).
  195walk_called((A->B), C, M, O) :-
  196    !,
  197    walk_called(A, C, M, O),
  198    walk_called(B, C, M, O).
  199walk_called((A*->B), C, M, O) :-
  200    !,
  201    walk_called(A, C, M, O),
  202    walk_called(B, C, M, O).
  203walk_called(\+(A), C, M, O) :-
  204    !,
  205    \+ \+ walk_called(A, C, M, O).
  206walk_called((A;B), C, M, O) :-
  207    !,
  208    term_variables(A, VA),
  209    term_variables(B, VB),
  210    sort(VA, SA),
  211    sort(VB, SB),
  212    ord_union(SA, SB, L),
  213    findall(L-V-Att,
  214            ( member(E, [A, B]),
  215              walk_called(E, C, M, O),
  216              term_attvars(L, V),
  217              maplist(get_attrs, V, Att)
  218            ), LVA),
  219    maplist(put_attrs_(L), LVA).
  220walk_called(Goal, C, M, O) :-
  221    walk_called_3(Goal, C, M, O),
  222    fail.
  223walk_called(Goal, C, M, O) :-
  224    % \+/1 to revert unintended bindings:
  225    ignore(\+ walk_called_ontrace(Goal, C, M, O)),
  226    option(trace_variables(TraceVars), O),
  227    maplist(trace_var(M:Goal), TraceVars).
  228
  229put_attrs_(L, L-V-A) :- maplist(put_attrs, V, A).
  230
  231walk_called_ontrace(Goal, Caller, M, Opts) :-
  232    option(trace_reference(To), Opts),
  233    To \== (-),
  234    (   subsumes_term(To, M:Goal)
  235    ->  M2 = M
  236    ;   predicate_property(M:Goal, implementation_module(M2)),
  237        subsumes_term(To, M2:Goal)
  238    ),
  239    ignore(option(module(M), Opts, M)),
  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)