1/*  Part of Run-Time Checker for Assertions
    2
    3    Author:        Edison Mera
    4    E-mail:        efmera@gmail.com
    5    WWW:           https://github.com/edisonm/refactor
    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(rtchecks_utils,
   36          [ handle_rtcheck/1,
   37            intercept_rtc/1,
   38            call_rtc/1,
   39            save_rtchecks/1,
   40            load_rtchecks/1,
   41            assrchk_error/1
   42          ]).   43
   44:- use_module(library(assertions)).   45:- use_module(library(plprops)).   46:- use_module(library(prolog_codewalk),  []). % for message_location
   47:- use_module(library(filtered_backtrace)).   48:- use_module(library(intercept)).   49:- use_module(library(rtchecks), [with_rtchecks/1]).   50:- init_expansors.   51
   52:- multifile
   53    prolog:message_location//1.

   58filtered_backtrace:no_backtrace_clause_hook(_, ontrace).
   59filtered_backtrace:no_backtrace_clause_hook(_, call_inoutex).
   60filtered_backtrace:no_backtrace_clause_hook(_, rtchecks_utils).
   61filtered_backtrace:no_backtrace_clause_hook(_, rtchecks_rt).
   62filtered_backtrace:no_backtrace_clause_hook(_, rtchecks).
   63filtered_backtrace:no_backtrace_clause_hook(_, ctrtchecks).
   64filtered_backtrace:no_backtrace_clause_hook(_, intercept).
   65filtered_backtrace:no_backtrace_clause_hook(_, globprops).
   66filtered_backtrace:no_backtrace_clause_hook(_, typeprops).
   67filtered_backtrace:no_backtrace_clause_hook(_, metaprops).
   68filtered_backtrace:no_backtrace_clause_hook(_, send_check).
   69filtered_backtrace:no_backtrace_clause_hook(_, plprops).
   70filtered_backtrace:no_backtrace_clause_hook(_, context_values).
   71
   72:- type location_t/1.
   73location_t(Loc) :-
   74    ( clause('$messages':swi_location(Term, _, _), _)
   75    ; clause(prolog:message_location(Term, _, _), _)
   76    ; Term = []
   77    ),
   78    nonvar(Term),
   79    Term = Loc.
   80
   81:- type assrchk_error/1 #
   82        "Specifies the format of an assertion check error.".
   83
   84assrchk_error(assrchk(error(Type, _Pred, PropValues, PLoc, ALoc))) :-
   85    rtcheck_type(Type),
   86    keylist(PropValues),
   87    location_t(PLoc),
   88    location_t(ALoc).
   89
   90:- type rtcheck_type/1 # "Specifies the type of run-time errors.".
   91
   92rtcheck_type(comp).
   93rtcheck_type(pp_check).
   94rtcheck_type(success).
   95rtcheck_type(compat).
   96rtcheck_type(compatpos).
   97rtcheck_type(calls).

 handle_rtcheck(RTCheck:assrchk_error) is det

Predicate that processes a rtcheck exception.

  103handle_rtcheck(RTCheck) :-
  104    \+ ( copy_term_nat(RTCheck, Term),
  105         numbervars(Term, 0, _,
  106                    [ singletons(true)
  107                    ]),
  108         print_message(error, Term),
  109         fail
  110       ).
  111
  112:- multifile
  113        prolog:error_message_signal//1,
  114        prolog:error_message//1,
  115        prolog:message//1.  116
  117prolog:error_message_signal(RTCheck) -->
  118    prolog:message(RTCheck).
  119
  120prolog:error_message(unintercepted_signal(Signal)) -->
  121        ( prolog:error_message_signal(Signal) -> []
  122        ; ['unintercepted signal: ~p'-[Signal]]
  123        ).
  124
  125% We should use our own apply.pl predicates, so that apply.pl can be
  126% run-time checked:
  127
  128:- meta_predicate '$foldl'(3,+,?,?).  129
  130'$foldl'(Goal, List, V1, V) :-
  131    '$foldl_'(List, Goal, V1, V).
  132
  133'$foldl_'([], _, V, V).
  134'$foldl_'([H|T], Goal, V1, V) :-
  135    call(Goal, H, V1, V2),
  136    '$foldl_'(T, Goal, V2, V).
  137
  138rt_translate_message(Msg) -->
  139    '$messages':translate_message(Msg),
  140    [nl].
  141
  142prolog:message(acheck(checks, RTChecks)) -->
  143    '$foldl'(rt_translate_message, RTChecks).
  144
  145prolog:message(assrchk(Error)) -->
  146    assr_error_message(Error),
  147    !.
  148
  149assr_error_message(error(Type, Pred, PropValues, PLoc, ALoc)) -->
  150    '$messages':swi_location(PLoc),
  151    ['Assertion failure for ~q.'-[Pred], nl],
  152    '$messages':swi_location(ALoc),
  153    ['    In *~w*, unsatisfied properties: '-[Type], nl],
  154    '$foldl'(prop_values, PropValues).
  155
  156prop_values(From/Prop-Values) -->
  157    ['        '],
  158    '$messages':swi_location(From),
  159    ['~q'-[Prop]],
  160    ( {Values = []}
  161    ->['.']
  162    ; [', because: ~q.'-[Values]]
  163    ),
  164    [nl].
  165
  166:- thread_local rtcheck_db/1.  167
  168:- meta_predicate
  169        call_rtc(0 ),
  170        intercept_rtc(0 ).  171
  172:- true pred call_rtc/1 : callable # "This predicate calls a goal and if an
  173        rtcheck signal is intercepted, an error message is shown and
  174        the execution continues. Alternatively, it is re-raised as an
  175        exception depending on the flag rtchecks_abort_on_error
  176        value.".
  177
  178call_rtc(Goal) :- intercept_rtc(with_rtchecks(Goal)).
  179
  180intercept_rtc(Goal) :-
  181        Error = assrchk(_),
  182        ( current_prolog_flag(rtchecks_abort_on_error, yes)
  183	->intercept(Goal, Error, throw(Error)) % rethrow signal as exception
  184        ; intercept(Goal, Error,
  185                    notrace(( handle_rtcheck(Error),
  186                              filtered_backtrace(100)
  187                            )))
  188        ).
  189
  190:- meta_predicate save_rtchecks(0).  191
  192:- pred save_rtchecks/1 : callable # "Asserts in rtcheck_db/1 all the
  193        run-time check exceptions thrown by the goal.".
  194
  195save_rtchecks(Goal) :-
  196    RTError = assrchk(_),
  197    intercept(Goal, RTError, assertz(rtcheck_db(RTError))).
  198
  199:- pred load_rtchecks/1 => list(assrchk_error) # "retract the
  200        rtcheck_db/1 facts and return them in a list.".
  201
  202load_rtchecks(RTChecks) :-
  203        findall(RTCheck, retract(rtcheck_db(RTCheck)), RTChecks)