1/*  Part of Extended Tools for SWI-Prolog
    2
    3    Author:        Edison Mera Menendez
    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(assertions)).   40:- use_module(library(extend_args)).   41:- use_module(library(extra_location)).   42:- use_module(library(from_utils)).   43:- use_module(library(meta_args)).   44:- use_module(library(option_utils)).   45:- use_module(library(concurrent_forall)).   46
   47codewalk:walk_code(clause, Options1) :-
   48    foldl(select_option_default,
   49          [on_trace(OnTrace)-(codewalk:true_3),
   50           on_head(OnHead)-(codewalk:true_2),
   51           trace_reference(To)-To,
   52           undefined(Undefined)-ignore,
   53           trace_variables(TraceVars)-[],
   54           walkextras(Extras)-[initialization,
   55                               declaration,
   56                               asrparts([body])],
   57           variable_names(VNL)-VNL],
   58          Options1, Options),
   59    option_files(Options, FileD),
   60    Data = data{from:_,
   61                on_trace:OnTrace,
   62                on_head:OnHead,
   63                trace_variables:TraceVars,
   64                trace_reference:To,
   65                undefined:Undefined},
   66    concurrent_maplist(walk_extras_c(FileD, Data), [clause|Extras]).
   67
   68walk_extras_c(FileD, Opts, Extra) :-
   69    walk_extras_(Extra, FileD, Opts).
   70
   71walk_extras_(clause,         FileD, Opts) :- walk_clause(              FileD, Opts).
   72walk_extras_(initialization, FileD, Opts) :- walk_from_initialization( FileD, Opts).
   73walk_extras_(declaration,    FileD, Opts) :- walk_from_loc_declaration(FileD, Opts).
   74walk_extras_(asrparts(L),    FileD, Opts) :- walk_from_assertion(      FileD, Opts, L).
   75
   76walk_from_initialization(FileD, Opts) :-
   77    forall(( '$init_goal'(_File, Goal, SourceLocation),
   78             ( SourceLocation = File:Line
   79             ->get_dict(File, FileD, _),
   80               From = file(File, Line, -1, _),
   81               option(from(From), Opts)
   82             ; true
   83             )
   84           ),
   85           walk_head_body('<initialization>', Goal, Opts)).
   86
   87walk_from_loc_declaration(FileD, Opts) :-
   88    forall(( option(from(From), Opts),
   89             loc_declaration(Body, M, body, From),
   90             from_to_file(From, File),
   91             get_dict(File, FileD, _)
   92           ),
   93           walk_head_body('<declaration>', M:Body, Opts)).
   94
   95current_assertion_goal(FileD, Opts, AsrPartL, M:Head, CM:Goal) :-
   96    assertions:asr_head_prop(Asr, HM, Head, _, _, VNL, AFrom),
   97    from_to_file(AFrom, File),
   98    get_dict(File, FileD, _),
   99    b_setval('$variable_names', VNL),
  100    predicate_property(HM:Head, implementation_module(M)),
  101    member(AsrPart, AsrPartL),
  102    option(from(From), Opts),
  103    assertion_goal(AsrPart, Asr, Goal, CM, From),
  104    option(trace_variables(TraceVars), Opts),
  105    maplist(trace_var(M:Head), TraceVars).
  106
  107walk_from_assertion(FileD, Opts, AsrPartL) :-
  108    forall(current_assertion_goal(FileD, Opts, AsrPartL, Head, Goal),
  109           walk_head_body('<assertion>'(Head), Goal, Opts)).
  110
  111assertion_goal(AsrPart, Asr, Prop, PM, From) :-
  112    member(AsrPart-PartL,
  113           [head-[head],
  114            body-[comp, call, succ, glob]]),
  115    member(Part, PartL),
  116    % For glob, actually is arg(1, Prop, HM:Head), but we keep it uninstantiated for optimization
  117    curr_prop_asr(Part, PM:Prop, From, Asr).
  118
  119walk_clause(FileD, Opts) :-
  120    option(trace_variables(TraceVars), Opts),
  121    option(from(From), Opts),
  122    Head = M:_,
  123    concurrent_forall(
  124        current_module(M),
  125        forall(( current_head(Head),
  126                 current_head_body(FileD, Head, Body, From)
  127               ),
  128               ( maplist(trace_var(Head), TraceVars),
  129                 walk_head_body(Head, Body, Opts)
  130               ))).
  131
  132current_head(Head) :-
  133    current_predicate(_, Head),
  134    \+ predicate_property(Head, imported_from(_)),
  135    predicate_property(Head, number_of_clauses(N)),
  136    N > 0.
  137
  138current_head_body(FileD, Head, CM:Body, From) :-
  139    From = clause(Ref),
  140    catch(clause(Head, Body, Ref), _, fail),
  141    from_to_file(From, File),
  142    get_dict(File, FileD, _),
  143    clause_property(Ref, module(CM)).
  144
  145trace_var(Head, non_fresh) :-
  146    term_variables(Head, Vars),
  147    '$expand':mark_vars_non_fresh(Vars).
  148trace_var(Head, meta_arg) :-
  149    mark_meta_arguments(Head).
  150
  151walk_head_body(Head, Body, Opts) :-
  152    option(on_head(OnHead), Opts),
  153    option(from(From), Opts),
  154    ignore(call(OnHead, Head, From)),
  155    walk_called(Body, Head, user, Opts),
  156    !.
  157walk_head_body(Head, Body, _) :-
  158    writeln(user_error, walk_head_body(Head, Body, -)),
  159    fail.
  160
  161walk_called(G, _, _, _) :-
  162    var(G),
  163    !.
  164walk_called(true, _, _, _) :- !.
  165walk_called(M:G, C, _, Opts) :-
  166    !,
  167    ( atom(M)
  168    ->setup_call_cleanup(( '$current_source_module'(OldM),
  169                           '$set_source_module'(M)
  170                         ),
  171                         walk_called(G, C, M, Opts),
  172                         '$set_source_module'(OldM))
  173    ; true
  174    ).
  175walk_called((A,B), C, M, O) :-
  176    !,
  177    walk_called(A, C, M, O),
  178    walk_called(B, C, M, O).
  179walk_called((A->B), C, M, O) :-
  180    !,
  181    walk_called(A, C, M, O),
  182    walk_called(B, C, M, O).
  183walk_called((A*->B), C, M, O) :-
  184    !,
  185    walk_called(A, C, M, O),
  186    walk_called(B, C, M, O).
  187walk_called(\+(A), C, M, O) :-
  188    \+ \+ walk_called(A, C, M, O).
  189walk_called((A;B), C, M, O) :-
  190    !,
  191    term_variables(A, VA),
  192    term_variables(B, VB),
  193    sort(VA, SA),
  194    sort(VB, SB),
  195    ord_union(SA, SB, L),
  196    findall(L-V-Att,
  197            ( member(E, [A, B]),
  198              walk_called(E, C, M, O),
  199              term_attvars(L, V),
  200              maplist(get_attrs, V, Att)
  201            ), LVA),
  202    maplist(put_attrs_(L), LVA).
  203walk_called(Goal, C, M, O) :-
  204    walk_called_3(Goal, C, M, O),
  205    fail.
  206walk_called(Goal, C, M, O) :-
  207    ignore(walk_called_ontrace(Goal, C, M, O)),
  208    option(trace_variables(TraceVars), O),
  209    maplist(trace_var(M:Goal), TraceVars).
  210
  211put_attrs_(L, L-V-A) :- maplist(put_attrs, V, A).
  212
  213walk_called_ontrace(Goal, Caller, M, Opts) :-
  214    option(trace_reference(To), Opts),
  215    To \== (-),
  216    (   subsumes_term(To, M:Goal)
  217    ->  M2 = M
  218    ;   predicate_property(M:Goal, implementation_module(M2)),
  219        subsumes_term(To, M2:Goal)
  220    ),
  221    option(on_trace(OnTrace), Opts),
  222    option(from(From), Opts),
  223    call(OnTrace, M2:Goal, Caller, From).
  224
  225walk_called_3(Goal, Caller, M, Opts) :-
  226    (   predicate_property(M:Goal, implementation_module(IM)),
  227        prolog:called_by(Goal, IM, M, Called)
  228    ;   prolog:called_by(Goal, Called)
  229    ),
  230    Called \== [],
  231    !,
  232    walk_called_by(Called, Caller, M, Opts).
  233walk_called_3(Meta, Caller, M, Opts) :-
  234    (   inferred_meta_predicate(M:Meta, Head)
  235    ;   predicate_property(M:Meta, meta_predicate(Head))
  236    ),
  237    !,
  238    mark_args_non_fresh(1, Head, Meta),
  239    walk_meta_call(1, Head, Meta, Caller, M, Opts).
  240walk_called_3(Goal, _, Module, _) :-
  241    nonvar(Module),
  242    '$get_predicate_attribute'(Module:Goal, defined, 1),
  243    !.
  244walk_called_3(Goal, Caller, Module, Opts) :-
  245    callable(Goal),
  246    nonvar(Module),
  247    !,
  248    undefined(Module:Goal, Caller, Opts).
  249walk_called_3(_, _, _, _).
  250
  251undefined(_, _, Opts) :-
  252    option(undefined(ignore), Opts),
  253    !.
  254undefined(Goal, _, _) :-
  255    predicate_property(Goal, autoload(_)),
  256    !.
  257undefined(Goal, Caller, Opts) :-
  258    option(undefined(trace), Opts),
  259    option(on_trace(OnTrace), Opts),
  260    option(from(From), Opts),
  261    call(OnTrace, Goal, Caller, From),
  262    fail.
  263undefined(_, _, _).
  264
  265walk_called_by([], _, _, _).
  266walk_called_by([H|T], C, M, O) :-
  267    (   H = G+N
  268    ->  (   extend(G, N, G1, O)
  269        ->  walk_called(G1, C, M, O)
  270        ;   true
  271        )
  272    ;   walk_called(H, C, M, O)
  273    ),
  274    walk_called_by(T, C, M, O).
  275
  276walk_meta_call(I, Head, Meta, Caller, M, Opts) :-
  277    arg(I, Head, AS),
  278    !,
  279    (   integer(AS)
  280    ->  arg(I, Meta, MA),
  281        ( extend(MA, AS, Goal, Opts)
  282        ->walk_called(Goal, Caller, M, Opts)
  283        ; true
  284        )
  285    ;   AS == (^)
  286    ->  arg(I, Meta, MA),
  287        remove_quantifier(MA, Goal, M, MG),
  288        walk_called(Goal, Caller, MG, Opts)
  289    ;   AS == (//)
  290    ->  arg(I, Meta, DCG),
  291        walk_dcg_body(DCG, Caller, M, Opts)
  292    ;   true
  293    ),
  294    succ(I, I2),
  295    walk_meta_call(I2, Head, Meta, Caller, M, Opts).
  296walk_meta_call(_, _, _, _, _, _).
  297
  298mark_args_non_fresh(I, Head, Meta) :-
  299    arg(I, Head, AS),
  300    !,
  301    ( ( integer(AS)
  302      ; AS == (^)
  303      ; AS == (//)
  304      )
  305    ->true
  306    ; arg(I, Meta, MA),
  307      term_variables(MA, Vars),
  308      '$expand':mark_vars_non_fresh(Vars)
  309    ),
  310    succ(I, I2),
  311    mark_args_non_fresh(I2, Head, Meta).
  312mark_args_non_fresh(_, _, _).
  313
  314walk_dcg_body(Var, _, _, _) :-
  315    var(Var),
  316    !.
  317walk_dcg_body([], _, _, _) :- !.
  318walk_dcg_body([_|_], _, _, _) :- !.
  319walk_dcg_body(String, _, _, _) :-
  320    string(String),
  321    !.
  322walk_dcg_body(!, _, _, _) :- !.
  323walk_dcg_body(M:G, C, _, O) :-
  324    !,
  325    (   nonvar(M)
  326    ->  walk_dcg_body(G, C, M, O)
  327    ;   fail
  328    ).
  329walk_dcg_body((A,B), C, M, O) :-
  330    !,
  331    walk_dcg_body(A, C, M, O),
  332    walk_dcg_body(B, C, M, O).
  333walk_dcg_body((A->B), C, M, O) :-
  334    !,
  335    walk_dcg_body(A, C, M, O),
  336    walk_dcg_body(B, C, M, O).
  337walk_dcg_body((A*->B), C, M, O) :-
  338    !,
  339    walk_dcg_body(A, C, M, O),
  340    walk_dcg_body(B, C, M, O).
  341walk_dcg_body((A;B), C, M, O) :-
  342    !,
  343    \+ \+ walk_dcg_body(A, C, M, O),
  344    \+ \+ walk_dcg_body(B, C, M, O).
  345walk_dcg_body((A|B), C, M, O) :-
  346    !,
  347    \+ \+ walk_dcg_body(A, C, M, O),
  348    \+ \+ walk_dcg_body(B, C, M, O).
  349walk_dcg_body({G}, C, M, O) :-
  350    !,
  351    walk_called(G, C, M, O).
  352walk_dcg_body(G, C, M, O) :-
  353    extend_args(G, [_, _], G2),
  354    walk_called(G2, C, M, O).
  355
  356extend(Goal, _, _, _) :-
  357    var(Goal),
  358    !,
  359    fail.
  360extend(Goal, 0, Goal, _) :- !.
  361extend(M:Goal, N, M:GoalEx, Opts) :-
  362    !,
  363    extend(Goal, N, GoalEx, Opts).
  364extend(Goal, N, GoalEx, _) :-
  365    callable(Goal),
  366    !,
  367    length(Extra, N),
  368    '$expand':mark_vars_non_fresh(Extra),
  369    extend_args(Goal, Extra, GoalEx).
  370extend(Goal, _, _, Opts) :-
  371    option(from(From), Opts),
  372    print_message(error, error(type_error(callable, Goal), From)),
  373    fail.
  374
  375remove_quantifier(Goal, Goal, M, M) :-
  376    var(Goal),
  377    !.
  378remove_quantifier(_^Goal1, Goal, M1, M) :-
  379    !,
  380    remove_quantifier(Goal1, Goal, M1, M).
  381remove_quantifier(M1:Goal1, Goal, _, M) :-
  382    !,
  383    remove_quantifier(Goal1, Goal, M1, M).
  384remove_quantifier(Goal, Goal, M, M)