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 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.
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 !.
341debug_interact(Event, _Depth, creep) :- 342 prolog_event(Event), 343 tracing, 344 !. 345 346prolog_event(call(_)). 347prolog_event(exit(_)). 348prolog_event(fail(_)).
creep
, skip
, ancestors
, nodebug
, abort
, fail
,
break
, help
or exit
.357 /******************************* 358 * MESSAGES * 359 *******************************/ 360 361:- multifile 362 prolog:message/3. 363 364prologmessage(chr(CHR)) --> 365 chr_message(CHR). 366 367:- multifile 368 check:trivial_fail_goal/1. 369 370checktrivial_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).
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( , , , ). 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 *******************************/
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 449systemterm_expansion(In, Out) :- 450 \+ current_prolog_flag(xref, true), 451 in_chr_context, 452 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
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.
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).
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_colourterm_colours(Term, Colours) :- 687 term_colours(Term, Colours). 688prolog_colourgoal_colours(Term, Colours) :- 689 goal_colours(Term, Colours)