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).
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 prolog:message_action/2, 305 chr:debug_event/2, 306 chr:debug_interact/3. 307 308prolog:message_action(trace_mode(OnOff), _) :- 309 ( OnOff == on 310 -> chr_trace 311 ; chr_notrace 312 ). 313 314:- public 315 debug_event/2, 316 debug_interact/3.
323debug_event(_State, _Event) :-
324 tracing, % are we tracing?
325 prolog_skip_level(Skip, Skip),
326 Skip \== very_deep,
327 prolog_current_frame(Me),
328 prolog_frame_attribute(Me, level, Level),
329 Level > Skip,
330 !.338debug_interact(Event, _Depth, creep) :- 339 prolog_event(Event), 340 tracing, 341 !. 342 343prolog_event(call(_)). 344prolog_event(exit(_)). 345prolog_event(fail(_)).
creep, skip, ancestors, nodebug, abort, fail,
break, help or exit.354 /******************************* 355 * MESSAGES * 356 *******************************/ 357 358:- multifile 359 prolog:message/3. 360 361prologmessage(chr(CHR)) --> 362 chr_message(CHR). 363 364:- multifile 365 check:trivial_fail_goal/1. 366 367checktrivial_fail_goal(_:Goal) :- 368 functor(Goal, Name, _), 369 sub_atom(Name, 0, _, _, '$chr_store_constants_'). 370 371 /******************************* 372 * TOPLEVEL PRINTING * 373 *******************************/ 374 375:- create_prolog_flag(chr_toplevel_show_store, true, []). 376 377:- residual_goals(chr_residuals).
duplicate_term(Templ, New), New = Templ
395chr_residuals(Residuals, Tail) :- 396 chr_current_prolog_flag(chr_toplevel_show_store,true), 397 nb_current(chr_global, _), 398 !, 399 Goal = _:_, 400 findallv(Goal, current_chr_constraint(Goal), Residuals, Tail). 401chr_residuals(Residuals, Residuals). 402 403:- meta_predicate 404 findallv(, , , ). 405 406findallv(Templ, Goal, List, Tail) :- 407 List2 = [x|_], 408 State = state(List2), 409 ( call(Goal), 410 arg(1, State, L), 411 duplicate_term(Templ, New), 412 New = Templ, 413 Cons = [New|_], 414 nb_linkarg(2, L, Cons), 415 nb_linkarg(1, State, Cons), 416 fail 417 ; List2 = [x|List], 418 arg(1, State, Last), 419 arg(2, Last, Tail) 420 ). 421 422 423 /******************************* 424 * MUST BE LAST! * 425 *******************************/
432in_chr_context :- 433 prolog_load_context(module, M), 434 ( current_op(1180, xfx, M:(==>)) 435 -> true 436 ; module_property(chr, exports(PIs)), 437 member(PI, PIs), 438 pi_head(PI, Head), 439 predicate_property(M:Head, imported_from(chr)) 440 -> true 441 ). 442 443:- multifile system:term_expansion/2. 444:- dynamic system:term_expansion/2. 445 446systemterm_expansion(In, Out) :- 447 \+ current_prolog_flag(xref, true), 448 in_chr_context, 449 chr_expand(In, Out).
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
520%%% for SSS %%% 521 522add_pragma_to_chr_rule((Name @ Rule), Pragma, Result) :- 523 !, 524 add_pragma_to_chr_rule(Rule,Pragma,NRule), 525 Result = (Name @ NRule). 526add_pragma_to_chr_rule((Rule pragma Pragmas), Pragma, Result) :- 527 !, 528 Result = (Rule pragma (Pragma,Pragmas)). 529add_pragma_to_chr_rule((Head ==> Body), Pragma, Result) :- 530 !, 531 Result = (Head ==> Body pragma Pragma). 532add_pragma_to_chr_rule((Head <=> Body), Pragma, Result) :- 533 !, 534 Result = (Head <=> Body pragma Pragma). 535add_pragma_to_chr_rule(Term,_,Term). 536 537 538 /******************************* 539 * SANDBOX SUPPORT * 540 *******************************/ 541 542:- multifile 543 sandbox:safe_primitive/1. 544 545% CHR uses a lot of global variables. We don't really mind as long as 546% the user does not mess around with global variable that may have a 547% predefined meaning. 548 549sandbox:safe_primitive(system:b_setval(V, _)) :- 550 chr_var(V). 551sandbox:safe_primitive(system:nb_linkval(V, _)) :- 552 chr_var(V). 553sandbox:safe_primitive(chr:debug_event(_,_)). 554sandbox:safe_primitive(chr:debug_interact(_,_,_)). 555 556chr_var(Name) :- sub_atom(Name, 0, _, _, '$chr'). 557chr_var(Name) :- sub_atom(Name, 0, _, _, 'chr'). 558 559 560 /******************************* 561 * SYNTAX HIGHLIGHTING * 562 *******************************/ 563 564:- multifile 565 prolog_colour:term_colours/2, 566 prolog_colour:goal_colours/2.
572term_colours((_Name @ Rule), delimiter - [ identifier, RuleColours ]) :- 573 !, 574 term_colours(Rule, RuleColours). 575term_colours((Rule pragma _Pragma), delimiter - [RuleColours,pragma]) :- 576 !, 577 term_colours(Rule, RuleColours). 578term_colours((Head <=> Body), delimiter - [ HeadColours, BodyColours ]) :- 579 !, 580 chr_head(Head, HeadColours), 581 chr_body(Body, BodyColours). 582term_colours((Head ==> Body), delimiter - [ HeadColours, BodyColours ]) :- 583 !, 584 chr_head(Head, HeadColours), 585 chr_body(Body, BodyColours). 586 587chr_head(_C#_Id, delimiter - [ head, identifier ]) :- !. 588chr_head((A \ B), delimiter - [ AC, BC ]) :- 589 !, 590 chr_head(A, AC), 591 chr_head(B, BC). 592chr_head((A, B), functor - [ AC, BC ]) :- 593 !, 594 chr_head(A, AC), 595 chr_head(B, BC). 596chr_head(_, head). 597 598chr_body((Guard|Goal), delimiter - [ GuardColour, GoalColour ]) :- 599 !, 600 chr_body(Guard, GuardColour), 601 chr_body(Goal, GoalColour). 602chr_body(_, body).
609goal_colours(constraints(Decls), deprecated-[DeclColours]) :- 610 chr_constraint_colours(Decls, DeclColours). 611goal_colours(chr_constraint(Decls), built_in-[DeclColours]) :- 612 chr_constraint_colours(Decls, DeclColours). 613goal_colours(chr_type(TypeDecl), built_in-[DeclColours]) :- 614 chr_type_decl_colours(TypeDecl, DeclColours). 615goal_colours(chr_option(Option,Value), built_in-[OpC,ValC]) :- 616 chr_option_colours(Option, Value, OpC, ValC). 617 618chr_constraint_colours(Var, instantiation_error(Var)) :- 619 var(Var), 620 !. 621chr_constraint_colours((H,T), classify-[HeadColours,BodyColours]) :- 622 !, 623 chr_constraint_colours(H, HeadColours), 624 chr_constraint_colours(T, BodyColours). 625chr_constraint_colours(PI, Colours) :- 626 pi_to_term(PI, Goal), 627 !, 628 Colours = predicate_indicator-[ goal(constraint(0), Goal), 629 arity 630 ]. 631chr_constraint_colours(Goal, Colours) :- 632 atom(Goal), 633 !, 634 Colours = goal(constraint(0), Goal). 635chr_constraint_colours(Goal, Colours) :- 636 compound(Goal), 637 !, 638 compound_name_arguments(Goal, _Name, Args), 639 maplist(chr_argspec, Args, ArgColours), 640 Colours = goal(constraint(0), Goal)-ArgColours. 641 642chr_argspec(Term, mode(Mode)-[chr_type(Type)]) :- 643 compound(Term), 644 compound_name_arguments(Term, Mode, [Type]), 645 chr_mode(Mode). 646 647chr_mode(+). 648chr_mode(?). 649chr_mode(-). 650 651pi_to_term(Name/Arity, Term) :- 652 atom(Name), integer(Arity), Arity >= 0, 653 !, 654 functor(Term, Name, Arity). 655 656chr_type_decl_colours((Type ---> Def), built_in-[chr_type(Type), DefColours]) :- 657 chr_type_colours(Def, DefColours). 658chr_type_decl_colours((Type == Alias), built_in-[chr_type(Type), chr_type(Alias)]). 659 660chr_type_colours(Var, classify) :- 661 var(Var), 662 !. 663chr_type_colours((A;B), control-[CA,CB]) :- 664 !, 665 chr_type_colours(A, CA), 666 chr_type_colours(B, CB). 667chr_type_colours(T, chr_type(T)). 668 669chr_option_colours(Option, Value, identifier, ValCol) :- 670 chr_option_range(Option, Values), 671 !, 672 ( nonvar(Value), 673 memberchk(Value, Values) 674 -> ValCol = classify 675 ; ValCol = error 676 ). 677chr_option_colours(_, _, error, classify). 678 679chr_option_range(check_guard_bindings, [on,off]). 680chr_option_range(optimize, [off, full]). 681chr_option_range(debug, [on, off]). 682 683prolog_colourterm_colours(Term, Colours) :- 684 term_colours(Term, Colours). 685prolog_colourgoal_colours(Term, Colours) :- 686 goal_colours(Term, Colours)