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    ->setup_call_cleanup(
  175          ( '$current_source_module'(OldM),
  176            '$set_source_module'(CM)
  177          ),
  178          walk_called(G, C, M, Opts),
  179          '$set_source_module'(OldM))
  180    ; true
  181    ).
  182
  183walk_called(G, _, _, _) :-
  184    var(G),
  185    !.
  186walk_called(true, _, _, _) :- !.
  187walk_called(@(G,CM), C, _, Opts) :-
  188    !,
  189    strip_module(CM:G, M, H),
  190    walk_called_mod(H, C, M, CM, Opts).
  191walk_called(M:G, C, _, Opts) :-
  192    !,
  193    walk_called_mod(G, C, M, M, Opts).
  194walk_called((A,B), C, M, O) :-
  195    !,
  196    walk_called(A, C, M, O),
  197    walk_called(B, C, M, O).
  198walk_called((A->B), C, M, O) :-
  199    !,
  200    walk_called(A, C, M, O),
  201    walk_called(B, C, M, O).
  202walk_called((A*->B), C, M, O) :-
  203    !,
  204    walk_called(A, C, M, O),
  205    walk_called(B, C, M, O).
  206walk_called(\+(A), C, M, O) :-
  207    \+ \+ walk_called(A, C, M, O).
  208walk_called((A;B), C, M, O) :-
  209    !,
  210    term_variables(A, VA),
  211    term_variables(B, VB),
  212    sort(VA, SA),
  213    sort(VB, SB),
  214    ord_union(SA, SB, L),
  215    findall(L-V-Att,
  216            ( member(E, [A, B]),
  217              walk_called(E, C, M, O),
  218              term_attvars(L, V),
  219              maplist(get_attrs, V, Att)
  220            ), LVA),
  221    maplist(put_attrs_(L), LVA).
  222walk_called(Goal, C, M, O) :-
  223    walk_called_3(Goal, C, M, O),
  224    fail.
  225walk_called(Goal, C, M, O) :-
  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, Caller, 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, Caller, 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,CM), C, CM, O)
  290        ;   true
  291        )
  292    ;   walk_called(@(H,CM), 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)