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