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-2015, K.U. Leuven
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*/
36:- module(chr, 37 [ op(1180, xfx, ==>), 38 op(1180, xfx, <=>), 39 op(1150, fx, constraints), 40 op(1150, fx, chr_constraint), 41 op(1150, fx, chr_preprocessor), 42 op(1150, fx, handler), 43 op(1150, fx, rules), 44 op(1100, xfx, \), 45 op(1200, xfx, @), 46 op(1190, xfx, pragma), 47 op( 500, yfx, #), 48 op(1150, fx, chr_type), 49 op(1150, fx, chr_declaration), 50 op(1130, xfx, --->), 51 op(1150, fx, (?)), 52 chr_show_store/1, % +Module 53 find_chr_constraint/1, % +Pattern 54 current_chr_constraint/1, % :Pattern 55 chr_trace/0, 56 chr_notrace/0, 57 chr_leash/1 % +Ports 58 ]). 59:- use_module(library(dialect), [expects_dialect/1]). 60:- use_module(library(apply), [maplist/3]). 61:- use_module(library(lists), [member/2]). 62 63:- expects_dialect(swi). 64 65:- set_prolog_flag(generate_debug_info, false). 66 67:- multifile 68 debug_ask_continue/1, 69 preprocess/2. 70 71:- multifile user:file_search_path/2. 72:- dynamic user:file_search_path/2. 73:- dynamic chr_translated_program/1. 74 75user:file_search_path(chr, library(chr)). 76 77:- load_files([ chr(chr_translate), 78 chr(chr_runtime), 79 chr(chr_messages), 80 chr(chr_hashtable_store), 81 chr(chr_compiler_errors) 82 ], 83 [ if(not_loaded), 84 silent(true) 85 ]). 86 87:- use_module(library(lists), [member/2]).
124:- multifile chr:'$chr_module'/1. 125 126:- dynamic chr_term/3. % File, Term 127 128:- dynamic chr_pp/2. % File, Term 129 130% chr_expandable(+Term) 131% 132% Succeeds if Term is a rule that must be handled by the CHR 133% compiler. Ideally CHR definitions should be between 134% 135% :- constraints ... 136% ... 137% :- end_constraints. 138% 139% As they are not we have to use some heuristics. We assume any 140% file is a CHR after we've seen :- constraints ... 141 142chr_expandable((:- constraints _)). 143chr_expandable((constraints _)). 144chr_expandable((:- chr_constraint _)). 145chr_expandable((:- chr_type _)). 146chr_expandable((chr_type _)). 147chr_expandable((:- chr_declaration _)). 148chr_expandable(option(_, _)). 149chr_expandable((:- chr_option(_, _))). 150chr_expandable((handler _)). 151chr_expandable((rules _)). 152chr_expandable((_ <=> _)). 153chr_expandable((_ @ _)). 154chr_expandable((_ ==> _)). 155chr_expandable((_ pragma _)). 156 157% chr_expand(+Term, -Expansion) 158% 159% Extract CHR declarations and rules from the file and run the 160% CHR compiler when reaching end-of-file.
163extra_declarations([ (:- use_module(chr(chr_runtime))),
164 (:- style_check(-discontiguous)),
165 (:- style_check(-singleton)),
166 (:- style_check(-no_effect)),
167 (:- set_prolog_flag(generate_debug_info, false))
168 | Tail
169 ], Tail).179chr_expand(Term, []) :- 180 chr_expandable(Term), !, 181 prolog_load_context(source,Source), 182 prolog_load_context(source,File), 183 prolog_load_context(term_position,Pos), 184 stream_position_data(line_count,Pos,SourceLocation), 185 add_pragma_to_chr_rule(Term,source_location(File:SourceLocation),NTerm), 186 assert(chr_term(Source, SourceLocation, NTerm)). 187chr_expand(Term, []) :- 188 Term = (:- chr_preprocessor Preprocessor), !, 189 prolog_load_context(source,File), 190 assert(chr_pp(File, Preprocessor)). 191chr_expand(end_of_file, FinalProgram) :- 192 extra_declarations(FinalProgram,Program), 193 prolog_load_context(source,File), 194 findall(T, retract(chr_term(File,_Line,T)), CHR0), 195 CHR0 \== [], 196 prolog_load_context(module, Module), 197 add_debug_decl(CHR0, CHR1), 198 add_optimise_decl(CHR1, CHR2), 199 call_preprocess(CHR2, CHR3), 200 CHR4 = [ (:- module(Module, [])) | CHR3 ], 201 findall(P, retract(chr_pp(File, P)), Preprocessors), 202 ( Preprocessors = [] -> 203 CHR4 = CHR 204 ; Preprocessors = [Preprocessor] -> 205 chr_compiler_errors:chr_info(preprocessor,'\tPreprocessing with ~w.\n',[Preprocessor]), 206 call_chr_preprocessor(Preprocessor,CHR4,CHR) 207 ; 208 chr_compiler_errors:print_chr_error(error(syntax(Preprocessors),'Too many preprocessors! Only one is allowed!\n',[])), 209 fail 210 ), 211 catch(call_chr_translate(File, 212 [ (:- module(Module, [])) 213 | CHR 214 ], 215 Program0), 216 chr_error(Error), 217 ( chr_compiler_errors:print_chr_error(Error), 218 fail 219 ) 220 ), 221 delete_header(Program0, Program). 222 223 224delete_header([(:- module(_,_))|T0], T) :- !, 225 delete_header(T0, T). 226delete_header(L, L). 227 228add_debug_decl(CHR, CHR) :- 229 member(option(Name, _), CHR), Name == debug, !. 230add_debug_decl(CHR, CHR) :- 231 member((:- chr_option(Name, _)), CHR), Name == debug, !. 232add_debug_decl(CHR, [(:- chr_option(debug, Debug))|CHR]) :- 233 ( chr_current_prolog_flag(generate_debug_info, true) 234 -> Debug = on 235 ; Debug = off 236 ).
239chr_current_prolog_flag(Flag,Val) :- current_prolog_flag(Flag,Val).242add_optimise_decl(CHR, CHR) :- 243 \+(\+(memberchk((:- chr_option(optimize, _)), CHR))), !. 244add_optimise_decl(CHR, [(:- chr_option(optimize, full))|CHR]) :- 245 chr_current_prolog_flag(optimize, full), !. 246add_optimise_decl(CHR, CHR).
preprocess(CHR0, CHR).252call_preprocess(CHR0, CHR) :- 253 preprocess(CHR0, CHR), !. 254call_preprocess(CHR, CHR). 255 256% call_chr_translate(+File, +In, -Out) 257% 258% The entire chr_translate/2 translation may fail, in which case we'd 259% better issue a warning rather than simply ignoring the CHR 260% declarations. 261 262call_chr_translate(File, In, _Out) :- 263 ( chr_translate_line_info(In, File, Out0) -> 264 nb_setval(chr_translated_program,Out0), 265 fail 266 ). 267call_chr_translate(_, _In, Out) :- 268 nb_current(chr_translated_program,Out), !, 269 nb_delete(chr_translated_program). 270 271call_chr_translate(File, _, []) :- 272 print_message(error, chr(compilation_failed(File))). 273 274call_chr_preprocessor(Preprocessor,CHR,_NCHR) :- 275 ( call(Preprocessor,CHR,CHR0) -> 276 nb_setval(chr_preprocessed_program,CHR0), 277 fail 278 ). 279call_chr_preprocessor(_,_,NCHR) :- 280 nb_current(chr_preprocessed_program,NCHR), !, 281 nb_delete(chr_preprocessed_program). 282call_chr_preprocessor(Preprocessor,_,_) :- 283 chr_compiler_errors:print_chr_error(error(preprocessor,'Preprocessor `~w\' failed!\n',[Preprocessor])).
287 /******************************* 288 * SYNCHRONISE TRACER * 289 *******************************/ 290 291:- multifile 292 user:message_hook/3, 293 chr:debug_event/2, 294 chr:debug_interact/3. 295:- dynamic 296 user:message_hook/3. 297 298user:message_hook(trace_mode(OnOff), _, _) :- 299 ( OnOff == on 300 -> chr_trace 301 ; chr_notrace 302 ), 303 fail. % backtrack to other handlers 304 305:- public 306 debug_event/2, 307 debug_interact/3.
314debug_event(_State, _Event) :-
315 tracing, % are we tracing?
316 prolog_skip_level(Skip, Skip),
317 Skip \== very_deep,
318 prolog_current_frame(Me),
319 prolog_frame_attribute(Me, level, Level),
320 Level > Skip, !.328debug_interact(Event, _Depth, creep) :- 329 prolog_event(Event), 330 tracing, !. 331 332prolog_event(call(_)). 333prolog_event(exit(_)). 334prolog_event(fail(_)).
creep, skip, ancestors, nodebug, abort, fail,
break, help or exit.343 /******************************* 344 * MESSAGES * 345 *******************************/ 346 347:- multifile 348 prolog:message/3. 349 350prologmessage(chr(CHR)) --> 351 chr_message(CHR). 352 353:- multifile 354 check:trivial_fail_goal/1. 355 356checktrivial_fail_goal(_:Goal) :- 357 functor(Goal, Name, _), 358 sub_atom(Name, 0, _, _, '$chr_store_constants_'). 359 360 /******************************* 361 * TOPLEVEL PRINTING * 362 *******************************/ 363 364:- create_prolog_flag(chr_toplevel_show_store, true, []). 365 366:- residual_goals(chr_residuals).
duplicate_term(Templ, New), New = Templ
384chr_residuals(Residuals, Tail) :- 385 chr_current_prolog_flag(chr_toplevel_show_store,true), 386 nb_current(chr_global, _), !, 387 Goal = _:_, 388 findallv(Goal, current_chr_constraint(Goal), Residuals, Tail). 389chr_residuals(Residuals, Residuals). 390 391:- meta_predicate 392 findallv(, , , ). 393 394findallv(Templ, Goal, List, Tail) :- 395 List2 = [x|_], 396 State = state(List2), 397 ( call(Goal), 398 arg(1, State, L), 399 duplicate_term(Templ, New), 400 New = Templ, 401 Cons = [New|_], 402 nb_linkarg(2, L, Cons), 403 nb_linkarg(1, State, Cons), 404 fail 405 ; List2 = [x|List], 406 arg(1, State, Last), 407 arg(2, Last, Tail) 408 ). 409 410 411 /******************************* 412 * MUST BE LAST! * 413 *******************************/ 414 415:- multifile system:term_expansion/2. 416:- dynamic system:term_expansion/2. 417 418systemterm_expansion(In, Out) :- 419 \+ current_prolog_flag(xref, true), 420 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
490%%% for SSS %%% 491 492add_pragma_to_chr_rule((Name @ Rule), Pragma, Result) :- !, 493 add_pragma_to_chr_rule(Rule,Pragma,NRule), 494 Result = (Name @ NRule). 495add_pragma_to_chr_rule((Rule pragma Pragmas), Pragma, Result) :- !, 496 Result = (Rule pragma (Pragma,Pragmas)). 497add_pragma_to_chr_rule((Head ==> Body), Pragma, Result) :- !, 498 Result = (Head ==> Body pragma Pragma). 499add_pragma_to_chr_rule((Head <=> Body), Pragma, Result) :- !, 500 Result = (Head <=> Body pragma Pragma). 501add_pragma_to_chr_rule(Term,_,Term). 502 503 504 /******************************* 505 * SANDBOX SUPPORT * 506 *******************************/ 507 508:- multifile 509 sandbox:safe_primitive/1. 510 511% CHR uses a lot of global variables. We don't really mind as long as 512% the user does not mess around with global variable that may have a 513% predefined meaning. 514 515sandbox:safe_primitive(system:b_setval(V, _)) :- 516 chr_var(V). 517sandbox:safe_primitive(system:nb_linkval(V, _)) :- 518 chr_var(V). 519sandbox:safe_primitive(chr:debug_event(_,_)). 520sandbox:safe_primitive(chr:debug_interact(_,_,_)). 521 522chr_var(Name) :- sub_atom(Name, 0, _, _, '$chr'). 523chr_var(Name) :- sub_atom(Name, 0, _, _, 'chr'). 524 525 526 /******************************* 527 * SYNTAX HIGHLIGHTING * 528 *******************************/ 529 530:- multifile 531 prolog_colour:term_colours/2, 532 prolog_colour:goal_colours/2.
538term_colours((_Name @ Rule), delimiter - [ identifier, RuleColours ]) :- !, 539 term_colours(Rule, RuleColours). 540term_colours((Rule pragma _Pragma), delimiter - [RuleColours,pragma]) :- !, 541 term_colours(Rule, RuleColours). 542term_colours((Head <=> Body), delimiter - [ HeadColours, BodyColours ]) :- !, 543 chr_head(Head, HeadColours), 544 chr_body(Body, BodyColours). 545term_colours((Head ==> Body), delimiter - [ HeadColours, BodyColours ]) :- !, 546 chr_head(Head, HeadColours), 547 chr_body(Body, BodyColours). 548 549chr_head(_C#_Id, delimiter - [ head, identifier ]) :- !. 550chr_head((A \ B), delimiter - [ AC, BC ]) :- !, 551 chr_head(A, AC), 552 chr_head(B, BC). 553chr_head((A, B), functor - [ AC, BC ]) :- !, 554 chr_head(A, AC), 555 chr_head(B, BC). 556chr_head(_, head). 557 558chr_body((Guard|Goal), delimiter - [ GuardColour, GoalColour ]) :- !, 559 chr_body(Guard, GuardColour), 560 chr_body(Goal, GoalColour). 561chr_body(_, body).
568goal_colours(constraints(Decls), deprecated-[DeclColours]) :- 569 chr_constraint_colours(Decls, DeclColours). 570goal_colours(chr_constraint(Decls), built_in-[DeclColours]) :- 571 chr_constraint_colours(Decls, DeclColours). 572goal_colours(chr_type(TypeDecl), built_in-[DeclColours]) :- 573 chr_type_decl_colours(TypeDecl, DeclColours). 574goal_colours(chr_option(Option,Value), built_in-[OpC,ValC]) :- 575 chr_option_colours(Option, Value, OpC, ValC). 576 577chr_constraint_colours(Var, instantiation_error(Var)) :- 578 var(Var), !. 579chr_constraint_colours((H,T), classify-[HeadColours,BodyColours]) :- !, 580 chr_constraint_colours(H, HeadColours), 581 chr_constraint_colours(T, BodyColours). 582chr_constraint_colours(PI, Colours) :- 583 pi_to_term(PI, Goal), !, 584 Colours = predicate_indicator-[ goal(constraint(0), Goal), 585 arity 586 ]. 587chr_constraint_colours(Goal, Colours) :- 588 atom(Goal), !, 589 Colours = goal(constraint(0), Goal). 590chr_constraint_colours(Goal, Colours) :- 591 compound(Goal), !, 592 compound_name_arguments(Goal, _Name, Args), 593 maplist(chr_argspec, Args, ArgColours), 594 Colours = goal(constraint(0), Goal)-ArgColours. 595 596chr_argspec(Term, mode(Mode)-[chr_type(Type)]) :- 597 compound(Term), 598 compound_name_arguments(Term, Mode, [Type]), 599 chr_mode(Mode). 600 601chr_mode(+). 602chr_mode(?). 603chr_mode(-). 604 605pi_to_term(Name/Arity, Term) :- 606 atom(Name), integer(Arity), Arity >= 0, !, 607 functor(Term, Name, Arity). 608 609chr_type_decl_colours((Type ---> Def), built_in-[chr_type(Type), DefColours]) :- 610 chr_type_colours(Def, DefColours). 611chr_type_decl_colours((Type == Alias), built_in-[chr_type(Type), chr_type(Alias)]). 612 613chr_type_colours(Var, classify) :- 614 var(Var), !. 615chr_type_colours((A;B), control-[CA,CB]) :- !, 616 chr_type_colours(A, CA), 617 chr_type_colours(B, CB). 618chr_type_colours(T, chr_type(T)). 619 620chr_option_colours(Option, Value, identifier, ValCol) :- 621 chr_option_range(Option, Values), !, 622 ( nonvar(Value), 623 memberchk(Value, Values) 624 -> ValCol = classify 625 ; ValCol = error 626 ). 627chr_option_colours(_, _, error, classify). 628 629chr_option_range(check_guard_bindings, [on,off]). 630chr_option_range(optimize, [off, full]). 631chr_option_range(debug, [on, off]). 632 633prolog_colourterm_colours(Term, Colours) :- 634 term_colours(Term, Colours). 635prolog_colourgoal_colours(Term, Colours) :- 636 goal_colours(Term, Colours)