34
   35:- module(yall,
   36          [ (>>)/2, (>>)/3, (>>)/4, (>>)/5, (>>)/6, (>>)/7, (>>)/8, (>>)/9,
   37            (/)/2, (/)/3, (/)/4, (/)/5, (/)/6, (/)/7, (/)/8, (/)/9,
   38
   39            lambda_calls/2,                        40            lambda_calls/3,                        41            is_lambda/1                            42          ]).   43:- autoload(library(error),
   44	    [ instantiation_error/1,
   45	      must_be/2,
   46	      domain_error/2,
   47	      type_error/2
   48	    ]).   49:- autoload(library(lists),[append/3]).   50
   51
   52:- meta_predicate
   53    '>>'(?, 0),
   54    '>>'(?, :, ?),
   55    '>>'(?, :, ?, ?),
   56    '>>'(?, :, ?, ?, ?),
   57    '>>'(?, :, ?, ?, ?, ?),
   58    '>>'(?, :, ?, ?, ?, ?, ?),
   59    '>>'(?, :, ?, ?, ?, ?, ?, ?),
   60    '>>'(?, :, ?, ?, ?, ?, ?, ?, ?).   61
   62:- meta_predicate
   63    '/'(?, 0),
   64    '/'(?, 1, ?),
   65    '/'(?, 2, ?, ?),
   66    '/'(?, 3, ?, ?, ?),
   67    '/'(?, 4, ?, ?, ?, ?),
   68    '/'(?, 5, ?, ?, ?, ?, ?),
   69    '/'(?, 6, ?, ?, ?, ?, ?, ?),
   70    '/'(?, 7, ?, ?, ?, ?, ?, ?, ?).   71
  171
  193
  194'>>'(Parms, Lambda) :-
  195    unify_lambda_parameters(Parms, [],
  196                            ExtraArgs, Lambda, LambdaCopy),
  197    Goal =.. [call, LambdaCopy| ExtraArgs],
  198    call(Goal).
  199
  200'>>'(Parms, Lambda, A1) :-
  201    unify_lambda_parameters(Parms, [A1],
  202                            ExtraArgs, Lambda, LambdaCopy),
  203    Goal =.. [call, LambdaCopy| ExtraArgs],
  204    call(Goal).
  205
  206'>>'(Parms, Lambda, A1, A2) :-
  207    unify_lambda_parameters(Parms, [A1,A2],
  208                            ExtraArgs, Lambda, LambdaCopy),
  209    Goal =.. [call, LambdaCopy| ExtraArgs],
  210    call(Goal).
  211
  212'>>'(Parms, Lambda, A1, A2, A3) :-
  213    unify_lambda_parameters(Parms, [A1,A2,A3],
  214                            ExtraArgs, Lambda, LambdaCopy),
  215    Goal =.. [call, LambdaCopy| ExtraArgs],
  216    call(Goal).
  217
  218'>>'(Parms, Lambda, A1, A2, A3, A4) :-
  219    unify_lambda_parameters(Parms, [A1,A2,A3,A4],
  220                            ExtraArgs, Lambda, LambdaCopy),
  221    Goal =.. [call, LambdaCopy| ExtraArgs],
  222    call(Goal).
  223
  224'>>'(Parms, Lambda, A1, A2, A3, A4, A5) :-
  225    unify_lambda_parameters(Parms, [A1,A2,A3,A4,A5],
  226                            ExtraArgs, Lambda, LambdaCopy),
  227    Goal =.. [call, LambdaCopy| ExtraArgs],
  228    call(Goal).
  229
  230'>>'(Parms, Lambda, A1, A2, A3, A4, A5, A6) :-
  231    unify_lambda_parameters(Parms, [A1,A2,A3,A4,A5,A6],
  232                            ExtraArgs, Lambda, LambdaCopy),
  233    Goal =.. [call, LambdaCopy| ExtraArgs],
  234    call(Goal).
  235
  236'>>'(Parms, Lambda, A1, A2, A3, A4, A5, A6, A7) :-
  237    unify_lambda_parameters(Parms, [A1,A2,A3,A4,A5,A6,A7],
  238                            ExtraArgs, Lambda, LambdaCopy),
  239    Goal =.. [call, LambdaCopy| ExtraArgs],
  240    call(Goal).
  241
  273
  274
  275'/'(Free, Lambda) :-
  276    lambda_free(Free),
  277    copy_term_nat(Free+Lambda, Free+LambdaCopy),
  278    call(LambdaCopy).
  279
  280'/'(Free, Lambda, A1) :-
  281    lambda_free(Free),
  282    copy_term_nat(Free+Lambda, Free+LambdaCopy),
  283    call(LambdaCopy, A1).
  284
  285'/'(Free, Lambda, A1, A2) :-
  286    lambda_free(Free),
  287    copy_term_nat(Free+Lambda, Free+LambdaCopy),
  288    call(LambdaCopy, A1, A2).
  289
  290'/'(Free, Lambda, A1, A2, A3) :-
  291    lambda_free(Free),
  292    copy_term_nat(Free+Lambda, Free+LambdaCopy),
  293    call(LambdaCopy, A1, A2, A3).
  294
  295'/'(Free, Lambda, A1, A2, A3, A4) :-
  296    lambda_free(Free),
  297    copy_term_nat(Free+Lambda, Free+LambdaCopy),
  298    call(LambdaCopy, A1, A2, A3, A4).
  299
  300'/'(Free, Lambda, A1, A2, A3, A4, A5) :-
  301    lambda_free(Free),
  302    copy_term_nat(Free+Lambda, Free+LambdaCopy),
  303    call(LambdaCopy, A1, A2, A3, A4, A5).
  304
  305'/'(Free, Lambda, A1, A2, A3, A4, A5, A6) :-
  306    lambda_free(Free),
  307    copy_term_nat(Free+Lambda, Free+LambdaCopy),
  308    call(LambdaCopy, A1, A2, A3, A4, A5, A6).
  309
  310'/'(Free, Lambda, A1, A2, A3, A4, A5, A6, A7) :-
  311    lambda_free(Free),
  312    copy_term_nat(Free+Lambda, Free+LambdaCopy),
  313    call(LambdaCopy, A1, A2, A3, A4, A5, A6, A7).
  314
  315
  324
  325unify_lambda_parameters(Parms, _Args, _ExtraArgs, _Lambda, _LambdaCopy) :-
  326    var(Parms),
  327    !,
  328    instantiation_error(Parms).
  329unify_lambda_parameters(Free/Parms, Args, ExtraArgs, Lambda, LambdaCopy) :-
  330    !,
  331    lambda_free(Free),
  332    must_be(list, Parms),
  333    copy_term_nat(Free/Parms>>Lambda, Free/ParmsCopy>>LambdaCopy),
  334    unify_lambda_parameters_(ParmsCopy, Args, ExtraArgs,
  335                             Free/Parms>>Lambda).
  336unify_lambda_parameters(Parms, Args, ExtraArgs, Lambda, LambdaCopy) :-
  337    must_be(list, Parms),
  338    copy_term_nat(Parms>>Lambda, ParmsCopy>>LambdaCopy),
  339    unify_lambda_parameters_(ParmsCopy, Args, ExtraArgs,
  340                             Parms>>Lambda).
  341
  342unify_lambda_parameters_([], ExtraArgs, ExtraArgs, _) :- !.
  343unify_lambda_parameters_([Parm|Parms], [Arg|Args], ExtraArgs, Culprit) :-
  344    !,
  345    Parm = Arg,
  346    unify_lambda_parameters_(Parms, Args, ExtraArgs, Culprit).
  347unify_lambda_parameters_(_,_,_,Culprit) :-
  348    domain_error(lambda_parameters, Culprit).
  349
  350lambda_free(Free) :-
  351    var(Free),
  352    !,
  353    instantiation_error(Free).
  354lambda_free({_}) :- !.
  355lambda_free({}) :- !.
  356lambda_free(Free) :-
  357    type_error(lambda_free, Free).
  358
  365
  366expand_lambda(Goal, Head) :-
  367    Goal =.. ['>>', Parms, Lambda| ExtraArgs],
  368    is_callable(Lambda),
  369    nonvar(Parms),
  370    lambda_functor(Parms>>Lambda, Functor),
  371    (   Parms = Free/ExtraArgs
  372    ->  is_lambda_free(Free),
  373        free_to_list(Free, FreeList)
  374    ;   Parms = ExtraArgs,
  375        FreeList = []
  376    ),
  377    append(FreeList, ExtraArgs, Args),
  378    Head =.. [Functor|Args],
  379    compile_aux_clause_if_new(Head, Lambda).
  380expand_lambda(Goal, Head) :-
  381    Goal =.. ['/', Free, Closure|ExtraArgs],
  382    is_lambda_free(Free),
  383    is_callable(Closure),
  384    free_to_list(Free, FreeList),
  385    lambda_functor(Free/Closure, Functor),
  386    append(FreeList, ExtraArgs, Args),
  387    Head =.. [Functor|Args],
  388    Closure =.. [ClosureFunctor|ClosureArgs],
  389    append(ClosureArgs, ExtraArgs, LambdaArgs),
  390    Lambda =.. [ClosureFunctor|LambdaArgs],
  391    compile_aux_clause_if_new(Head, Lambda).
  392
  393lambda_functor(Term, Functor) :-
  394    copy_term_nat(Term, Copy),
  395    variant_sha1(Copy, Functor0),
  396    atom_concat('__aux_yall_', Functor0, Functor).
  397
  398free_to_list({}, []).
  399free_to_list({VarsConj}, Vars) :-
  400    conjunction_to_list(VarsConj, Vars).
  401
  402conjunction_to_list(Term, [Term]) :-
  403    var(Term),
  404    !.
  405conjunction_to_list((Term, Conjunction), [Term|Terms]) :-
  406    !,
  407    conjunction_to_list(Conjunction, Terms).
  408conjunction_to_list(Term, [Term]).
  409
  410compile_aux_clause_if_new(Head, Lambda) :-
  411    prolog_load_context(module, Context),
  412    (   predicate_property(Context:Head, defined)
  413    ->  true
  414    ;   expand_goal(Lambda, LambdaExpanded),
  415        compile_aux_clauses([(Head :- LambdaExpanded)])
  416    ).
  417
  418lambda_like(Goal) :-
  419    compound(Goal),
  420    compound_name_arity(Goal, Name, Arity),
  421    lambda_functor(Name),
  422    Arity >= 2.
  423
  424lambda_functor(>>).
  425lambda_functor(/).
  426
  427:- dynamic system:goal_expansion/2.  428:- multifile system:goal_expansion/2.  429
  430system:goal_expansion(Goal, Head) :-
  431    lambda_like(Goal),
  432    prolog_load_context(source, _),
  433    \+ current_prolog_flag(xref, true),
  434    expand_lambda(Goal, Head).
  435
  439
  440is_lambda(Term) :-
  441    compound(Term),
  442    compound_name_arguments(Term, Name, Args),
  443    is_lambda(Name, Args).
  444
  445is_lambda(>>, [Params,Lambda|_]) :-
  446    is_lamdba_params(Params),
  447    is_callable(Lambda).
  448is_lambda(/, [Free,Lambda|_]) :-
  449    is_lambda_free(Free),
  450    is_callable(Lambda).
  451
  452is_lamdba_params(Var) :-
  453    var(Var), !, fail.
  454is_lamdba_params(Free/Params) :-
  455    !,
  456    is_lambda_free(Free),
  457    is_list(Params).
  458is_lamdba_params(Params) :-
  459    is_list(Params).
  460
  461is_lambda_free(Free) :-
  462    nonvar(Free), !, (Free = {_} -> true ; Free == {}).
  463
  464is_callable(Term) :-
  465    strip_module(Term, _, Goal),
  466    callable(Goal).
  467
  468
  477
  478lambda_calls(LambdaExtended, Goal) :-
  479    compound(LambdaExtended),
  480    compound_name_arguments(LambdaExtended, Name, [A1,A2|Extra]),
  481    lambda_functor(Name),
  482    compound_name_arguments(Lambda, Name, [A1,A2]),
  483    lambda_calls(Lambda, Extra, Goal).
  484
  485lambda_calls(Lambda, Extra, Goal) :-
  486    integer(Extra),
  487    !,
  488    length(ExtraVars, Extra),
  489    lambda_calls_(Lambda, ExtraVars, Goal).
  490lambda_calls(Lambda, Extra, Goal) :-
  491    must_be(list, Extra),
  492    lambda_calls_(Lambda, Extra, Goal).
  493
  494lambda_calls_(Params>>Lambda, Args, Goal) :-
  495    unify_lambda_parameters(Params, Args, ExtraArgs, Lambda, LambdaCopy),
  496    extend(LambdaCopy, ExtraArgs, Goal).
  497lambda_calls_(Free/Lambda, ExtraArgs, Goal) :-
  498    copy_term_nat(Free+Lambda, Free+LambdaCopy),
  499    extend(LambdaCopy, ExtraArgs, Goal).
  500
  501extend(Var, _, _) :-
  502    var(Var),
  503    !,
  504    instantiation_error(Var).
  505extend(Cyclic, _, _) :-
  506    cyclic_term(Cyclic),
  507    !,
  508    type_error(acyclic_term, Cyclic).
  509extend(M:Goal0, Extra, M:Goal) :-
  510    !,
  511    extend(Goal0, Extra, Goal).
  512extend(Goal0, Extra, Goal) :-
  513    atom(Goal0),
  514    !,
  515    Goal =.. [Goal0|Extra].
  516extend(Goal0, Extra, Goal) :-
  517    compound(Goal0),
  518    !,
  519    compound_name_arguments(Goal0, Name, Args0),
  520    append(Args0, Extra, Args),
  521    compound_name_arguments(Goal, Name, Args).
  522
  523
  524                   527
  528:- multifile prolog_colour:goal_colours/2.  529
  530yall_colours(Lambda, built_in-[classify,body(Goal)|ArgSpecs]) :-
  531    catch(lambda_calls(Lambda, Goal), _, fail),
  532    Lambda =.. [>>,_,_|Args],
  533    classify_extra(Args, ArgSpecs).
  534
