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