:- 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]).