([], []).
  536classify_extra([_|T0], [classify|T]) :-
  537    classify_extra(T0, T).
  538
  539prolog_colour:goal_colours(Goal, Spec) :-
  540    lambda_like(Goal),
  541    yall_colours(Goal, Spec).
  542
  543
  544                   547
  548:- multifile prolog:called_by/4.  549
  550prolog:called_by(Lambda, yall, _, [Goal]) :-
  551    lambda_like(Lambda),
  552    catch(lambda_calls(Lambda, Goal), _, fail).
  553
  554
  555                   558
  559:- multifile
  560    sandbox:safe_meta_predicate/1,
  561    sandbox:safe_meta/2.  562
  563sandbox:safe_meta_predicate(yall:(/)/2).
  564sandbox:safe_meta_predicate(yall:(/)/3).
  565sandbox:safe_meta_predicate(yall:(/)/4).
  566sandbox:safe_meta_predicate(yall:(/)/5).
  567sandbox:safe_meta_predicate(yall:(/)/6).
  568sandbox:safe_meta_predicate(yall:(/)/7).
  569
  570sandbox:safe_meta(yall:Lambda, [Goal]) :-
  571    compound(Lambda),
  572    compound_name_arity(Lambda, >>, Arity),
  573    Arity >= 2,
  574    lambda_calls(Lambda, Goal)