1/*  Part of SWI-Prolog
    2
    3    Author:        Jan Wielemaker
    4    E-mail:        J.Wielemaker@vu.nl
    5    WWW:           http://www.swi-prolog.org
    6    Copyright (c)  2011-2016, VU University Amsterdam
    7    All rights reserved.
    8
    9    Redistribution and use in source and binary forms, with or without
   10    modification, are permitted provided that the following conditions
   11    are met:
   12
   13    1. Redistributions of source code must retain the above copyright
   14       notice, this list of conditions and the following disclaimer.
   15
   16    2. Redistributions in binary form must reproduce the above copyright
   17       notice, this list of conditions and the following disclaimer in
   18       the documentation and/or other materials provided with the
   19       distribution.
   20
   21    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
   22    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
   23    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
   24    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
   25    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
   26    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
   27    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
   28    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
   29    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
   30    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
   31    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
   32    POSSIBILITY OF SUCH DAMAGE.
   33*/
   34
   35:- module(predicate_options,
   36          [ predicate_options/3,                % +PI, +Arg, +Options
   37            assert_predicate_options/4,         % +PI, +Arg, +Options, ?New
   38
   39            current_option_arg/2,               % ?PI, ?Arg
   40            current_predicate_option/3,         % ?PI, ?Arg, ?Option
   41            check_predicate_option/3,           % +PI, +Arg, +Option
   42                                                % Create declarations
   43            current_predicate_options/3,        % ?PI, ?Arg, ?Options
   44            retractall_predicate_options/0,
   45            derived_predicate_options/3,        % :PI, ?Arg, ?Options
   46            derived_predicate_options/1,        % +Module
   47                                                % Checking
   48            check_predicate_options/0,
   49            derive_predicate_options/0,
   50            check_predicate_options/1           % :PredicateIndicator
   51          ]).   52:- autoload(library(apply),[maplist/3]).   53:- use_module(library(debug),[debug/3]).   54:- autoload(library(error),
   55	    [ existence_error/2,
   56	      must_be/2,
   57	      instantiation_error/1,
   58	      uninstantiation_error/1,
   59	      is_of_type/2
   60	    ]).   61:- use_module(library(dialect/swi/syspred_options)).   62
   63:- autoload(library(listing),[portray_clause/1]).   64:- autoload(library(lists),[member/2,nth1/3,append/3,delete/3]).   65:- autoload(library(pairs),[group_pairs_by_key/2]).   66:- autoload(library(prolog_clause),[clause_info/4]).   67
   68
   69:- meta_predicate
   70    predicate_options(:, +, +),
   71    assert_predicate_options(:, +, +, ?),
   72    current_predicate_option(:, ?, ?),
   73    check_predicate_option(:, ?, ?),
   74    current_predicate_options(:, ?, ?),
   75    current_option_arg(:, ?),
   76    pred_option(:,-),
   77    derived_predicate_options(:,?,?),
   78    check_predicate_options(:).   79
   80/** <module> Access and analyse predicate options
   81
   82This  module  provides  the  developers   interface  for  the  directive
   83predicate_options/3. This directive allows  us  to  specify  that, e.g.,
   84open/4 processes options using the 4th  argument and supports the option
   85=type= using the values =text= and  =binary=. Declaring options that are
   86processed allows for more reliable  handling   of  predicate options and
   87simplifies porting applications. This  library   provides  the following
   88functionality:
   89
   90  * Query supported options through current_predicate_option/3
   91    or current_predicate_options/3.  This is intended to support
   92    conditional compilation and an IDE.
   93  * Derive additional declarations through dataflow analysis using
   94    derive_predicate_options/0.
   95  * Perform a compile-time analysis of the entire loaded program using
   96    check_predicate_options/0.
   97
   98Below, we describe some use-cases.
   99
  100  $ Quick check of a program :
  101  This scenario is useful as an occasional check or to assess problems
  102  with option-handling for porting an application to SWI-Prolog.  It
  103  consists of three steps: loading the program (1 and 2), deriving
  104  option handling for application predicates (3) and running the
  105  checker (4).
  106
  107    ==
  108    1 ?- [load].
  109    2 ?- autoload.
  110    3 ?- derive_predicate_options.
  111    4 ?- check_predicate_options.
  112    ==
  113
  114  $ Add declarations to your program :
  115  Adding declarations about option processes improves the quality of
  116  the checking.  The analysis of derive_predicate_options/0 may miss
  117  options and does not derive the types for options that are processed
  118  in Prolog code.  The process is similar to the above.  In steps 4 and
  119  further, the inferred declarations are listed, inspected and added to
  120  the source code of the module.
  121
  122    ==
  123    1 ?- [load].
  124    2 ?- autoload.
  125    3 ?- derive_predicate_options.
  126    4 ?- derived_predicate_options(module_1).
  127    5 ?- derived_predicate_options(module_2).
  128    6 ?- ...
  129    ==
  130
  131  $ Declare option processing requirements :
  132  If an application requires that open/4 needs to support lock(write),
  133  it may do so using the directive below.  This directive raises an
  134  exception when loaded on a Prolog implementation that does not support
  135  this option.
  136
  137    ==
  138    :- current_predicate_option(open/4, 4, lock(write)).
  139    ==
  140
  141@see library(option) for accessing options in Prolog code.
  142*/
  143
  144:- multifile option_decl/3, pred_option/3.  145:- dynamic   dyn_option_decl/3.  146
  147%!  predicate_options(:PI, +Arg, +Options) is det.
  148%
  149%   Declare that the predicate PI processes options on Arg.  Options
  150%   is a list of options processed.  Each element is one of:
  151%
  152%     * Option(ModeAndType)
  153%     PI processes Option. The option-value must comply to
  154%     ModeAndType.  Mode is one of + or - and Type is a type as
  155%     accepted by must_be/2.
  156%
  157%     * pass_to(:PI,Arg)
  158%     The option-list is passed to the indicated predicate.
  159%
  160%   Below is an example that   processes  the option header(boolean)
  161%   and passes all options to open/4:
  162%
  163%     ==
  164%     :- predicate_options(write_xml_file/3, 3,
  165%                          [ header(boolean),
  166%                            pass_to(open/4, 4)
  167%                          ]).
  168%
  169%     write_xml_file(File, XMLTerm, Options) :-
  170%         open(File, write, Out, Options),
  171%         (   option(header(true), Options, true)
  172%         ->  write_xml_header(Out)
  173%         ;   true
  174%         ),
  175%         ...
  176%     ==
  177%
  178%   This predicate may  only  be  used   as  a  _directive_  and  is
  179%   processed  by  expand_term/2.  Option  processing    can  be
  180%   specified at runtime using  assert_predicate_options/3, which is
  181%   intended to support program analysis.
  182
  183predicate_options(PI, Arg, Options) :-
  184    throw(error(context_error(nodirective,
  185                              predicate_options(PI, Arg, Options)), _)).
  186
  187
  188%!  assert_predicate_options(:PI, +Arg, +Options, ?New) is semidet.
  189%
  190%   As predicate_options(:PI, +Arg, +Options).  New   is  a  boolean
  191%   indicating whether the declarations  have   changed.  If  New is
  192%   provided and =false=, the predicate   becomes  semidet and fails
  193%   without modifications if modifications are required.
  194
  195assert_predicate_options(PI, Arg, Options, New) :-
  196    canonical_pi(PI, M:Name/Arity),
  197    functor(Head, Name, Arity),
  198    (   dyn_option_decl(Head, M, Arg)
  199    ->  true
  200    ;   New = true,
  201        assertz(dyn_option_decl(Head, M, Arg))
  202    ),
  203    phrase('$predopts':option_clauses(Options, Head, M, Arg),
  204           OptionClauses),
  205    forall(member(Clause, OptionClauses),
  206           assert_option_clause(Clause, New)),
  207    (   var(New)
  208    ->  New = false
  209    ;   true
  210    ).
  211
  212assert_option_clause(Clause, New) :-
  213    rename_clause(Clause, NewClause,
  214                  '$pred_option'(A,B,C,D), '$dyn_pred_option'(A,B,C,D)),
  215    clause_head(NewClause, NewHead),
  216    (   clause(NewHead, _)
  217    ->  true
  218    ;   New = true,
  219        assertz(NewClause)
  220    ).
  221
  222clause_head(M:(Head:-_Body), M:Head) :- !.
  223clause_head((M:Head :-_Body), M:Head) :- !.
  224clause_head(Head, Head).
  225
  226rename_clause(M:Clause, M:NewClause, Head, NewHead) :-
  227    !,
  228    rename_clause(Clause, NewClause, Head, NewHead).
  229rename_clause((Head :- Body), (NewHead :- Body), Head, NewHead) :- !.
  230rename_clause(Head, NewHead, Head, NewHead) :- !.
  231rename_clause(Head, Head, _, _).
  232
  233
  234
  235                 /*******************************
  236                 *        QUERY OPTIONS         *
  237                 *******************************/
  238
  239%!  current_option_arg(:PI, ?Arg) is nondet.
  240%
  241%   True when Arg of PI processes   predicate options. Which options
  242%   are processed can be accessed using current_predicate_option/3.
  243
  244current_option_arg(Module:Name/Arity, Arg) :-
  245    current_option_arg(Module:Name/Arity, Arg, _DefM).
  246
  247current_option_arg(Module:Name/Arity, Arg, DefM) :-
  248    atom(Name), integer(Arity),
  249    !,
  250    resolve_module(Module:Name/Arity, DefM:Name/Arity),
  251    functor(Head, Name, Arity),
  252    (   option_decl(Head, DefM, Arg)
  253    ;   dyn_option_decl(Head, DefM, Arg)
  254    ).
  255current_option_arg(M:Name/Arity, Arg, M) :-
  256    (   option_decl(Head, M, Arg)
  257    ;   dyn_option_decl(Head, M, Arg)
  258    ),
  259    functor(Head, Name, Arity).
  260
  261%!  current_predicate_option(:PI, ?Arg, ?Option) is nondet.
  262%
  263%   True when Arg of PI processes Option. For example, the following
  264%   is true:
  265%
  266%     ==
  267%     ?- current_predicate_option(open/4, 4, type(text)).
  268%     true.
  269%     ==
  270%
  271%   This predicate is intended to   support  conditional compilation
  272%   using      if/1      ...      endif/0.        The      predicate
  273%   current_predicate_options/3 can be  used  to   access  the  full
  274%   capabilities of a predicate.
  275
  276current_predicate_option(Module:PI, Arg, Option) :-
  277    current_option_arg(Module:PI, Arg, DefM),
  278    PI = Name/Arity,
  279    functor(Head, Name, Arity),
  280    catch(pred_option(DefM:Head, Option),
  281          error(type_error(_,_),_),
  282          fail).
  283
  284%!  check_predicate_option(:PI, +Arg, +Option) is det.
  285%
  286%   Verify   predicate   options    at     runtime.    Similar    to
  287%   current_predicate_option/3,  but  intended  to  support  runtime
  288%   checking.
  289%
  290%   @error  existence_error(option, OptionName) if the option is not
  291%           supported by PI.
  292%   @error  type_error(Type, Value) if the option is supported but
  293%           the value does not match the option type. See must_be/2.
  294
  295check_predicate_option(Module:PI, Arg, Option) :-
  296    define_predicate(Module:PI),
  297    current_option_arg(Module:PI, Arg, DefM),
  298    PI = Name/Arity,
  299    functor(Head, Name, Arity),
  300    (   pred_option(DefM:Head, Option)
  301    ->  true
  302    ;   existence_error(option, Option)
  303    ).
  304
  305
  306pred_option(Head, Option) :-
  307    pred_option(Head, Option, []).
  308
  309pred_option(M:Head, Option, Seen) :-
  310    (   has_static_option_decl(M),
  311        M:'$pred_option'(Head, _, Option, Seen)
  312    ;   has_dynamic_option_decl(M),
  313        M:'$dyn_pred_option'(Head, _, Option, Seen)
  314    ).
  315
  316has_static_option_decl(M) :-
  317    '$c_current_predicate'(_, M:'$pred_option'(_,_,_,_)).
  318has_dynamic_option_decl(M) :-
  319    '$c_current_predicate'(_, M:'$dyn_pred_option'(_,_,_,_)).
  320
  321
  322                 /*******************************
  323                 *     TYPE&MODE CONSTRAINTS    *
  324                 *******************************/
  325
  326:- public
  327    system:predicate_option_mode/2,
  328    system:predicate_option_type/2.  329
  330add_attr(Var, Value) :-
  331    (   get_attr(Var, predicate_options, Old)
  332    ->  put_attr(Var, predicate_options, [Value|Old])
  333    ;   put_attr(Var, predicate_options, [Value])
  334    ).
  335
  336system:predicate_option_type(Type, Arg) :-
  337    var(Arg),
  338    !,
  339    add_attr(Arg, option_type(Type)).
  340system:predicate_option_type(callable+_N, Arg) :-
  341    !,
  342    must_be(callable, Arg).
  343system:predicate_option_type(list, Arg) :-
  344    !,
  345    must_be(list_or_partial_list, Arg).
  346system:predicate_option_type(list(Type), Arg) :-
  347    !,
  348    must_be(list_or_partial_list(Type), Arg).
  349system:predicate_option_type(Type, Arg) :-
  350    must_be(Type, Arg).
  351
  352system:predicate_option_mode(_Mode, Arg) :-
  353    var(Arg),
  354    !.
  355system:predicate_option_mode(Mode, Arg) :-
  356    check_mode(Mode, Arg).
  357
  358check_mode(input, Arg) :-
  359    (   nonvar(Arg)
  360    ->  true
  361    ;   instantiation_error(Arg)
  362    ).
  363check_mode(output, Arg) :-
  364    (   var(Arg)
  365    ->  true
  366    ;   uninstantiation_error(Arg)
  367    ).
  368
  369attr_unify_hook([], _).
  370attr_unify_hook([H|T], Var) :-
  371    option_hook(H, Var),
  372    attr_unify_hook(T, Var).
  373
  374option_hook(option_type(Type), Value) :-
  375    is_of_type(Type, Value).
  376option_hook(option_mode(Mode), Value) :-
  377    check_mode(Mode, Value).
  378
  379
  380attribute_goals(Var) -->
  381    { get_attr(Var, predicate_options, Attrs) },
  382    option_goals(Attrs, Var).
  383
  384option_goals([], _) --> [].
  385option_goals([H|T], Var) -->
  386    option_goal(H, Var),
  387    option_goals(T, Var).
  388
  389option_goal(option_type(Type), Var) --> [predicate_option_type(Type, Var)].
  390option_goal(option_mode(Mode), Var) --> [predicate_option_mode(Mode, Var)].
  391
  392
  393                 /*******************************
  394                 *      OUTPUT DECLARATIONS     *
  395                 *******************************/
  396
  397%!  current_predicate_options(:PI, ?Arg, ?Options) is nondet.
  398%
  399%   True when Options is the current   active option declaration for
  400%   PI  on  Arg.   See   predicate_options/3    for   the   argument
  401%   descriptions. If PI  is  ground  and   refers  to  an  undefined
  402%   predicate, the autoloader is used to  obtain a definition of the
  403%   predicate.
  404
  405current_predicate_options(PI, Arg, Options) :-
  406    define_predicate(PI),
  407    setof(Arg-Option,
  408          current_predicate_option_decl(PI, Arg, Option),
  409          Options0),
  410    group_pairs_by_key(Options0, Grouped),
  411    member(Arg-Options, Grouped).
  412
  413current_predicate_option_decl(PI, Arg, Option) :-
  414    current_predicate_option(PI, Arg, Option0),
  415    Option0 =.. [Name|Values],
  416    maplist(mode_and_type, Values, Types),
  417    Option =.. [Name|Types].
  418
  419mode_and_type(Value, ModeAndType) :-
  420    copy_term(Value,_,Goals),
  421    (   memberchk(predicate_option_mode(output, _), Goals)
  422    ->  ModeAndType = -(Type)
  423    ;   ModeAndType = Type
  424    ),
  425    (   memberchk(predicate_option_type(Type, _), Goals)
  426    ->  true
  427    ;   Type = any
  428    ).
  429
  430define_predicate(PI) :-
  431    ground(PI),
  432    !,
  433    PI = M:Name/Arity,
  434    functor(Head, Name, Arity),
  435    once(predicate_property(M:Head, _)).
  436define_predicate(_).
  437
  438%!  derived_predicate_options(:PI, ?Arg, ?Options) is nondet.
  439%
  440%   Derive option arguments using static analysis. True when Options
  441%   is the current _derived_ active  option   declaration  for PI on
  442%   Arg.
  443
  444derived_predicate_options(PI, Arg, Options) :-
  445    define_predicate(PI),
  446    setof(Arg-Option,
  447          derived_predicate_option(PI, Arg, Option),
  448          Options0),
  449    group_pairs_by_key(Options0, Grouped),
  450    member(Arg-Options1, Grouped),
  451    PI = M:_,
  452    phrase(expand_pass_to_options(Options1, M), Options2),
  453    sort(Options2, Options).
  454
  455derived_predicate_option(PI, Arg, Decl) :-
  456    current_option_arg(PI, Arg, DefM),
  457    PI = _:Name/Arity,
  458    functor(Head, Name, Arity),
  459    has_dynamic_option_decl(DefM),
  460    (   has_static_option_decl(DefM),
  461        DefM:'$pred_option'(Head, Decl, _, [])
  462    ;   DefM:'$dyn_pred_option'(Head, Decl, _, [])
  463    ).
  464
  465%!  expand_pass_to_options(+OptionsIn, +Module, -OptionsOut)// is det.
  466%
  467%   Expand the options of pass_to(PI,Arg) if PI  does not refer to a
  468%   public predicate.
  469
  470expand_pass_to_options([], _) --> [].
  471expand_pass_to_options([H|T], M) -->
  472    expand_pass_to(H, M),
  473    expand_pass_to_options(T, M).
  474
  475expand_pass_to(pass_to(PI, Arg), Module) -->
  476    { strip_module(Module:PI, M, Name/Arity),
  477      functor(Head, Name, Arity),
  478      \+ (   predicate_property(M:Head, exported)
  479         ;   predicate_property(M:Head, public)
  480         ;   M == system
  481         ),
  482      !,
  483      current_predicate_options(M:Name/Arity, Arg, Options)
  484    },
  485    list(Options).
  486expand_pass_to(Option, _) -->
  487    [Option].
  488
  489list([]) --> [].
  490list([H|T]) --> [H], list(T).
  491
  492%!  derived_predicate_options(+Module) is det.
  493%
  494%   Derive predicate option declarations for   a module. The derived
  495%   options are printed to the =current_output= stream.
  496
  497derived_predicate_options(Module) :-
  498    var(Module),
  499    !,
  500    forall(current_module(Module),
  501           derived_predicate_options(Module)).
  502derived_predicate_options(Module) :-
  503    findall(predicate_options(Module:PI, Arg, Options),
  504            ( derived_predicate_options(Module:PI, Arg, Options),
  505              PI = Name/Arity,
  506              functor(Head, Name, Arity),
  507              (   predicate_property(Module:Head, exported)
  508              ->  true
  509              ;   predicate_property(Module:Head, public)
  510              )
  511            ),
  512            Decls0),
  513    maplist(qualify_decl(Module), Decls0, Decls1),
  514    sort(Decls1, Decls),
  515    (   Decls \== []
  516    ->  format('~N~n~n% Predicate option declarations for module ~q~n~n',
  517               [Module]),
  518        forall(member(Decl, Decls),
  519               portray_clause((:-Decl)))
  520    ;   true
  521    ).
  522
  523qualify_decl(M,
  524             predicate_options(PI0, Arg, Options0),
  525             predicate_options(PI1, Arg, Options1)) :-
  526    qualify(PI0, M, PI1),
  527    maplist(qualify_option(M), Options0, Options1).
  528
  529qualify_option(M, pass_to(PI0, Arg), pass_to(PI1, Arg)) :-
  530    !,
  531    qualify(PI0, M, PI1).
  532qualify_option(_, Opt, Opt).
  533
  534qualify(M:Term, M, Term) :- !.
  535qualify(QTerm, _, QTerm).
  536
  537
  538                 /*******************************
  539                 *            CLEANUP           *
  540                 *******************************/
  541
  542%!  retractall_predicate_options is det.
  543%
  544%   Remove all dynamically (derived) predicate options.
  545
  546retractall_predicate_options :-
  547    forall(retract(dyn_option_decl(_,M,_)),
  548           abolish(M:'$dyn_pred_option'/4)).
  549
  550
  551                 /*******************************
  552                 *     COMPILE-TIME CHECKER     *
  553                 *******************************/
  554
  555
  556:- thread_local
  557    new_decl/1.  558
  559%!  check_predicate_options is det.
  560%
  561%   Analyse loaded program for  erroneous   options.  This predicate
  562%   decompiles  the  current  program  and  searches  for  calls  to
  563%   predicates that process  options.  For   each  option  list,  it
  564%   validates  whether  the  provided  options   are  supported  and
  565%   validates the argument type.  This   predicate  performs partial
  566%   dataflow analysis to track option-lists inside a clause.
  567%
  568%   @see    derive_predicate_options/0 can be used to derive
  569%           declarations for predicates that pass options. This
  570%           predicate should normally be called before
  571%           check_predicate_options/0.
  572
  573check_predicate_options :-
  574    forall(current_module(Module),
  575           check_predicate_options_module(Module)).
  576
  577%!  derive_predicate_options is det.
  578%
  579%   Derive  new  predicate  option    declarations.  This  predicate
  580%   analyses the loaded program to find clauses that process options
  581%   using one of  the  predicates   from  library(option)  or passes
  582%   options to other predicates that are   known to process options.
  583%   The process is repeated until no new declarations are retrieved.
  584%
  585%   @see autoload/0 may be used to complete the loaded program.
  586
  587derive_predicate_options :-
  588    derive_predicate_options(NewDecls),
  589    (   NewDecls == []
  590    ->  true
  591    ;   print_message(informational, check_options(new(NewDecls))),
  592        new_decls(NewDecls),
  593        derive_predicate_options
  594    ).
  595
  596new_decls([]).
  597new_decls([predicate_options(PI, A, O)|T]) :-
  598    assert_predicate_options(PI, A, O, _),
  599    new_decls(T).
  600
  601
  602derive_predicate_options(NewDecls) :-
  603    call_cleanup(
  604        ( forall(
  605              current_module(Module),
  606              forall(
  607                  ( predicate_in_module(Module, PI),
  608                    PI = Name/Arity,
  609                    functor(Head, Name, Arity),
  610                    catch(Module:clause(Head, Body, Ref), _, fail)
  611                  ),
  612                  check_clause((Head:-Body), Module, Ref, decl))),
  613          (   setof(Decl, retract(new_decl(Decl)), NewDecls)
  614              ->  true
  615              ;   NewDecls = []
  616          )
  617        ),
  618        retractall(new_decl(_))).
  619
  620
  621check_predicate_options_module(Module) :-
  622    forall(predicate_in_module(Module, PI),
  623           check_predicate_options(Module:PI)).
  624
  625predicate_in_module(Module, PI) :-
  626    current_predicate(Module:PI),
  627    PI = Name/Arity,
  628    functor(Head, Name, Arity),
  629    \+ predicate_property(Module:Head, imported_from(_)).
  630
  631%!  check_predicate_options(:PredicateIndicator) is det.
  632%
  633%   Verify calls to predicates that have   options in all clauses of
  634%   the predicate indicated by PredicateIndicator.
  635
  636check_predicate_options(Module:Name/Arity) :-
  637    debug(predicate_options, 'Checking ~q', [Module:Name/Arity]),
  638    functor(Head, Name, Arity),
  639    forall(catch(Module:clause(Head, Body, Ref), _, fail),
  640           check_clause((Head:-Body), Module, Ref, check)).
  641
  642%!  check_clause(+Clause, +Module, +Ref, +Action) is det.
  643%
  644%   Action is one of
  645%
  646%     * decl
  647%     Create additional declarations
  648%     * check
  649%     Produce error messages
  650
  651check_clause((Head:-Body), M, ClauseRef, Action) :-
  652    !,
  653    catch(check_body(Body, M, _, Action), E, true),
  654    (   var(E)
  655    ->  option_decl(M:Head, Action)
  656    ;   (   clause_info(ClauseRef, File, TermPos, _NameOffset),
  657            TermPos = term_position(_,_,_,_,[_,BodyPos]),
  658            catch(check_body(Body, M, BodyPos, Action),
  659                  error(Formal, ArgPos), true),
  660            compound(ArgPos),
  661            arg(1, ArgPos, CharCount),
  662            integer(CharCount)
  663        ->  Location = file_char_count(File, CharCount)
  664        ;   Location = clause(ClauseRef),
  665            E = error(Formal, _)
  666        ),
  667        print_message(error, predicate_option_error(Formal, Location))
  668    ).
  669
  670
  671%!  check_body(+Body, +Module, +TermPos, +Action)
  672
  673:- multifile
  674    prolog:called_by/4,             % +Goal, +Module, +Context, -Called
  675    prolog:called_by/2.             % +Goal, -Called
  676
  677check_body(Var, _, _, _) :-
  678    var(Var),
  679    !.
  680check_body(M:G, _, term_position(_,_,_,_,[_,Pos]), Action) :-
  681    !,
  682    check_body(G, M, Pos, Action).
  683check_body((A,B), M, term_position(_,_,_,_,[PA,PB]), Action) :-
  684    !,
  685    check_body(A, M, PA, Action),
  686    check_body(B, M, PB, Action).
  687check_body((A;B), M, term_position(_,_,_,_,[PA,PB]), Action) :-
  688    !,
  689    \+ \+ check_body(A, M, PA, Action),
  690    \+ \+ check_body(B, M, PB, Action).
  691check_body(A=B, _, _, _) :-             % partial evaluation
  692    unify_with_occurs_check(A,B),
  693    !.
  694check_body(Goal, M, term_position(_,_,_,_,ArgPosList), Action) :-
  695    callable(Goal),
  696    functor(Goal, Name, Arity),
  697    (   '$get_predicate_attribute'(M:Goal, imported, DefM)
  698    ->  true
  699    ;   DefM = M
  700    ),
  701    (   eval_option_pred(DefM:Goal)
  702    ->  true
  703    ;   current_option_arg(DefM:Name/Arity, OptArg),
  704        !,
  705        arg(OptArg, Goal, Options),
  706        nth1(OptArg, ArgPosList, ArgPos),
  707        check_options(DefM:Name/Arity, OptArg, Options, ArgPos, Action)
  708    ).
  709check_body(Goal, M, _, Action) :-
  710    (   (   predicate_property(M:Goal, imported_from(IM))
  711        ->  true
  712        ;   IM = M
  713        ),
  714        prolog:called_by(Goal, IM, M, Called)
  715    ;   prolog:called_by(Goal, Called)
  716    ),
  717    !,
  718    check_called_by(Called, M, Action).
  719check_body(Meta, M, term_position(_,_,_,_,ArgPosList), Action) :-
  720    '$get_predicate_attribute'(M:Meta, meta_predicate, Head),
  721    !,
  722    check_meta_args(1, Head, Meta, M, ArgPosList, Action).
  723check_body(_, _, _, _).
  724
  725check_meta_args(I, Head, Meta, M, [ArgPos|ArgPosList], Action) :-
  726    arg(I, Head, AS),
  727    !,
  728    (   AS == 0
  729    ->  arg(I, Meta, MA),
  730        check_body(MA, M, ArgPos, Action)
  731    ;   true
  732    ),
  733    succ(I, I2),
  734    check_meta_args(I2, Head, Meta, M, ArgPosList, Action).
  735check_meta_args(_,_,_,_, _, _).
  736
  737%!  check_called_by(+CalledBy, +M, +Action) is det.
  738%
  739%   Handle results from prolog:called_by/2.
  740
  741check_called_by([], _, _).
  742check_called_by([H|T], M, Action) :-
  743    (   H = G+N
  744    ->  (   extend(G, N, G2)
  745        ->  check_body(G2, M, _, Action)
  746        ;   true
  747        )
  748    ;   check_body(H, M, _, Action)
  749    ),
  750    check_called_by(T, M, Action).
  751
  752extend(Goal, N, GoalEx) :-
  753    callable(Goal),
  754    Goal =.. List,
  755    length(Extra, N),
  756    append(List, Extra, ListEx),
  757    GoalEx =.. ListEx.
  758
  759
  760%!  check_options(:Predicate, +OptionArg, +Options, +ArgPos, +Action)
  761%
  762%   Verify the list Options,  that  is   passed  into  Predicate  on
  763%   argument OptionArg. ArgPos is a   term-position  term describing
  764%   the location of the Options list. If  Options is a partial list,
  765%   the tail is annotated with pass_to(PI, OptArg).
  766
  767check_options(PI, OptArg, QOptions, ArgPos, Action) :-
  768    debug(predicate_options, '\tChecking call to ~q', [PI]),
  769    remove_qualifier(QOptions, Options),
  770    must_be(list_or_partial_list, Options),
  771    check_option_list(Options, PI, OptArg, Options, ArgPos, Action).
  772
  773remove_qualifier(X, X) :-
  774    var(X),
  775    !.
  776remove_qualifier(_:X, X) :- !.
  777remove_qualifier(X, X).
  778
  779check_option_list(Var,  PI, OptArg, _, _, _) :-
  780    var(Var),
  781    !,
  782    annotate(Var, pass_to(PI, OptArg)).
  783check_option_list([], _, _, _, _, _).
  784check_option_list([H|T], PI, OptArg, Options, ArgPos, Action) :-
  785    check_option(PI, OptArg, H, ArgPos, Action),
  786    check_option_list(T, PI, OptArg, Options, ArgPos, Action).
  787
  788check_option(_, _, _, _, decl) :- !.
  789check_option(PI, OptArg, Opt, ArgPos, _) :-
  790    catch(check_predicate_option(PI, OptArg, Opt), E, true),
  791    !,
  792    (   var(E)
  793    ->  true
  794    ;   E = error(Formal,_),
  795        throw(error(Formal,ArgPos))
  796    ).
  797
  798
  799                 /*******************************
  800                 *          ANNOTATIONS         *
  801                 *******************************/
  802
  803%!  annotate(+Var, +Term) is det.
  804%
  805%   Use constraints to accumulate annotations   about  variables. If
  806%   two annotated variables are unified, the attributes are joined.
  807
  808annotate(Var, Term) :-
  809    (   get_attr(Var, predopts_analysis, Old)
  810    ->  put_attr(Var, predopts_analysis, [Term|Old])
  811    ;   var(Var)
  812    ->  put_attr(Var, predopts_analysis, [Term])
  813    ;   true
  814    ).
  815
  816annotations(Var, Annotations) :-
  817    get_attr(Var, predopts_analysis, Annotations).
  818
  819predopts_analysis:attr_unify_hook(Opts, Value) :-
  820    get_attr(Value, predopts_analysis, Others),
  821    !,
  822    append(Opts, Others, All),
  823    put_attr(Value, predopts_analysis, All).
  824predopts_analysis:attr_unify_hook(_, _).
  825
  826
  827                 /*******************************
  828                 *         PARTIAL EVAL         *
  829                 *******************************/
  830
  831eval_option_pred(swi_option:option(Opt, Options)) :-
  832    processes(Opt, Spec),
  833    annotate(Options, Spec).
  834eval_option_pred(swi_option:option(Opt, Options, _Default)) :-
  835    processes(Opt, Spec),
  836    annotate(Options, Spec).
  837eval_option_pred(swi_option:select_option(Opt, Options, Rest)) :-
  838    ignore(unify_with_occurs_check(Rest, Options)),
  839    processes(Opt, Spec),
  840    annotate(Options, Spec).
  841eval_option_pred(swi_option:select_option(Opt, Options, Rest, _Default)) :-
  842    ignore(unify_with_occurs_check(Rest, Options)),
  843    processes(Opt, Spec),
  844    annotate(Options, Spec).
  845eval_option_pred(swi_option:meta_options(_Cond, QOptionsIn, QOptionsOut)) :-
  846    remove_qualifier(QOptionsIn, OptionsIn),
  847    remove_qualifier(QOptionsOut, OptionsOut),
  848    ignore(unify_with_occurs_check(OptionsIn, OptionsOut)).
  849
  850processes(Opt, Spec) :-
  851    compound(Opt),
  852    functor(Opt, OptName, 1),
  853    Spec =.. [OptName,any].
  854
  855
  856                 /*******************************
  857                 *        NEW DECLARTIONS       *
  858                 *******************************/
  859
  860%!  option_decl(:Head, +Action) is det.
  861%
  862%   Add new declarations based on attributes   left  by the analysis
  863%   pass. We do not add declarations   for system modules or modules
  864%   that already contain static declarations.
  865%
  866%   @tbd    Should we add a mode to include generating declarations
  867%           for system modules and modules with static declarations?
  868
  869option_decl(_, check) :- !.
  870option_decl(M:_, _) :-
  871    system_module(M),
  872    !.
  873option_decl(M:_, _) :-
  874    has_static_option_decl(M),
  875    !.
  876option_decl(M:Head, _) :-
  877    compound(Head),
  878    arg(AP, Head, QA),
  879    remove_qualifier(QA, A),
  880    annotations(A, Annotations0),
  881    functor(Head, Name, Arity),
  882    PI = M:Name/Arity,
  883    delete(Annotations0, pass_to(PI,AP), Annotations),
  884    Annotations \== [],
  885    Decl = predicate_options(PI, AP, Annotations),
  886    (   new_decl(Decl)
  887    ->  true
  888    ;   assert_predicate_options(M:Name/Arity, AP, Annotations, false)
  889    ->  true
  890    ;   assertz(new_decl(Decl)),
  891        debug(predicate_options(decl), '~q', [Decl])
  892    ),
  893    fail.
  894option_decl(_, _).
  895
  896system_module(system) :- !.
  897system_module(Module) :-
  898    sub_atom(Module, 0, _, _, $).
  899
  900
  901                 /*******************************
  902                 *             MISC             *
  903                 *******************************/
  904
  905canonical_pi(M:Name//Arity, M:Name/PArity) :-
  906    integer(Arity),
  907    PArity is Arity+2.
  908canonical_pi(PI, PI).
  909
  910%!  resolve_module(:PI, -DefPI) is det.
  911%
  912%   Find the real predicate  indicator   pointing  to the definition
  913%   module of PI. This is similar to using predicate_property/3 with
  914%   the       property       imported_from,         but        using
  915%   '$get_predicate_attribute'/3    avoids    auto-importing     the
  916%   predicate.
  917
  918resolve_module(Module:Name/Arity, DefM:Name/Arity) :-
  919    functor(Head, Name, Arity),
  920    (   '$get_predicate_attribute'(Module:Head, imported, M)
  921    ->  DefM = M
  922    ;   DefM = Module
  923    ).
  924
  925
  926                 /*******************************
  927                 *            MESSAGES          *
  928                 *******************************/
  929:- multifile
  930    prolog:message//1.  931
  932prolog:message(predicate_option_error(Formal, Location)) -->
  933    error_location(Location),
  934    '$messages':term_message(Formal). % TBD: clean interface
  935prolog:message(check_options(new(Decls))) -->
  936    [ 'Inferred declarations:'-[], nl ],
  937    new_decls(Decls).
  938
  939error_location(file_char_count(File, CharPos)) -->
  940    { filepos_line(File, CharPos, Line, LinePos) },
  941    [ url(File:Line:LinePos), ': ' ].
  942error_location(clause(ClauseRef)) -->
  943    { clause_property(ClauseRef, file(File)),
  944      clause_property(ClauseRef, line_count(Line))
  945    },
  946    !,
  947    [ url(File:Line), ': ' ].
  948error_location(clause(ClauseRef)) -->
  949    [ 'Clause ~q: '-[ClauseRef] ].
  950
  951filepos_line(File, CharPos, Line, LinePos) :-
  952    setup_call_cleanup(
  953        ( open(File, read, In),
  954          open_null_stream(Out)
  955        ),
  956        ( Skip is CharPos-1,
  957          copy_stream_data(In, Out, Skip),
  958          stream_property(In, position(Pos)),
  959          stream_position_data(line_count, Pos, Line),
  960          stream_position_data(line_position, Pos, LinePos)
  961        ),
  962        ( close(Out),
  963          close(In)
  964        )).
  965
  966new_decls([]) --> [].
  967new_decls([H|T]) -->
  968    [ '    :- ~q'-[H], nl ],
  969    new_decls(T).
  970
  971
  972                 /*******************************
  973                 *      SYSTEM DECLARATIONS     *
  974                 *******************************/