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