1:- module( edcg, [
    2    op(1200, xfx, '-->>'),   % Similar to '-->'
    3    op(1200, xfx, '==>>'),   % Similar to '-->'
    4    op( 990,  fx, '?'),      % For guards with '==>>'
    5    edcg_import_sentinel/0
    6]).    7
    8% If running a version of SWI-Prolog older than 8.3.19, define the
    9% '=>' operator to prevent syntax errors in this module.  The '==>>'
   10% operator is still defined in the module export, even though it'll
   11% generate a runtime error if it's used.
   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]).   18
   19% These predicates define extra arguments and are defined in the
   20% modules that use the edcg module.
   21:- multifile
   22    acc_info/5,
   23    acc_info/7,
   24    pred_info/3,
   25    pass_info/1,
   26    pass_info/2.   27
   28
   29% True if the module being read has opted-in to EDCG macro expansion.
   30wants_edcg_expansion :-
   31    prolog_load_context(module, Module),
   32    Module \== edcg,  % don't expand macros in our own library
   33    predicate_property(Module:edcg_import_sentinel, imported_from(edcg)).
   34
   35% dummy predicate exported to detect which modules want EDCG expansion
   36edcg_import_sentinel.
   37
   38
   39% term_expansion/4 is used to work around SWI-Prolog's attempts to
   40% match variable names when doing a listing (or interactive trace) and
   41% getting confused; this sometimes results in a strange error message
   42% for an unknown extended_pos(Pos,N).
   43
   44% Returning a variable for _Layout2 means "I don't know".
   45% See https://swi-prolog.discourse.group/t/strange-warning-message-from-compile-or-listing/3774
   46
   47% TODO: support ((H,PB-->>B) [same as regular DCG]
   48user:term_expansion((H-->>B), _Layout1, Expansion, _Layout2) :-
   49    edcg_term_expansion((H-->>B), Expansion).
   50user:term_expansion((H,PB==>>B), _Layout1, Expansion, _Layout2) :-
   51    edcg_term_expansion((H,PB==>>B), Expansion).
   52user:term_expansion((H==>>B), _Layout1, Expansion, _Layout2) :-
   53    edcg_term_expansion((H==>>B), Expansion).
   54
   55
   56% Perform EDCG macro expansion
   57% TODO: support ((H,PB-->>B) [same as regular DCG]
   58edcg_term_expansion((H-->>B), (TH:-TB)) :-
   59    term_expansion_(H, B, TH, TB, NewAcc),
   60    '_finish_acc'(NewAcc),
   61    !.
   62edcg_term_expansion((H,PB==>>B), (TH,Guards=>TB2)) :-
   63    '_guard_expansion_'(PB, Guards),
   64    term_expansion_(H, B, TH, TB, NewAcc),
   65    '_finish_acc_ssu'(NewAcc, TB, TB2),
   66    !.
   67edcg_term_expansion((H==>>B), (TH=>TB2)) :-
   68    term_expansion_(H, B, TH, TB, NewAcc),
   69    '_finish_acc_ssu'(NewAcc, TB, TB2),
   70    !.
   71
   72% TODO: Do we want to expand the guards?
   73%       For now, just verify that they all start with '?'
   74'_guard_expansion_'((?G0,G2), (G, GE2)) :- !,
   75    '_guard_expansion_curly_'(G0, G),
   76    '_guard_expansion_'(G2, GE2).
   77'_guard_expansion_'(?G0, G) :- !,
   78    '_guard_expansion_curly_'(G0, G).
   79'_guard_expansion_'(G, _) :-
   80    throw(error(type_error(guard,G),_)).
   81
   82'_guard_expansion_curly_'({G}, G) :- !.
   83'_guard_expansion_curly_'(G, G).
   84
   85
   86term_expansion_(H, B, TH, TB, NewAcc) :-
   87    wants_edcg_expansion,
   88    functor(H, Na, Ar),
   89    '_has_hidden'(H, HList),
   90    debug(edcg,'Expanding ~w',[H]),
   91    '_new_goal'(H, HList, HArity, TH),
   92    '_create_acc_pass'(HList, HArity, TH, Acc, Pass),
   93    '_expand_goal'(B, TB, Na/Ar, HList, Acc, NewAcc, Pass).
   94
   95% Expand a goal:
   96'_expand_goal'((G1,G2), (TG1,TG2), NaAr, HList, Acc, NewAcc, Pass) :-
   97    '_expand_goal'(G1, TG1, NaAr, HList, Acc, MidAcc, Pass),
   98    '_expand_goal'(G2, TG2, NaAr, HList, MidAcc, NewAcc, Pass).
   99'_expand_goal'((G1->G2;G3), (TG1->TG2;TG3), NaAr, HList, Acc, NewAcc, Pass) :-
  100    '_expand_goal'(G1, TG1, NaAr, HList, Acc, MidAcc, Pass),
  101    '_expand_goal'(G2, MG2, NaAr, HList, MidAcc, Acc1, Pass),
  102    '_expand_goal'(G3, MG3, NaAr, HList, Acc, Acc2, Pass),
  103    '_merge_acc'(Acc, Acc1, MG2, TG2, Acc2, MG3, TG3, NewAcc).
  104'_expand_goal'((G1*->G2;G3), (TG1*->TG2;TG3), NaAr, HList, Acc, NewAcc, Pass) :-
  105    '_expand_goal'(G1, TG1, NaAr, HList, Acc, MidAcc, Pass),
  106    '_expand_goal'(G2, MG2, NaAr, HList, MidAcc, Acc1, Pass),
  107    '_expand_goal'(G3, MG3, NaAr, HList, Acc, Acc2, Pass),
  108    '_merge_acc'(Acc, Acc1, MG2, TG2, Acc2, MG3, TG3, NewAcc).
  109'_expand_goal'((G1;G2), (TG1;TG2), NaAr, HList, Acc, NewAcc, Pass) :-
  110    '_expand_goal'(G1, MG1, NaAr, HList, Acc, Acc1, Pass),
  111    '_expand_goal'(G2, MG2, NaAr, HList, Acc, Acc2, Pass),
  112    '_merge_acc'(Acc, Acc1, MG1, TG1, Acc2, MG2, TG2, NewAcc).
  113'_expand_goal'((G1->G2), (TG1->TG2), NaAr, HList, Acc, NewAcc, Pass) :-
  114    '_expand_goal'(G1, TG1, NaAr, HList, Acc, MidAcc, Pass),
  115    '_expand_goal'(G2, TG2, NaAr, HList, MidAcc, NewAcc, Pass).
  116'_expand_goal'((G1*->G2), (TG1->TG2), NaAr, HList, Acc, NewAcc, Pass) :-
  117    '_expand_goal'(G1, TG1, NaAr, HList, Acc, MidAcc, Pass),
  118    '_expand_goal'(G2, TG2, NaAr, HList, MidAcc, NewAcc, Pass).
  119'_expand_goal'((\+G), (\+TG), NaAr, HList, Acc, Acc, Pass) :-
  120    '_expand_goal'(G, TG, NaAr, HList, Acc, _TempAcc, Pass).
  121'_expand_goal'({G}, G, _, _, Acc, Acc, _) :- !.
  122'_expand_goal'(insert(X,Y), LeftA=X, _, _, Acc, NewAcc, _) :-
  123    '_replace_acc'(dcg, LeftA, RightA, Y, RightA, Acc, NewAcc), !.
  124'_expand_goal'(insert(X,Y):A, LeftA=X, _, _, Acc, NewAcc, _) :-
  125    '_replace_acc'(A, LeftA, RightA, Y, RightA, Acc, NewAcc),
  126    debug(edcg,'Expanding accumulator goal: ~w',[insert(X,Y):A]),
  127    !.
  128% Force hidden arguments in L to be appended to G:
  129'_expand_goal'((G:A), TG, _, _HList, Acc, NewAcc, Pass) :-
  130    \+'_list'(G),
  131    '_has_hidden'(G, []), !,
  132    '_make_list'(A, AList),
  133    '_new_goal'(G, AList, GArity, TG),
  134    '_use_acc_pass'(AList, GArity, TG, Acc, NewAcc, Pass).
  135% Use G's regular hidden arguments & override defaults for those arguments
  136% not in the head:
  137'_expand_goal'((G:A), TG, _, _HList, Acc, NewAcc, Pass) :-
  138    \+'_list'(G),
  139    '_has_hidden'(G, GList), GList\==[], !,
  140    '_make_list'(A, L),
  141    '_new_goal'(G, GList, GArity, TG),
  142    '_replace_defaults'(GList, NGList, L),
  143    '_use_acc_pass'(NGList, GArity, TG, Acc, NewAcc, Pass).
  144'_expand_goal'((L:A), Joiner, NaAr, _, Acc, NewAcc, _) :-
  145    '_list'(L), !,
  146    '_joiner'(L, A, NaAr, Joiner, Acc, NewAcc).
  147'_expand_goal'(L, Joiner, NaAr, _, Acc, NewAcc, _) :-
  148    '_list'(L), !,
  149    '_joiner'(L, dcg, NaAr, Joiner, Acc, NewAcc).
  150'_expand_goal'((X/A), true, _, _, Acc, Acc, _) :-
  151    atomic(A),
  152    member(acc(A,X,_), Acc),
  153    debug(edcg,'Expanding accumulator goal: ~w',[X/A]),
  154    !.
  155'_expand_goal'((X/A), true, _, _, Acc, Acc, Pass) :-
  156    atomic(A),
  157    member(pass(A,X), Pass),
  158    debug(edcg,'Expanding passed argument goal: ~w',[X/A]),
  159    !.
  160'_expand_goal'((A/X), true, _, _, Acc, Acc, _) :-
  161    atomic(A),
  162    member(acc(A,_,X), Acc), !.
  163'_expand_goal'((X/A/Y), true, _, _, Acc, Acc, _) :-
  164    var(X), var(Y), atomic(A),
  165    member(acc(A,X,Y), Acc), !.
  166'_expand_goal'((X/Y), true, NaAr, _, Acc, Acc, _) :-
  167    print_message(warning,missing_hidden_parameter(NaAr,X/Y)).
  168% Defaulty cases:
  169'_expand_goal'(G, TG, _HList, _, Acc, NewAcc, Pass) :-
  170    '_has_hidden'(G, GList), !,
  171    '_new_goal'(G, GList, GArity, TG),
  172    '_use_acc_pass'(GList, GArity, TG, Acc, NewAcc, Pass).
  173
  174% ==== The following was originally acc-pass.pl ====
  175
  176% Operations on the Acc and Pass data structures:
  177
  178% Create the Acc and Pass data structures:
  179% Acc contains terms of the form acc(A,LeftA,RightA) where A is the name of an
  180% accumulator, and RightA and LeftA are the accumulating parameters.
  181% Pass contains terms of the form pass(A,Arg) where A is the name of a passed
  182% argument, and Arg is the argument.
  183'_create_acc_pass'([], _, _, [], []).
  184'_create_acc_pass'([A|AList], Index, TGoal, [acc(A,LeftA,RightA)|Acc], Pass) :-
  185    '_is_acc'(A), !,
  186    Index1 is Index+1,
  187    arg(Index1, TGoal, LeftA),
  188    Index2 is Index+2,
  189    arg(Index2, TGoal, RightA),
  190    '_create_acc_pass'(AList, Index2, TGoal, Acc, Pass).
  191'_create_acc_pass'([A|AList], Index, TGoal, Acc, [pass(A,Arg)|Pass]) :-
  192    '_is_pass'(A), !,
  193    Index1 is Index+1,
  194    arg(Index1, TGoal, Arg),
  195    '_create_acc_pass'(AList, Index1, TGoal, Acc, Pass).
  196'_create_acc_pass'([A|_AList], _Index, _TGoal, _Acc, _Pass) :-
  197    \+'_is_acc'(A),
  198    \+'_is_pass'(A),
  199    print_message(error,not_a_hidden_param(A)).
  200
  201
  202% Use the Acc and Pass data structures to create the arguments of a body goal:
  203% Add the hidden parameters named in GList to the goal.
  204'_use_acc_pass'([], _, _, Acc, Acc, _).
  205% 1a. The accumulator A is used in the head:
  206'_use_acc_pass'([A|GList], Index, TGoal, Acc, NewAcc, Pass) :-
  207    '_replace_acc'(A, LeftA, RightA, MidA, RightA, Acc, MidAcc), !,
  208    Index1 is Index+1,
  209    arg(Index1, TGoal, LeftA),
  210    Index2 is Index+2,
  211    arg(Index2, TGoal, MidA),
  212    '_use_acc_pass'(GList, Index2, TGoal, MidAcc, NewAcc, Pass).
  213% 1b. The accumulator A is not used in the head:
  214'_use_acc_pass'([A|GList], Index, TGoal, Acc, NewAcc, Pass) :-
  215    '_acc_info'(A, LStart, RStart), !,
  216    Index1 is Index+1,
  217    arg(Index1, TGoal, LStart),
  218    Index2 is Index+2,
  219    arg(Index2, TGoal, RStart),
  220    '_use_acc_pass'(GList, Index2, TGoal, Acc, NewAcc, Pass).
  221% 2a. The passed argument A is used in the head:
  222'_use_acc_pass'([A|GList], Index, TGoal, Acc, NewAcc, Pass) :-
  223    '_is_pass'(A),
  224    member(pass(A,Arg), Pass), !,
  225    Index1 is Index+1,
  226    arg(Index1, TGoal, Arg),
  227    '_use_acc_pass'(GList, Index1, TGoal, Acc, NewAcc, Pass).
  228% 2b. The passed argument A is not used in the head:
  229'_use_acc_pass'([A|GList], Index, TGoal, Acc, NewAcc, Pass) :-
  230    '_pass_info'(A, AStart), !,
  231    Index1 is Index+1,
  232    arg(Index1, TGoal, AStart),
  233    '_use_acc_pass'(GList, Index1, TGoal, Acc, NewAcc, Pass).
  234% 3. Defaulty case when A does not exist:
  235'_use_acc_pass'([A|_GList], _Index, _TGoal, Acc, Acc, _Pass) :-
  236    print_message(error,not_a_hidden_param(A)).
  237
  238% Finish the Acc data structure:
  239% Link its Left and Right accumulation variables together in pairs:
  240% TODO: does this work correctly in the presence of cuts? ("!") - see README
  241'_finish_acc'([]).
  242'_finish_acc'([acc(_,Link,Link)|Acc]) :- '_finish_acc'(Acc).
  243
  244'_finish_acc_ssu'([], TB, TB).
  245'_finish_acc_ssu'([acc(_,Link0,Link1)|Acc], TB0, TB) :-
  246    '_finish_acc_ssu'(Acc, (Link0=Link1,TB0), TB).
  247
  248% Replace elements in the Acc data structure:
  249% Succeeds iff replacement is successful.
  250'_replace_acc'(A, L1, R1, L2, R2, Acc, NewAcc) :-
  251    member(acc(A,L1,R1), Acc), !,
  252    '_replace'(acc(A,_,_), acc(A,L2,R2), Acc, NewAcc).
  253
  254% Combine two accumulator lists ('or'ing their values)
  255'_merge_acc'([], [], G1, G1, [], G2, G2, []) :- !.
  256'_merge_acc'([acc(Acc,OL,R)|Accs], [acc(Acc,L1,R)|Accs1], G1, NG1,
  257         [acc(Acc,L2,R)|Accs2], G2, NG2, [acc(Acc,NL,R)|NewAccs]) :- !,
  258    ( ( OL == L1, OL \== L2 ) ->
  259      MG1 = (G1,L1=L2), MG2 = G2, NL = L2
  260        ; ( OL == L2, OL \== L1 ) ->
  261      MG2 = (G2,L2=L1), MG1 = G1, NL = L1
  262        ; MG1 = G1, MG2 = G2, L1 = L2, L2 = NL ),
  263    '_merge_acc'(Accs, Accs1, MG1, NG1, Accs2, MG2, NG2, NewAccs).
  264
  265% ==== The following was originally generic-util.pl ====
  266
  267% Generic utilities special-util.pl
  268
  269% Match arguments L, L+1, ..., H of the predicates P and Q:
  270'_match'(L, H, _, _) :- L>H, !.
  271'_match'(L, H, P, Q) :- L=<H, !,
  272    arg(L, P, A),
  273    arg(L, Q, A),
  274    L1 is L+1,
  275    '_match'(L1, H, P, Q).
  276
  277
  278'_list'(L) :- nonvar(L), L=[_|_], !.
  279'_list'(L) :- L==[], !.
  280
  281'_make_list'(A, [A]) :- \+'_list'(A), !.
  282'_make_list'(L,   L) :-   '_list'(L), !.
  283
  284% replace(Elem, RepElem, List, RepList)
  285'_replace'(_, _, [], []).
  286'_replace'(A, B, [A|L], [B|R]) :- !,
  287    '_replace'(A, B, L, R).
  288'_replace'(A, B, [C|L], [C|R]) :-
  289    \+C=A, !,
  290    '_replace'(A, B, L, R).
  291
  292% ==== The following was originally special-util.pl ====
  293
  294% Specialized utilities:
  295
  296% Given a goal Goal and a list of hidden parameters GList
  297% create a new goal TGoal with the correct number of arguments.
  298% Also return the arity of the original goal.
  299'_new_goal'(Goal, GList, GArity, TGoal) :-
  300    functor(Goal, Name, GArity),
  301    '_number_args'(GList, GArity, TArity),
  302    functor(TGoal, Name, TArity),
  303    '_match'(1, GArity, Goal, TGoal).
  304
  305% Add the number of arguments needed for the hidden parameters:
  306'_number_args'([], N, N).
  307'_number_args'([A|List], N, M) :-
  308    '_is_acc'(A), !,
  309    N2 is N+2,
  310    '_number_args'(List, N2, M).
  311'_number_args'([A|List], N, M) :-
  312    '_is_pass'(A), !,
  313    N1 is N+1,
  314    '_number_args'(List, N1, M).
  315'_number_args'([_|List], N, M) :- !,
  316    % error caught elsewhere
  317    '_number_args'(List, N, M).
  318
  319% Give a list of G's hidden parameters:
  320'_has_hidden'(G, GList) :-
  321    functor(G, GName, GArity),
  322    pred_info(GName, GArity, GList).
  323'_has_hidden'(G, []) :-
  324    functor(G, GName, GArity),
  325    \+pred_info(GName, GArity, _).
  326
  327% Succeeds if A is an accumulator:
  328'_is_acc'(A)  :- atomic(A), !, '_acc_info'(A, _, _, _, _, _, _).
  329'_is_acc'(A)  :- functor(A, N, 2), !, '_acc_info'(N, _, _, _, _, _, _).
  330
  331% Succeeds if A is a passed argument:
  332'_is_pass'(A) :- atomic(A), !, '_pass_info'(A, _).
  333'_is_pass'(A) :- functor(A, N, 1), !, '_pass_info'(N, _).
  334
  335% Get initial values for the accumulator:
  336'_acc_info'(AccParams, LStart, RStart) :-
  337    functor(AccParams, Acc, 2),
  338    '_is_acc'(Acc), !,
  339    arg(1, AccParams, LStart),
  340    arg(2, AccParams, RStart).
  341'_acc_info'(Acc, LStart, RStart) :-
  342    '_acc_info'(Acc, _, _, _, _, LStart, RStart).
  343
  344% Isolate the internal database from the user database:
  345'_acc_info'(Acc, Term, Left, Right, Joiner, LStart, RStart) :-
  346    acc_info(Acc, Term, Left, Right, Joiner, LStart, RStart).
  347'_acc_info'(Acc, Term, Left, Right, Joiner, _, _) :-
  348    acc_info(Acc, Term, Left, Right, Joiner).
  349'_acc_info'(dcg, Term, Left, Right, Left=[Term|Right], _, []).
  350
  351% Get initial value for the passed argument:
  352% Also, isolate the internal database from the user database.
  353'_pass_info'(PassParam, PStart) :-
  354    functor(PassParam, Pass, 1),
  355    '_is_pass'(Pass), !,
  356    arg(1, PassParam, PStart).
  357'_pass_info'(Pass, PStart) :-
  358    pass_info(Pass, PStart).
  359'_pass_info'(Pass, _) :-
  360    pass_info(Pass).
  361
  362% Calculate the joiner for an accumulator A:
  363'_joiner'([], _, _, true, Acc, Acc).
  364'_joiner'([Term|List], A, NaAr, (Joiner,LJoiner), Acc, NewAcc) :-
  365    '_replace_acc'(A, LeftA, RightA, MidA, RightA, Acc, MidAcc),
  366    '_acc_info'(A, Term, LeftA, MidA, Joiner, _, _), !,
  367    '_joiner'(List, A, NaAr, LJoiner, MidAcc, NewAcc).
  368% Defaulty case:
  369'_joiner'([_Term|List], A, NaAr, Joiner, Acc, NewAcc) :-
  370    print_message(warning, missing_accumulator(NaAr,A)),
  371    '_joiner'(List, A, NaAr, Joiner, Acc, NewAcc).
  372
  373% Replace hidden parameters with ones containing initial values:
  374'_replace_defaults'([], [], _).
  375'_replace_defaults'([A|GList], [NA|NGList], AList) :-
  376    '_replace_default'(A, NA, AList),
  377    '_replace_defaults'(GList, NGList, AList).
  378
  379'_replace_default'(A, NewA, AList) :-  % New initial values for accumulator.
  380    functor(NewA, A, 2),
  381    member(NewA, AList), !.
  382'_replace_default'(A, NewA, AList) :-  % New initial values for passed argument.
  383    functor(NewA, A, 1),
  384    member(NewA, AList), !.
  385'_replace_default'(A, NewA, _) :-      % Use default initial values.
  386    A=NewA.
  387
  388% ==== The following was originally messages.pl ====
  389
  390:- multifile prolog:message//1.  391
  392prolog:message(missing_accumulator(Predicate,Accumulator)) -->
  393    ['In ~w the accumulator ''~w'' does not exist'-[Predicate,Accumulator]].
  394prolog:message(missing_hidden_parameter(Predicate,Term)) -->
  395    ['In ~w the term ''~w'' uses a non-existent hidden parameter.'-[Predicate,Term]].
  396prolog:message(not_a_hidden_param(Name)) -->
  397    ['~w is not a hidden parameter'-[Name]]