1:- module( edcg, [
2 op(1200, xfx, '-->>'), 3 op(1200, xfx, '==>>'), 4 op( 990, fx, '?'), 5 edcg_import_sentinel/0
6]). 7
12:- if(\+ current_op(_, _, '=>')). 13:- op(1200, xfx, '=>'). 14:- endif. 15
16:- use_module(library(debug), [debug/3]). 17:- use_module(library(lists), [member/2, selectchk/3]). 18:- use_module(library(apply), [maplist/3, maplist/4, foldl/4]). 19
22:- multifile
23 acc_info/5,
24 acc_info/7,
25 pred_info/3,
26 pass_info/1,
27 pass_info/2. 28
29:- multifile
30 prolog_clause:make_varnames_hook/5,
31 prolog_clause:unify_clause_hook/5. 32
34wants_edcg_expansion :-
35 prolog_load_context(module, Module),
36 wants_edcg_expansion(Module).
37
38wants_edcg_expansion(Module) :-
39 Module \== edcg, 40 predicate_property(Module:edcg_import_sentinel, imported_from(edcg)).
41
43edcg_import_sentinel.
44
45
50
53user:term_expansion(Term, Layout0, Expansion, Layout) :-
54 wants_edcg_expansion,
55 edcg_expand_clause(Term, Expansion, Layout0, Layout).
56
61
64
66edcg_expand_clause((H-->>B), Expansion, TermPos0, _) :-
67 edcg_expand_clause_wrap((H-->>B), Expansion, TermPos0, _).
68edcg_expand_clause((H,PB==>>B), Expansion, TermPos0, _) :-
69 edcg_expand_clause_wrap((H,PB==>>B), Expansion, TermPos0, _).
70edcg_expand_clause((H==>>B), Expansion, TermPos0, _) :-
71 edcg_expand_clause_wrap((H==>>B), Expansion, TermPos0, _).
72
73edcg_expand_clause_wrap(Term, Expansion, TermPos0, TermPos) :-
74 75 76 77 78 ( '_expand_clause'(Term, Expansion, TermPos0, TermPos)
79 -> true
80 ; throw(error('FAILED_expand_clause'(Term, Expansion, TermPos0, TermPos), _))
81 ),
82 83 84 85 86 true.
87
91'_expand_clause'((H-->>B), Expansion, TermPos0, TermPos) =>
92 TermPos0 = term_position(From,To,ArrowFrom,ArrowTo,[H_pos,B_pos]),
93 TermPos = term_position(From,To,ArrowFrom,ArrowTo,[Hx_pos,Bx_pos]),
94 Expansion = (TH:-TB),
95 '_expand_head_body'(H, B, TH, TB, NewAcc, H_pos,B_pos, Hx_pos,Bx_pos),
96 '_finish_acc'(NewAcc),
97 !.
98'_expand_clause'((H,PB==>>B), Expansion, _TermPos0, _) => 99 100 Expansion = (TH,Guards=>TB2),
101 '_expand_guard'(PB, Guards),
102 '_expand_head_body'(H, B, TH, TB, NewAcc, _H_pos,_B_pos, _Hx_pos,_Bx_pos),
103 '_finish_acc_ssu'(NewAcc, TB, TB2),
104 !.
105'_expand_clause'((H==>>B), Expansion, TermPos0, TermPos) =>
106 TermPos0 = term_position(From,To,ArrowFrom,ArrowTo,[H_pos,B_pos]),
107 TermPos = term_position(From,To,ArrowFrom,ArrowTo,[Hx_pos,Bx_pos]),
108 Expansion = (TH=>TB2),
109 '_expand_head_body'(H, B, TH, TB, NewAcc, H_pos,B_pos, Hx_pos,Bx_pos),
110 '_finish_acc_ssu'(NewAcc, TB, TB2),
111 !.
112
113:- det('_expand_guard'/2). 116'_expand_guard'((?G0,G2), Expansion) =>
117 Expansion = (G, GE2),
118 '_expand_guard_curly'(G0, G),
119 '_expand_guard'(G2, GE2).
120'_expand_guard'(?G0, G) =>
121 '_expand_guard_curly'(G0, G).
122'_expand_guard'(G, _) =>
123 throw(error(type_error(guard,G),_)).
124
125:- det('_expand_guard_curly'/2). 126'_expand_guard_curly'({G}, G) :- !.
127'_expand_guard_curly'(G, G).
128
129
130:- det('_expand_head_body'/9). 131'_expand_head_body'(H, B, TH, TB, NewAcc, _H_pos,_B_pos, _Hx_pos,_Bx_pos) :-
132 functor(H, Na, Ar),
133 '_has_hidden'(H, HList), 134 debug(edcg,'Expanding ~w',[H]),
135 '_new_goal'(H, HList, HArity, TH),
136 '_create_acc_pass'(HList, HArity, TH, Acc, Pass),
137 '_expand_goal'(B, TB, Na/Ar, HList, Acc, NewAcc, Pass),
138 !.
139
141'_expand_goal'((G1,G2), Expansion, NaAr, HList, Acc, NewAcc, Pass) =>
142 Expansion = (TG1,TG2),
143 '_expand_goal'(G1, TG1, NaAr, HList, Acc, MidAcc, Pass),
144 '_expand_goal'(G2, TG2, NaAr, HList, MidAcc, NewAcc, Pass).
145'_expand_goal'((G1->G2;G3), Expansion, NaAr, HList, Acc, NewAcc, Pass) =>
146 Expansion = (TG1->TG2;TG3),
147 '_expand_goal'(G1, TG1, NaAr, HList, Acc, MidAcc, Pass),
148 '_expand_goal'(G2, MG2, NaAr, HList, MidAcc, Acc1, Pass),
149 '_expand_goal'(G3, MG3, NaAr, HList, Acc, Acc2, Pass),
150 '_merge_acc'(Acc, Acc1, MG2, TG2, Acc2, MG3, TG3, NewAcc).
151'_expand_goal'((G1*->G2;G3), Expansion, NaAr, HList, Acc, NewAcc, Pass) =>
152 Expansion = (TG1*->TG2;TG3),
153 '_expand_goal'(G1, TG1, NaAr, HList, Acc, MidAcc, Pass),
154 '_expand_goal'(G2, MG2, NaAr, HList, MidAcc, Acc1, Pass),
155 '_expand_goal'(G3, MG3, NaAr, HList, Acc, Acc2, Pass),
156 '_merge_acc'(Acc, Acc1, MG2, TG2, Acc2, MG3, TG3, NewAcc).
157'_expand_goal'((G1;G2), Expansion, NaAr, HList, Acc, NewAcc, Pass) =>
158 Expansion = (TG1;TG2),
159 '_expand_goal'(G1, MG1, NaAr, HList, Acc, Acc1, Pass),
160 '_expand_goal'(G2, MG2, NaAr, HList, Acc, Acc2, Pass),
161 '_merge_acc'(Acc, Acc1, MG1, TG1, Acc2, MG2, TG2, NewAcc).
162'_expand_goal'((G1->G2), Expansion, NaAr, HList, Acc, NewAcc, Pass) =>
163 Expansion = (TG1->TG2),
164 '_expand_goal'(G1, TG1, NaAr, HList, Acc, MidAcc, Pass),
165 '_expand_goal'(G2, TG2, NaAr, HList, MidAcc, NewAcc, Pass).
166'_expand_goal'((G1*->G2), Expansion, NaAr, HList, Acc, NewAcc, Pass) =>
167 Expansion = (TG1*->TG2),
168 '_expand_goal'(G1, TG1, NaAr, HList, Acc, MidAcc, Pass),
169 '_expand_goal'(G2, TG2, NaAr, HList, MidAcc, NewAcc, Pass).
170'_expand_goal'((\+G), Expansion, NaAr, HList, Acc, NewAcc, Pass) =>
171 Expansion = (\+TG),
172 NewAcc = Acc,
173 '_expand_goal'(G, TG, NaAr, HList, Acc, _TempAcc, Pass).
174'_expand_goal'({G}, Expansion, _, _, Acc, NewAcc, _) =>
175 Expansion = G,
176 NewAcc = Acc.
177'_expand_goal'(insert(X,Y), Expansion, _, _, Acc, NewAcc, _) =>
178 Expansion = (LeftA=X),
179 '_replace_acc'(dcg, LeftA, RightA, Y, RightA, Acc, NewAcc), !.
180'_expand_goal'(insert(X,Y):A, Expansion, _, _, Acc, NewAcc, _) =>
181 Expansion = (LeftA=X),
182 '_replace_acc'(A, LeftA, RightA, Y, RightA, Acc, NewAcc),
183 debug(edcg,'Expanding accumulator goal: ~w',[insert(X,Y):A]),
184 !.
186'_expand_goal'((G:A), TG, _, _HList, Acc, NewAcc, Pass),
187 \+'_list'(G),
188 '_has_hidden'(G, []) =>
189 '_make_list'(A, AList),
190 '_new_goal'(G, AList, GArity, TG),
191 '_use_acc_pass'(AList, GArity, TG, Acc, NewAcc, Pass).
194'_expand_goal'((G:A), TG, _, _HList, Acc, NewAcc, Pass),
195 \+'_list'(G),
196 '_has_hidden'(G, GList), GList\==[] =>
197 '_make_list'(A, L),
198 '_new_goal'(G, GList, GArity, TG),
199 '_replace_defaults'(GList, NGList, L),
200 '_use_acc_pass'(NGList, GArity, TG, Acc, NewAcc, Pass).
201'_expand_goal'((L:A), Joiner, NaAr, _, Acc, NewAcc, _),
202 '_list'(L) =>
203 '_joiner'(L, A, NaAr, Joiner, Acc, NewAcc).
204'_expand_goal'(L, Joiner, NaAr, _, Acc, NewAcc, _),
205 '_list'(L) =>
206 '_joiner'(L, dcg, NaAr, Joiner, Acc, NewAcc).
207'_expand_goal'((X/A), Expansion, _, _, Acc, NewAcc, _),
208 atomic(A),
209 member(acc(A,X,_), Acc) =>
210 Expansion = true,
211 NewAcc = Acc,
212 debug(edcg,'Expanding accumulator goal: ~w',[X/A]),
213 !.
214'_expand_goal'((X/A), Expansion, _, _, Acc, NewAcc, Pass),
215 atomic(A),
216 member(pass(A,X), Pass) =>
217 Expansion = true,
218 NewAcc = Acc,
219 debug(edcg,'Expanding passed argument goal: ~w',[X/A]),
220 !.
221'_expand_goal'((A/X), Expansion, _, _, Acc, NewAcc, _),
222 atomic(A),
223 member(acc(A,_,X), Acc) =>
224 Expansion = true,
225 NewAcc = Acc.
226'_expand_goal'((X/A/Y), Expansion, _, _, Acc, NewAcc, _),
227 member(acc(A,X,Y), Acc),
228 var(X), var(Y), atomic(A) =>
229 Expansion = true,
230 NewAcc = Acc.
231'_expand_goal'((X/Y), true, NaAr, _, Acc, NewAcc, _) =>
232 NewAcc = Acc,
233 print_message(warning,missing_hidden_parameter(NaAr,X/Y)).
235'_expand_goal'(G, TG, _HList, _, Acc, NewAcc, Pass) =>
236 '_has_hidden'(G, GList), !,
237 '_new_goal'(G, GList, GArity, TG),
238 '_use_acc_pass'(GList, GArity, TG, Acc, NewAcc, Pass).
239
241
243
244:- det('_create_acc_pass'/5). 250'_create_acc_pass'([], _, _, Acc, Pass) =>
251 Acc = [],
252 Pass = [].
253'_create_acc_pass'([A|AList], Index, TGoal, Acc2, Pass),
254 '_is_acc'(A) =>
255 Acc2 = [acc(A,LeftA,RightA)|Acc],
256 Index1 is Index+1,
257 arg(Index1, TGoal, LeftA),
258 Index2 is Index+2,
259 arg(Index2, TGoal, RightA),
260 '_create_acc_pass'(AList, Index2, TGoal, Acc, Pass).
261'_create_acc_pass'([A|AList], Index, TGoal, Acc, Pass2),
262 '_is_pass'(A) =>
263 Pass2 = [pass(A,Arg)|Pass],
264 Index1 is Index+1,
265 arg(Index1, TGoal, Arg),
266 '_create_acc_pass'(AList, Index1, TGoal, Acc, Pass).
267'_create_acc_pass'([A|_AList], _Index, _TGoal, _Acc, _Pass),
268 \+'_is_acc'(A),
269 \+'_is_pass'(A) =>
270 print_message(error,not_a_hidden_param(A)).
271
272
273:- det('_use_acc_pass'/6). 276'_use_acc_pass'([], _, _, Acc, NewAcc, _) =>
277 NewAcc = Acc.
280'_use_acc_pass'([A|GList], Index, TGoal, Acc, NewAcc, Pass),
281 '_replace_acc'(A, LeftA, RightA, MidA, RightA, Acc, MidAcc) =>
282 Index1 is Index+1,
283 arg(Index1, TGoal, LeftA),
284 Index2 is Index+2,
285 arg(Index2, TGoal, MidA),
286 '_use_acc_pass'(GList, Index2, TGoal, MidAcc, NewAcc, Pass).
288'_use_acc_pass'([A|GList], Index, TGoal, Acc, NewAcc, Pass),
289 '_acc_info'(A, LStart, RStart) =>
290 Index1 is Index+1,
291 arg(Index1, TGoal, LStart),
292 Index2 is Index+2,
293 arg(Index2, TGoal, RStart),
294 '_use_acc_pass'(GList, Index2, TGoal, Acc, NewAcc, Pass).
296'_use_acc_pass'([A|GList], Index, TGoal, Acc, NewAcc, Pass),
297 '_is_pass'(A),
298 member(pass(A,Arg), Pass) =>
299 Index1 is Index+1,
300 arg(Index1, TGoal, Arg),
301 '_use_acc_pass'(GList, Index1, TGoal, Acc, NewAcc, Pass).
303'_use_acc_pass'([A|GList], Index, TGoal, Acc, NewAcc, Pass),
304 '_pass_info'(A, AStart) =>
305 Index1 is Index+1,
306 arg(Index1, TGoal, AStart),
307 '_use_acc_pass'(GList, Index1, TGoal, Acc, NewAcc, Pass).
309'_use_acc_pass'([A|_GList], _Index, _TGoal, Acc, Acc, _Pass) =>
310 print_message(error,not_a_hidden_param(A)).
311
312:- det('_finish_acc'/1). 316'_finish_acc'([]).
317'_finish_acc'([acc(_,Link,Link)|Acc]) :- '_finish_acc'(Acc).
318
319:- det('_finish_acc_ssu'/3). 320'_finish_acc_ssu'([], TB, TB).
321'_finish_acc_ssu'([acc(_,Link0,Link1)|Acc], TB0, TB) :-
322 '_finish_acc_ssu'(Acc, (Link0=Link1,TB0), TB).
323
326'_replace_acc'(A, L1, R1, L2, R2, Acc, NewAcc) :-
327 member(acc(A,L1,R1), Acc), !,
328 '_replace'(acc(A,_,_), acc(A,L2,R2), Acc, NewAcc).
329
330:- det('_merge_acc'/8). 332'_merge_acc'([], [], G1, G1, [], G2, G2, []) :- !.
333'_merge_acc'([acc(Acc,OL,R)|Accs], [acc(Acc,L1,R)|Accs1], G1, NG1,
334 [acc(Acc,L2,R)|Accs2], G2, NG2, [acc(Acc,NL,R)|NewAccs]) :- !,
335 ( ( OL == L1, OL \== L2 ) ->
336 MG1 = (G1,L1=L2), MG2 = G2, NL = L2
337 ; ( OL == L2, OL \== L1 ) ->
338 MG2 = (G2,L2=L1), MG1 = G1, NL = L1
339 ; MG1 = G1, MG2 = G2, L1 = L2, L2 = NL ),
340 '_merge_acc'(Accs, Accs1, MG1, NG1, Accs2, MG2, NG2, NewAccs).
341
343
345
346:- det('_match'/4). 348'_match'(L, H, _, _) :- L>H, !.
349'_match'(L, H, P, Q) :- L=<H, !,
350 arg(L, P, A),
351 arg(L, Q, A),
352 L1 is L+1,
353 '_match'(L1, H, P, Q).
354
355
356'_list'(L) :- nonvar(L), L=[_|_], !.
357'_list'(L) :- L==[], !.
358
359:- det('_make_list'/2). 360'_make_list'(A, [A]) :- \+'_list'(A), !.
361'_make_list'(L, L) :- '_list'(L), !.
362
363:- det('_replace'/4). 365'_replace'(_, _, [], []) :- !.
366'_replace'(A, B, [A|L], [B|R]) :- !,
367 '_replace'(A, B, L, R).
368'_replace'(A, B, [C|L], [C|R]) :-
369 \+C=A, !,
370 '_replace'(A, B, L, R).
371
373
375
379'_new_goal'(Goal, GList, GArity, TGoal) :-
380 functor(Goal, Name, GArity),
381 '_number_args'(GList, GArity, TArity),
382 functor(TGoal, Name, TArity),
383 '_match'(1, GArity, Goal, TGoal).
384
386'_number_args'([], N, N).
387'_number_args'([A|List], N, M) :-
388 '_is_acc'(A), !,
389 N2 is N+2,
390 '_number_args'(List, N2, M).
391'_number_args'([A|List], N, M) :-
392 '_is_pass'(A), !,
393 N1 is N+1,
394 '_number_args'(List, N1, M).
395'_number_args'([_|List], N, M) :- !,
396 397 '_number_args'(List, N, M).
398
400'_has_hidden'(G, GList) :-
401 functor(G, GName, GArity),
402 ( pred_info(GName, GArity, GList)
403 -> true
404 ; GList = []
405 ).
406
408'_is_acc'(A), atomic(A) => '_acc_info'(A, _, _, _, _, _, _).
409'_is_acc'(A), functor(A, N, 2) => '_acc_info'(N, _, _, _, _, _, _).
410
412'_is_pass'(A), atomic(A) => '_pass_info'(A, _).
413'_is_pass'(A), functor(A, N, 1) => '_pass_info'(N, _).
414
416'_acc_info'(AccParams, LStart, RStart) :-
417 functor(AccParams, Acc, 2),
418 '_is_acc'(Acc), !,
419 arg(1, AccParams, LStart),
420 arg(2, AccParams, RStart).
421'_acc_info'(Acc, LStart, RStart) :-
422 '_acc_info'(Acc, _, _, _, _, LStart, RStart).
423
425'_acc_info'(Acc, Term, Left, Right, Joiner, LStart, RStart) :-
426 acc_info(Acc, Term, Left, Right, Joiner, LStart, RStart).
427'_acc_info'(Acc, Term, Left, Right, Joiner, _, _) :-
428 acc_info(Acc, Term, Left, Right, Joiner).
429'_acc_info'(dcg, Term, Left, Right, Left=[Term|Right], _, []).
430
433'_pass_info'(PassParam, PStart) :-
434 functor(PassParam, Pass, 1),
435 '_is_pass'(Pass), !,
436 arg(1, PassParam, PStart).
437'_pass_info'(Pass, PStart) :-
438 pass_info(Pass, PStart).
439'_pass_info'(Pass, _) :-
440 pass_info(Pass).
441
443'_joiner'([], _, _, true, Acc, Acc).
444'_joiner'([Term|List], A, NaAr, (Joiner,LJoiner), Acc, NewAcc) :-
445 '_replace_acc'(A, LeftA, RightA, MidA, RightA, Acc, MidAcc),
446 '_acc_info'(A, Term, LeftA, MidA, Joiner, _, _), !,
447 '_joiner'(List, A, NaAr, LJoiner, MidAcc, NewAcc).
449'_joiner'([_Term|List], A, NaAr, Joiner, Acc, NewAcc) :-
450 print_message(warning, missing_accumulator(NaAr,A)),
451 '_joiner'(List, A, NaAr, Joiner, Acc, NewAcc).
452
454'_replace_defaults'([], [], _).
455'_replace_defaults'([A|GList], [NA|NGList], AList) :-
456 '_replace_default'(A, NA, AList),
457 '_replace_defaults'(GList, NGList, AList).
458
459'_replace_default'(A, NewA, AList) :- 460 functor(NewA, A, 2),
461 member(NewA, AList), !.
462'_replace_default'(A, NewA, AList) :- 463 functor(NewA, A, 1),
464 member(NewA, AList), !.
465'_replace_default'(A, NewA, _) :- 466 A=NewA.
467
469
470:- multifile prolog:message//1. 471
472prolog:message(missing_accumulator(Predicate,Accumulator)) -->
473 ['In ~w the accumulator ''~w'' does not exist'-[Predicate,Accumulator]].
474prolog:message(missing_hidden_parameter(Predicate,Term)) -->
475 ['In ~w the term ''~w'' uses a non-existent hidden parameter.'-[Predicate,Term]].
476prolog:message(not_a_hidden_param(Name)) -->
477 ['~w is not a hidden parameter'-[Name]].
479
488valid_termpos(Term, TermPos) :-
489 ( valid_termpos_(Term, TermPos)
490 -> true
491 ; fail 492 ).
493
494valid_termpos_(Var, _From-_To) :- var(Var).
495valid_termpos_(Atom, _From-_To) :- atom(Atom), !.
496valid_termpos_(Number, _From-_To) :- number(Number), !.
497valid_termpos_(String, string_position(_From,_To)) :- string(String), !.
498valid_termpos_([], _From-_To) :- !.
499valid_termpos_({Arg}, brace_term_position(_From,_To,ArgPos)) :-
500 valid_termpos(Arg, ArgPos), !.
502valid_termpos_([Hd|Tl], list_position(_From,_To, ElemsPos, none)) :-
503 maplist(valid_termpos, [Hd|Tl], ElemsPos),
504 list_tail([Hd|Tl], _, []), !.
505valid_termpos_([Hd|Tl], list_position(_From,_To, ElemsPos, TailPos)) :-
506 list_tail([Hd|Tl], HdPart, Tail),
507 tailPos \= none, Tail \= [],
508 maplist(valid_termpos, HdPart, ElemsPos),
509 valid_termpos(Tail, TailPos), !.
510valid_termpos_(Term, term_position(_From,_To, FFrom,FTo,SubPos)) :-
511 compound_name_arguments(Term, Name, Arguments),
512 valid_termpos(Name, FFrom-FTo),
513 maplist(valid_termpos, Arguments, SubPos), !.
514valid_termpos_(Dict, dict_position(_From,_To,TagFrom,TagTo,KeyValuePosList)) :-
515 dict_pairs(Dict, Tag, Pairs),
516 valid_termpos(Tag, TagFrom-TagTo),
517 foldl(valid_termpos_dict, Pairs, KeyValuePosList, []), !.
520valid_termpos_(Term, parentheses_term_position(_From,_To,ContentPos)) :-
521 valid_termpos(Term, ContentPos), !.
523valid_termpos_(_Term, quasi_quotation_position(_From,_To,SyntaxTerm,SyntaxPos,_ContentPos)) :-
524 valid_termpos(SyntaxTerm, SyntaxPos), !.
525
526:- det(valid_termpos_dict/3). 527valid_termpos_dict(Key-Value, KeyValuePosList0, KeyValuePosList1) :-
528 selectchk(key_value_position(_From,_To,_SepFrom,_SepTo,Key,KeyPos,ValuePos),
529 KeyValuePosList0, KeyValuePosList1),
530 valid_termpos(Key, KeyPos),
531 valid_termpos(Value, ValuePos).
532
533:- det(list_tail/3). 534list_tail([X|Xs], HdPart, Tail) =>
535 HdPart = [X|HdPart2],
536 list_tail(Xs, HdPart2, Tail).
537list_tail(Tail0, HdPart, Tail) => HdPart = [], Tail0 = Tail