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)