diff --git a/samples/Prolog/format_spec.pl b/samples/Prolog/format_spec.pl new file mode 100644 index 00000000..1508f3a3 --- /dev/null +++ b/samples/Prolog/format_spec.pl @@ -0,0 +1,260 @@ +:- module(format_spec, [ format_error/2 + , format_spec/2 + , format_spec//1 + , spec_arity/2 + , spec_types/2 + ]). + +:- use_module(library(dcg/basics), [eos//0, integer//1, string_without//2]). +:- use_module(library(error)). +:- use_module(library(when), [when/2]). + +% TODO loading this module is optional +% TODO it's for my own convenience during development +%:- use_module(library(mavis)). + +%% format_error(+Goal, -Error:string) is nondet. +% +% True if Goal exhibits an Error in its format string. The +% Error string describes what is wrong with Goal. Iterates each +% error on backtracking. +% +% Goal may be one of the following predicates: +% +% * format/2 +% * format/3 +% * debug/3 +format_error(format(Format,Args), Error) :- + format_error_(Format, Args,Error). +format_error(format(_,Format,Args), Error) :- + format_error_(Format,Args,Error). +format_error(debug(_,Format,Args), Error) :- + format_error_(Format,Args,Error). + +format_error_(Format,Args,Error) :- + format_spec(Format, Spec), + !, + is_list(Args), + spec_types(Spec, Types), + types_error(Args, Types, Error). +format_error_(Format,_,Error) :- + % \+ format_spec(Format, _), + format(string(Error), "Invalid format string: ~q", [Format]). + +types_error(Args, Types, Error) :- + length(Types, TypesLen), + length(Args, ArgsLen), + TypesLen =\= ArgsLen, + !, + format( string(Error) + , "Wrong argument count. Expected ~d, got ~d" + , [TypesLen, ArgsLen] + ). +types_error(Args, Types, Error) :- + types_error_(Args, Types, Error). + +types_error_([Arg|_],[Type|_],Error) :- + ground(Arg), + \+ is_of_type(Type,Arg), + message_to_string(error(type_error(Type,Arg),_Location),Error). +types_error_([_|Args],[_|Types],Error) :- + types_error_(Args, Types, Error). + + +% check/0 augmentation +:- multifile check:checker/2. +:- dynamic check:checker/2. +check:checker(format_spec:checker, "format/2 strings and arguments"). + +:- dynamic format_fail/3. + +checker :- + prolog_walk_code([ module_class([user]) + , infer_meta_predicates(false) + , autoload(false) % format/{2,3} are always loaded + , undefined(ignore) + , trace_reference(_) + , on_trace(check_format) + ]), + retract(format_fail(Goal,Location,Error)), + print_message(warning, format_error(Goal,Location,Error)), + fail. % iterate all errors +checker. % succeed even if no errors are found + +check_format(Module:Goal, _Caller, Location) :- + predicate_property(Module:Goal, imported_from(Source)), + memberchk(Source, [system,prolog_debug]), + can_check(Goal), + format_error(Goal, Error), + assert(format_fail(Goal, Location, Error)), + fail. +check_format(_,_,_). % succeed to avoid printing goals + +% true if format_error/2 can check this goal +can_check(Goal) :- + once(clause(format_error(Goal,_),_)). + +prolog:message(format_error(Goal,Location,Error)) --> + prolog:message_location(Location), + ['~n In goal: ~q~n ~s'-[Goal,Error]]. + + +%% format_spec(-Spec)// +% +% DCG for parsing format strings. It doesn't yet generate format +% strings from a spec. See format_spec/2 for details. +format_spec([]) --> + eos. +format_spec([escape(Numeric,Modifier,Action)|Rest]) --> + "~", + numeric_argument(Numeric), + modifier_argument(Modifier), + action(Action), + format_spec(Rest). +format_spec([text(String)|Rest]) --> + { when((ground(String);ground(Codes)),string_codes(String, Codes)) }, + string_without("~", Codes), + { Codes \= [] }, + format_spec(Rest). + + +%% format_spec(+Format, -Spec:list) is semidet. +% +% Parse a format string. Each element of Spec is one of the following: +% +% * `text(Text)` - text sent to the output as is +% * `escape(Num,Colon,Action)` - a format escape +% +% `Num` represents the optional numeric portion of an esape. `Colon` +% represents the optional colon in an escape. `Action` is an atom +% representing the action to be take by this escape. +format_spec(Format, Spec) :- + when((ground(Format);ground(Codes)),text_codes(Format, Codes)), + once(phrase(format_spec(Spec), Codes, [])). + +%% spec_arity(+FormatSpec, -Arity:positive_integer) is det. +% +% True if FormatSpec requires format/2 to have Arity arguments. +spec_arity(Spec, Arity) :- + spec_types(Spec, Types), + length(Types, Arity). + + +%% spec_types(+FormatSpec, -Types:list(type)) is det. +% +% True if FormatSpec requires format/2 to have arguments of Types. Each +% value of Types is a type as described by error:has_type/2. This +% notion of types is compatible with library(mavis). +spec_types(Spec, Types) :- + phrase(spec_types(Spec), Types). + +spec_types([]) --> + []. +spec_types([Item|Items]) --> + item_types(Item), + spec_types(Items). + +item_types(text(_)) --> + []. +item_types(escape(Numeric,_,Action)) --> + numeric_types(Numeric), + action_types(Action). + +numeric_types(number(_)) --> + []. +numeric_types(character(_)) --> + []. +numeric_types(star) --> + [number]. +numeric_types(nothing) --> + []. + +action_types(Action) --> + { atom_codes(Action, [Code]) }, + { action_types(Code, Types) }, + phrase(Types). + + +%% text_codes(Text:text, Codes:codes). +text_codes(Var, Codes) :- + var(Var), + !, + string_codes(Var, Codes). +text_codes(Atom, Codes) :- + atom(Atom), + !, + atom_codes(Atom, Codes). +text_codes(String, Codes) :- + string(String), + !, + string_codes(String, Codes). +text_codes(Codes, Codes) :- + is_of_type(codes, Codes). + + +numeric_argument(number(N)) --> + integer(N). +numeric_argument(character(C)) --> + "`", + [C]. +numeric_argument(star) --> + "*". +numeric_argument(nothing) --> + "". + + +modifier_argument(colon) --> + ":". +modifier_argument(no_colon) --> + \+ ":". + + +action(Action) --> + [C], + { is_action(C) }, + { atom_codes(Action, [C]) }. + + +%% is_action(+Action:integer) is semidet. +%% is_action(-Action:integer) is multi. +% +% True if Action is a valid format/2 action character. Iterates all +% acceptable action characters, if Action is unbound. +is_action(Action) :- + action_types(Action, _). + +%% action_types(?Action:integer, ?Types:list(type)) +% +% True if Action consumes arguments matching Types. An action (like +% `~`), which consumes no arguments, has `Types=[]`. For example, +% +% ?- action_types(0'~, Types). +% Types = []. +% ?- action_types(0'a, Types). +% Types = [atom]. +action_types(0'~, []). +action_types(0'a, [atom]). +action_types(0'c, [integer]). % specifically, a code +action_types(0'd, [integer]). +action_types(0'D, [integer]). +action_types(0'e, [float]). +action_types(0'E, [float]). +action_types(0'f, [float]). +action_types(0'g, [float]). +action_types(0'G, [float]). +action_types(0'i, [any]). +action_types(0'I, [integer]). +action_types(0'k, [any]). +action_types(0'n, []). +action_types(0'N, []). +action_types(0'p, [any]). +action_types(0'q, [any]). +action_types(0'r, [integer]). +action_types(0'R, [integer]). +action_types(0's, [text]). +action_types(0'@, [callable]). +action_types(0't, []). +action_types(0'|, []). +action_types(0'+, []). +action_types(0'w, [any]). +action_types(0'W, [any, list]). diff --git a/samples/Prolog/func.pl b/samples/Prolog/func.pl new file mode 100644 index 00000000..944514e2 --- /dev/null +++ b/samples/Prolog/func.pl @@ -0,0 +1,194 @@ +:- module(func, [ op(675, xfy, ($)) + , op(650, xfy, (of)) + , ($)/2 + , (of)/2 + ]). +:- use_module(library(list_util), [xfy_list/3]). +:- use_module(library(function_expansion)). +:- use_module(library(arithmetic)). +:- use_module(library(error)). + + +% true if the module whose terms are being read has specifically +% imported library(func). +wants_func :- + prolog_load_context(module, Module), + Module \== func, % we don't want func sugar ourselves + predicate_property(Module:of(_,_),imported_from(func)). + + +%% compile_function(+Term, -In, -Out, -Goal) is semidet. +% +% True if Term represents a function from In to Out +% implemented by calling Goal. This multifile hook is +% called by $/2 and of/2 to convert a term into a goal. +% It's used at compile time for macro expansion. +% It's used at run time to handle functions which aren't +% known at compile time. +% When called as a hook, Term is guaranteed to be =nonvar=. +% +% For example, to treat library(assoc) terms as functions which +% map a key to a value, one might define: +% +% :- multifile compile_function/4. +% compile_function(Assoc, Key, Value, Goal) :- +% is_assoc(Assoc), +% Goal = get_assoc(Key, Assoc, Value). +% +% Then one could write: +% +% list_to_assoc([a-1, b-2, c-3], Assoc), +% Two = Assoc $ b, +:- multifile compile_function/4. +compile_function(Var, _, _, _) :- + % variables storing functions must be evaluated at run time + % and can't be compiled, a priori, into a goal + var(Var), + !, + fail. +compile_function(Expr, In, Out, Out is Expr) :- + % arithmetic expression of one variable are simply evaluated + \+ string(Expr), % evaluable/1 throws exception with strings + arithmetic:evaluable(Expr), + term_variables(Expr, [In]). +compile_function(F, In, Out, func:Goal) :- + % composed functions + function_composition_term(F), + user:function_expansion(F, func:Functor, true), + Goal =.. [Functor,In,Out]. +compile_function(F, In, Out, Goal) :- + % string interpolation via format templates + format_template(F), + ( atom(F) -> + Goal = format(atom(Out), F, In) + ; string(F) -> + Goal = format(string(Out), F, In) + ; error:has_type(codes, F) -> + Goal = format(codes(Out), F, In) + ; fail % to be explicit + ). +compile_function(Dict, In, Out, Goal) :- + is_dict(Dict), + Goal = get_dict(In, Dict, Out). + +%% $(+Function, +Argument) is det. +% +% Apply Function to an Argument. A Function is any predicate +% whose final argument generates output and whose penultimate argument +% accepts input. +% +% This is realized by expanding function application to chained +% predicate calls at compile time. Function application itself can +% be chained. +% +% == +% Reversed = reverse $ sort $ [c,d,b]. +% == +:- meta_predicate $(2,+). +$(_,_) :- + throw(error(permission_error(call, predicate, ($)/2), + context(_, '$/2 must be subject to goal expansion'))). + +user:function_expansion($(F,X), Y, Goal) :- + wants_func, + ( func:compile_function(F, X, Y, Goal) -> + true + ; var(F) -> Goal = % defer until run time + ( func:compile_function(F, X, Y, P) -> + call(P) + ; call(F, X, Y) + ) + ; Goal = call(F, X, Y) + ). + + +%% of(+F, +G) is det. +% +% Creates a new function by composing F and G. The functions are +% composed at compile time to create a new, compiled predicate which +% behaves like a function. Function composition can be chained. +% Composed functions can also be applied with $/2. +% +% == +% Reversed = reverse of sort $ [c,d,b]. +% == +:- meta_predicate of(2,2). +of(_,_). + + +%% format_template(Format) is semidet. +% +% True if Format is a template string suitable for format/3. +% The current check is very naive and should be improved. +format_template(Format) :- + atom(Format), !, + atom_codes(Format, Codes), + format_template(Codes). +format_template(Format) :- + string(Format), + !, + string_codes(Format, Codes), + format_template(Codes). +format_template(Format) :- + error:has_type(codes, Format), + memberchk(0'~, Format). % ' fix syntax highlighting + + +% True if the argument is a function composition term +function_composition_term(of(_,_)). + +% Converts a function composition term into a list of functions to compose +functions_to_compose(Term, Funcs) :- + functor(Term, Op, 2), + Op = (of), + xfy_list(Op, Term, Funcs). + +% Thread a state variable through a list of functions. This is similar +% to a DCG expansion, but much simpler. +thread_state([], [], Out, Out). +thread_state([F|Funcs], [Goal|Goals], In, Out) :- + ( compile_function(F, In, Tmp, Goal) -> + true + ; var(F) -> + instantiation_error(F) + ; F =.. [Functor|Args], + append(Args, [In, Tmp], NewArgs), + Goal =.. [Functor|NewArgs] + ), + thread_state(Funcs, Goals, Tmp, Out). + +user:function_expansion(Term, func:Functor, true) :- + wants_func, + functions_to_compose(Term, Funcs), + debug(func, 'building composed function for: ~w', [Term]), + variant_sha1(Funcs, Sha), + format(atom(Functor), 'composed_function_~w', [Sha]), + debug(func, ' name: ~s', [Functor]), + ( func:current_predicate(Functor/2) -> + debug(func, ' composed predicate already exists', []) + ; true -> + reverse(Funcs, RevFuncs), + thread_state(RevFuncs, Threaded, In, Out), + xfy_list(',', Body, Threaded), + Head =.. [Functor, In, Out], + func:assert(Head :- Body), + func:compile_predicates([Functor/2]) + ). + + +% support foo(x,~,y) evaluation +user:function_expansion(Term, Output, Goal) :- + wants_func, + compound(Term), + + % has a single ~ argument + setof( X + , ( arg(X,Term,Arg), Arg == '~' ) + , [N] + ), + + % replace ~ with a variable + Term =.. [Name|Args0], + nth1(N, Args0, ~, Rest), + nth1(N, Args, Output, Rest), + Goal =.. [Name|Args].