View source with raw comments or as raw
    1/*  Part of CHR (Constraint Handling Rules)
    2
    3    Author:        Tom Schrijvers and Jan Wielemaker
    4    E-mail:        Tom.Schrijvers@cs.kuleuven.be
    5    WWW:           http://www.swi-prolog.org
    6    Copyright (c)  2004-2025, K.U. Leuven
    7                              SWI-Prolog Solutions b.v.
    8    All rights reserved.
    9
   10    Redistribution and use in source and binary forms, with or without
   11    modification, are permitted provided that the following conditions
   12    are met:
   13
   14    1. Redistributions of source code must retain the above copyright
   15       notice, this list of conditions and the following disclaimer.
   16
   17    2. Redistributions in binary form must reproduce the above copyright
   18       notice, this list of conditions and the following disclaimer in
   19       the documentation and/or other materials provided with the
   20       distribution.
   21
   22    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
   23    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
   24    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
   25    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
   26    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
   27    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
   28    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
   29    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
   30    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
   31    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
   32    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
   33    POSSIBILITY OF SUCH DAMAGE.
   34*/
   37:- module(chr,
   38          [ op(1180, xfx, ==>),
   39            op(1180, xfx, <=>),
   40            op(1150, fx, constraints),
   41            op(1150, fx, chr_constraint),
   42            op(1150, fx, chr_preprocessor),
   43            op(1150, fx, handler),
   44            op(1150, fx, rules),
   45            op(1100, xfx, \),
   46            op(1200, xfx, @),
   47            op(1190, xfx, pragma),
   48            op( 500, yfx, #),
   49            op(1150, fx, chr_type),
   50            op(1150, fx, chr_declaration),
   51            op(1130, xfx, --->),
   52            op(1150, fx, (?)),
   53            chr_show_store/1,           % +Module
   54            find_chr_constraint/1,      % +Pattern
   55            current_chr_constraint/1,   % :Pattern
   56            chr_trace/0,
   57            chr_notrace/0,
   58            chr_leash/1                 % +Ports
   59          ]).   60:- use_module(library(dialect), [expects_dialect/1]).   61:- use_module(library(apply), [maplist/3]).   62:- use_module(library(lists), [member/2]).   63:- use_module(library(prolog_code), [pi_head/2]).   64
   65:- expects_dialect(swi).   66
   67:- set_prolog_flag(generate_debug_info, false).   68
   69:- multifile
   70    debug_ask_continue/1,
   71    preprocess/2.   72
   73:- multifile user:file_search_path/2.   74:- dynamic   user:file_search_path/2.   75:- dynamic   chr_translated_program/1.   76
   77user:file_search_path(chr, library(chr)).
   78
   79:- load_files([ chr(chr_translate),
   80                chr(chr_runtime),
   81                chr(chr_messages),
   82                chr(chr_hashtable_store),
   83                chr(chr_compiler_errors)
   84              ],
   85              [ if(not_loaded),
   86                silent(true)
   87              ]).   88
   89:- use_module(library(lists), [member/2]).
  126:- multifile chr:'$chr_module'/1.  127
  128:- dynamic chr_term/3.          % File, Term
  129
  130:- dynamic chr_pp/2.            % File, Term
  131
  132%       chr_expandable(+Term)
  133%
  134%       Succeeds if Term is a  rule  that   must  be  handled by the CHR
  135%       compiler. Ideally CHR definitions should be between
  136%
  137%               :- constraints ...
  138%               ...
  139%               :- end_constraints.
  140%
  141%       As they are not we have to   use  some heuristics. We assume any
  142%       file is a CHR after we've seen :- constraints ...
  143
  144chr_expandable((:- constraints _)).
  145chr_expandable((constraints _)).
  146chr_expandable((:- chr_constraint _)).
  147chr_expandable((:- chr_type _)).
  148chr_expandable((chr_type _)).
  149chr_expandable((:- chr_declaration _)).
  150chr_expandable(option(_, _)).
  151chr_expandable((:- chr_option(_, _))).
  152chr_expandable((handler _)).
  153chr_expandable((rules _)).
  154chr_expandable((_ <=> _)).
  155chr_expandable((_ @ _)).
  156chr_expandable((_ ==> _)).
  157chr_expandable((_ pragma _)).
  158
  159%       chr_expand(+Term, -Expansion)
  160%
  161%       Extract CHR declarations and rules from the file and run the
  162%       CHR compiler when reaching end-of-file.
  165extra_declarations([ (:- use_module(chr(chr_runtime))),
  166                     (:- style_check(-discontiguous)),
  167                     (:- style_check(-singleton)),
  168                     (:- style_check(-no_effect)),
  169                     (:- set_prolog_flag(generate_debug_info, false))
  170                   | Tail
  171                   ], Tail).
  181chr_expand(Term, []) :-
  182    chr_expandable(Term),
  183    !,
  184    prolog_load_context(source,Source),
  185    prolog_load_context(source,File),
  186    prolog_load_context(term_position,Pos),
  187    stream_position_data(line_count,Pos,SourceLocation),
  188    add_pragma_to_chr_rule(Term,source_location(File:SourceLocation),NTerm),
  189    assert(chr_term(Source, SourceLocation, NTerm)).
  190chr_expand(Term, []) :-
  191    Term = (:- chr_preprocessor Preprocessor),
  192    !,
  193    prolog_load_context(source,File),
  194    assert(chr_pp(File, Preprocessor)).
  195chr_expand(end_of_file, FinalProgram) :-
  196    extra_declarations(FinalProgram,Program),
  197    prolog_load_context(source,File),
  198    findall(T, retract(chr_term(File,_Line,T)), CHR0),
  199    CHR0 \== [],
  200    prolog_load_context(module, Module),
  201    add_debug_decl(CHR0, CHR1),
  202    add_optimise_decl(CHR1, CHR2),
  203    call_preprocess(CHR2, CHR3),
  204    CHR4 = [ (:- module(Module, [])) | CHR3 ],
  205    findall(P, retract(chr_pp(File, P)), Preprocessors),
  206    ( Preprocessors = [] ->
  207            CHR4 = CHR
  208    ; Preprocessors = [Preprocessor] ->
  209            chr_compiler_errors:chr_info(preprocessor,'\tPreprocessing with ~w.\n',[Preprocessor]),
  210            call_chr_preprocessor(Preprocessor,CHR4,CHR)
  211    ;
  212            chr_compiler_errors:print_chr_error(error(syntax(Preprocessors),'Too many preprocessors! Only one is allowed!\n',[])),
  213            fail
  214    ),
  215    catch(call_chr_translate(File,
  216                       [ (:- module(Module, []))
  217                       | CHR
  218                       ],
  219                       Program0),
  220            chr_error(Error),
  221            (       chr_compiler_errors:print_chr_error(Error),
  222                    fail
  223            )
  224    ),
  225    delete_header(Program0, Program).
  226
  227
  228delete_header([(:- module(_,_))|T0], T) :-
  229    !,
  230    delete_header(T0, T).
  231delete_header(L, L).
  232
  233add_debug_decl(CHR, CHR) :-
  234    member(option(Name, _), CHR), Name == debug,
  235    !.
  236add_debug_decl(CHR, CHR) :-
  237    member((:- chr_option(Name, _)), CHR), Name == debug,
  238    !.
  239add_debug_decl(CHR, [(:- chr_option(debug, Debug))|CHR]) :-
  240    (   chr_current_prolog_flag(generate_debug_info, true)
  241    ->  Debug = on
  242    ;   Debug = off
  243    ).
  246chr_current_prolog_flag(Flag,Val) :- current_prolog_flag(Flag,Val).
  249add_optimise_decl(CHR, CHR) :-
  250    \+(\+(memberchk((:- chr_option(optimize, _)), CHR))),
  251    !.
  252add_optimise_decl(CHR, [(:- chr_option(optimize, full))|CHR]) :-
  253    chr_current_prolog_flag(optimize, full),
  254    !.
  255add_optimise_decl(CHR, CHR).
 call_preprocess(+CHR0, -CHR) is det
Call user chr:preprocess(CHR0, CHR).
  261call_preprocess(CHR0, CHR) :-
  262    preprocess(CHR0, CHR),
  263    !.
  264call_preprocess(CHR, CHR).
  265
  266%       call_chr_translate(+File, +In, -Out)
  267%
  268%       The entire chr_translate/2 translation may fail, in which case we'd
  269%       better issue a warning  rather  than   simply  ignoring  the CHR
  270%       declarations.
  271
  272call_chr_translate(File, In, _Out) :-
  273    ( chr_translate_line_info(In, File, Out0) ->
  274        nb_setval(chr_translated_program,Out0),
  275        fail
  276    ).
  277call_chr_translate(_, _In, Out) :-
  278    nb_current(chr_translated_program,Out),
  279    !,
  280    nb_delete(chr_translated_program).
  281
  282call_chr_translate(File, _, []) :-
  283    print_message(error, chr(compilation_failed(File))).
  284
  285call_chr_preprocessor(Preprocessor,CHR,_NCHR) :-
  286    ( call(Preprocessor,CHR,CHR0) ->
  287            nb_setval(chr_preprocessed_program,CHR0),
  288            fail
  289    ).
  290call_chr_preprocessor(_,_,NCHR) :-
  291    nb_current(chr_preprocessed_program,NCHR),
  292    !,
  293    nb_delete(chr_preprocessed_program).
  294call_chr_preprocessor(Preprocessor,_,_) :-
  295    chr_compiler_errors:print_chr_error(error(preprocessor,'Preprocessor `~w\' failed!\n',[Preprocessor])).
  299                 /*******************************
  300                 *      SYNCHRONISE TRACER      *
  301                 *******************************/
  302
  303:- multifile
  304    user:message_hook/3,
  305    chr:debug_event/2,
  306    chr:debug_interact/3.  307:- dynamic
  308    user:message_hook/3.  309
  310user:message_hook(trace_mode(OnOff), _, _) :-
  311    (   OnOff == on
  312    ->  chr_trace
  313    ;   chr_notrace
  314    ),
  315    fail.                           % backtrack to other handlers
  316
  317:- public
  318    debug_event/2,
  319    debug_interact/3.
 debug_event(+State, +Event)
Hook into the CHR debugger. At this moment we will discard CHR events if we are in a Prolog `skip' and we ignore the
  326debug_event(_State, _Event) :-
  327    tracing,                        % are we tracing?
  328    prolog_skip_level(Skip, Skip),
  329    Skip \== very_deep,
  330    prolog_current_frame(Me),
  331    prolog_frame_attribute(Me, level, Level),
  332    Level > Skip,
  333    !.
 debug_interact(+Event, +Depth, -Command)
Hook into the CHR debugger to display Event and ask for the next command to execute. This definition causes the normal Prolog debugger to be used for the standard ports.
  341debug_interact(Event, _Depth, creep) :-
  342    prolog_event(Event),
  343    tracing,
  344    !.
  345
  346prolog_event(call(_)).
  347prolog_event(exit(_)).
  348prolog_event(fail(_)).
 debug_ask_continue(-Command) is semidet
Hook to ask for a CHR debug continuation. Must bind Command to one of creep, skip, ancestors, nodebug, abort, fail, break, help or exit.
  357                 /*******************************
  358                 *            MESSAGES          *
  359                 *******************************/
  360
  361:- multifile
  362    prolog:message/3.  363
  364prolog:message(chr(CHR)) -->
  365    chr_message(CHR).
  366
  367:- multifile
  368    check:trivial_fail_goal/1.  369
  370check:trivial_fail_goal(_:Goal) :-
  371    functor(Goal, Name, _),
  372    sub_atom(Name, 0, _, _, '$chr_store_constants_').
  373
  374                 /*******************************
  375                 *       TOPLEVEL PRINTING      *
  376                 *******************************/
  377
  378:- create_prolog_flag(chr_toplevel_show_store, true, []).  379
  380:- residual_goals(chr_residuals).
 chr_residuals// is det
Find the CHR constraints from the store. These are accessible through the nondet predicate current_chr_constraint/1. Doing a findall/4 however would loose the bindings. We therefore rolled findallv/4, which exploits non-backtrackable assignment and realises a copy of the template without disturbing the bindings using this strangely looking construct. Note that the bindings created by the unifications are in New, which is newer then the latest choicepoint and therefore the bindings are not trailed.
duplicate_term(Templ, New),
New = Templ
  398chr_residuals(Residuals, Tail) :-
  399    chr_current_prolog_flag(chr_toplevel_show_store,true),
  400    nb_current(chr_global, _),
  401    !,
  402    Goal = _:_,
  403    findallv(Goal, current_chr_constraint(Goal), Residuals, Tail).
  404chr_residuals(Residuals, Residuals).
  405
  406:- meta_predicate
  407    findallv(?, 0, ?, ?).  408
  409findallv(Templ, Goal, List, Tail) :-
  410    List2 = [x|_],
  411    State = state(List2),
  412    (   call(Goal),
  413        arg(1, State, L),
  414        duplicate_term(Templ, New),
  415        New = Templ,
  416        Cons = [New|_],
  417        nb_linkarg(2, L, Cons),
  418        nb_linkarg(1, State, Cons),
  419        fail
  420    ;   List2 = [x|List],
  421        arg(1, State, Last),
  422        arg(2, Last, Tail)
  423    ).
  424
  425
  426                 /*******************************
  427                 *         MUST BE LAST!        *
  428                 *******************************/
 in_chr_context is semidet
True if we are expanding into a context where the chr module is loaded.
  435in_chr_context :-
  436    prolog_load_context(module, M),
  437    (   current_op(1180, xfx, M:(==>))
  438    ->  true
  439    ;   module_property(chr, exports(PIs)),
  440        member(PI, PIs),
  441        pi_head(PI, Head),
  442        predicate_property(M:Head, imported_from(chr))
  443    ->  true
  444    ).
  445
  446:- multifile system:term_expansion/2.  447:- dynamic   system:term_expansion/2.  448
  449system:term_expansion(In, Out) :-
  450    \+ current_prolog_flag(xref, true),
  451    in_chr_context,
  452    chr_expand(In, Out).
:- dynamic current_toplevel_show_store/1, current_generate_debug_info/1, current_optimize/1.

current_toplevel_show_store(on).

current_generate_debug_info(false).

current_optimize(off).

chr_current_prolog_flag(generate_debug_info, X) :- chr_flag(generate_debug_info, X, X). chr_current_prolog_flag(optimize, X) :- chr_flag(optimize, X, X).

chr_flag(Flag, Old, New) :- Goal = chr_flag(Flag,Old,New), g must_be(Flag, oneof([toplevel_show_store,generate_debug_info,optimize]), Goal, 1), chr_flag(Flag, Old, New, Goal).

chr_flag(toplevel_show_store, Old, New, Goal) :- clause(current_toplevel_show_store(Old), true, Ref), ( New==Old -> true ; must_be(New, oneof([on,off]), Goal, 3), erase(Ref), assertz(current_toplevel_show_store(New)) ). chr_flag(generate_debug_info, Old, New, Goal) :- clause(current_generate_debug_info(Old), true, Ref), ( New==Old -> true ; must_be(New, oneof([false,true]), Goal, 3), erase(Ref), assertz(current_generate_debug_info(New)) ). chr_flag(optimize, Old, New, Goal) :- clause(current_optimize(Old), true, Ref), ( New==Old -> true ; must_be(New, oneof([full,off]), Goal, 3), erase(Ref), assertz(current_optimize(New)) ).

all_stores_goal(Goal, CVAs) :- chr_flag(toplevel_show_store, on, on), !, findall(C-CVAs, find_chr_constraint(C), Pairs), andify(Pairs, Goal, CVAs). all_stores_goal(true, _).

andify([], true, _). andify([X-Vs|L], Conj, Vs) :- andify(L, X, Conj, Vs).

andify([], X, X, _). andify([Y-Vs|L], X, (X,Conj), Vs) :- andify(L, Y, Conj, Vs).

:- multifile term_expansion/6.

user:term_expansion(In, _, Ids, Out, [], [chr|Ids]) :- nonvar(In), nonmember(chr, Ids), chr_expand(In, Out), !.

% SICStus end

  523%%% for SSS %%%
  524
  525add_pragma_to_chr_rule((Name @ Rule), Pragma, Result) :-
  526    !,
  527    add_pragma_to_chr_rule(Rule,Pragma,NRule),
  528    Result = (Name @ NRule).
  529add_pragma_to_chr_rule((Rule pragma Pragmas), Pragma, Result) :-
  530    !,
  531    Result = (Rule pragma (Pragma,Pragmas)).
  532add_pragma_to_chr_rule((Head ==> Body), Pragma, Result) :-
  533    !,
  534    Result = (Head ==> Body pragma Pragma).
  535add_pragma_to_chr_rule((Head <=> Body), Pragma, Result) :-
  536    !,
  537    Result = (Head <=> Body pragma Pragma).
  538add_pragma_to_chr_rule(Term,_,Term).
  539
  540
  541                 /*******************************
  542                 *        SANDBOX SUPPORT       *
  543                 *******************************/
  544
  545:- multifile
  546    sandbox:safe_primitive/1.  547
  548% CHR uses a lot of global variables. We   don't  really mind as long as
  549% the user does not mess around  with   global  variable that may have a
  550% predefined meaning.
  551
  552sandbox:safe_primitive(system:b_setval(V, _)) :-
  553    chr_var(V).
  554sandbox:safe_primitive(system:nb_linkval(V, _)) :-
  555    chr_var(V).
  556sandbox:safe_primitive(chr:debug_event(_,_)).
  557sandbox:safe_primitive(chr:debug_interact(_,_,_)).
  558
  559chr_var(Name) :- sub_atom(Name, 0, _, _, '$chr').
  560chr_var(Name) :- sub_atom(Name, 0, _, _, 'chr').
  561
  562
  563                 /*******************************
  564                 *     SYNTAX HIGHLIGHTING      *
  565                 *******************************/
  566
  567:- multifile
  568    prolog_colour:term_colours/2,
  569    prolog_colour:goal_colours/2.
 term_colours(+Term, -Colours)
Colourisation of a toplevel term as read from the file.
  575term_colours((_Name @ Rule), delimiter - [ identifier, RuleColours ]) :-
  576    !,
  577    term_colours(Rule, RuleColours).
  578term_colours((Rule pragma _Pragma), delimiter - [RuleColours,pragma]) :-
  579    !,
  580    term_colours(Rule, RuleColours).
  581term_colours((Head <=> Body), delimiter - [ HeadColours, BodyColours ]) :-
  582    !,
  583    chr_head(Head, HeadColours),
  584    chr_body(Body, BodyColours).
  585term_colours((Head ==> Body), delimiter - [ HeadColours, BodyColours ]) :-
  586    !,
  587    chr_head(Head, HeadColours),
  588    chr_body(Body, BodyColours).
  589
  590chr_head(_C#_Id, delimiter - [ head, identifier ]) :- !.
  591chr_head((A \ B), delimiter - [ AC, BC ]) :-
  592    !,
  593    chr_head(A, AC),
  594    chr_head(B, BC).
  595chr_head((A, B), functor - [ AC, BC ]) :-
  596    !,
  597    chr_head(A, AC),
  598    chr_head(B, BC).
  599chr_head(_, head).
  600
  601chr_body((Guard|Goal), delimiter - [ GuardColour, GoalColour ]) :-
  602    !,
  603    chr_body(Guard, GuardColour),
  604    chr_body(Goal, GoalColour).
  605chr_body(_, body).
 goal_colours(+Goal, -Colours)
Colouring of special goals.
  612goal_colours(constraints(Decls), deprecated-[DeclColours]) :-
  613    chr_constraint_colours(Decls, DeclColours).
  614goal_colours(chr_constraint(Decls), built_in-[DeclColours]) :-
  615    chr_constraint_colours(Decls, DeclColours).
  616goal_colours(chr_type(TypeDecl), built_in-[DeclColours]) :-
  617    chr_type_decl_colours(TypeDecl, DeclColours).
  618goal_colours(chr_option(Option,Value), built_in-[OpC,ValC]) :-
  619    chr_option_colours(Option, Value, OpC, ValC).
  620
  621chr_constraint_colours(Var, instantiation_error(Var)) :-
  622    var(Var),
  623    !.
  624chr_constraint_colours((H,T), classify-[HeadColours,BodyColours]) :-
  625    !,
  626    chr_constraint_colours(H, HeadColours),
  627    chr_constraint_colours(T, BodyColours).
  628chr_constraint_colours(PI, Colours) :-
  629    pi_to_term(PI, Goal),
  630    !,
  631    Colours = predicate_indicator-[ goal(constraint(0), Goal),
  632                                    arity
  633                                  ].
  634chr_constraint_colours(Goal, Colours) :-
  635    atom(Goal),
  636    !,
  637    Colours = goal(constraint(0), Goal).
  638chr_constraint_colours(Goal, Colours) :-
  639    compound(Goal),
  640    !,
  641    compound_name_arguments(Goal, _Name, Args),
  642    maplist(chr_argspec, Args, ArgColours),
  643    Colours = goal(constraint(0), Goal)-ArgColours.
  644
  645chr_argspec(Term, mode(Mode)-[chr_type(Type)]) :-
  646    compound(Term),
  647    compound_name_arguments(Term, Mode, [Type]),
  648    chr_mode(Mode).
  649
  650chr_mode(+).
  651chr_mode(?).
  652chr_mode(-).
  653
  654pi_to_term(Name/Arity, Term) :-
  655    atom(Name), integer(Arity), Arity >= 0,
  656    !,
  657    functor(Term, Name, Arity).
  658
  659chr_type_decl_colours((Type ---> Def), built_in-[chr_type(Type), DefColours]) :-
  660    chr_type_colours(Def, DefColours).
  661chr_type_decl_colours((Type == Alias), built_in-[chr_type(Type), chr_type(Alias)]).
  662
  663chr_type_colours(Var, classify) :-
  664    var(Var),
  665    !.
  666chr_type_colours((A;B), control-[CA,CB]) :-
  667    !,
  668    chr_type_colours(A, CA),
  669    chr_type_colours(B, CB).
  670chr_type_colours(T, chr_type(T)).
  671
  672chr_option_colours(Option, Value, identifier, ValCol) :-
  673    chr_option_range(Option, Values),
  674    !,
  675    (   nonvar(Value),
  676        memberchk(Value, Values)
  677    ->  ValCol = classify
  678    ;   ValCol = error
  679    ).
  680chr_option_colours(_, _, error, classify).
  681
  682chr_option_range(check_guard_bindings, [on,off]).
  683chr_option_range(optimize, [off, full]).
  684chr_option_range(debug, [on, off]).
  685
  686prolog_colour:term_colours(Term, Colours) :-
  687    term_colours(Term, Colours).
  688prolog_colour:goal_colours(Term, Colours) :-
  689    goal_colours(Term, Colours)