34
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, 53 find_chr_constraint/1, 54 chr_trace/0,
55 chr_notrace/0,
56 chr_leash/1 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]). 85
119
120:- multifile chr:'$chr_module'/1. 121
122:- dynamic chr_term/3. 123
124:- dynamic chr_pp/2. 125
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
157
([ (:- 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).
167
174
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
([(:- 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 ).
233
235chr_current_prolog_flag(Flag,Val) :- current_prolog_flag(Flag,Val).
237
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).
243
247
248call_preprocess(CHR0, CHR) :-
249 preprocess(CHR0, CHR), !.
250call_preprocess(CHR, CHR).
251
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])).
280
282
283 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. 300
301:- public
302 debug_event/2,
303 debug_interact/3. 304
309
310debug_event(_State, _Event) :-
311 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, !.
317
323
324debug_interact(Event, _Depth, creep) :-
325 prolog_event(Event),
326 tracing, !.
327
328prolog_event(call(_)).
329prolog_event(exit(_)).
330prolog_event(fail(_)).
331
337
338
339 342
343:- multifile
344 prolog:message/3. 345
346prolog:message(chr(CHR)) -->
347 chr_message(CHR).
348
349:- multifile
350 check:trivial_fail_goal/1. 351
352check:trivial_fail_goal(_:Goal) :-
353 functor(Goal, Name, _),
354 sub_atom(Name, 0, _, _, '$chr_store_constants_').
355
356 359
360:- create_prolog_flag(chr_toplevel_show_store, true, []). 361
362:- residual_goals(chr_residuals). 363
379
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(?, 0, ?, ?). 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 410
411:- multifile system:term_expansion/2. 412:- dynamic system:term_expansion/2. 413
414system:term_expansion(In, Out) :-
415 \+ current_prolog_flag(xref, true),
416 chr_expand(In, Out).
418
485
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 503
504:- multifile
505 sandbox:safe_primitive/1. 506
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 525
526:- multifile
527 prolog_colour:term_colours/2,
528 prolog_colour:goal_colours/2. 529
533
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).
558
559
563
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_colour:term_colours(Term, Colours) :-
630 term_colours(Term, Colours).
631prolog_colour:goal_colours(Term, Colours) :-
632 goal_colours(Term, Colours)