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