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)  2007-2014, University of 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((record),
   36          [ (record)/1,                 % +Record
   37            current_record/2,           % ?Name, ?Term
   38            current_record_predicate/2, % ?Record, :PI
   39            op(1150, fx, record)
   40          ]).   41:- autoload(library(error),
   42	    [ instantiation_error/1,
   43	      current_type/3,
   44	      domain_error/2,
   45	      must_be/2
   46	    ]).   47:- autoload(library(lists),[member/2]).   48
   49
   50/** <module> Access compound arguments by name
   51
   52This module creates a set of predicates   to  create a default instance,
   53access and modify records represented as a compound term.
   54
   55The full documentation is  with  record/1,  which   must  be  used  as a
   56_directive_.  Here is a simple example declaration and some calls.
   57
   58==
   59:- record point(x:integer=0, y:integer=0).
   60
   61        default_point(Point),
   62        point_x(Point, X),
   63        set_x_of_point(10, Point, Point1),
   64
   65        make_point([y(20)], YPoint),
   66==
   67
   68@author Jan Wielemaker
   69@author Richard O'Keefe
   70*/
   71
   72:- multifile
   73    error:has_type/2,
   74    prolog:generated_predicate/1.   75
   76error:has_type(record(M:Name), X) :-
   77    is_record(Name, M, X).
   78
   79is_record(Name, M, X) :-
   80    current_record(Name, M, _, X, IsX),
   81    !,
   82    call(M:IsX).
   83
   84%!  record(+RecordDef)
   85%
   86%   Define access predicates for a compound-term. RecordDef is of
   87%   the form <constructor>(<argument>, ...), where each argument
   88%   is of the form:
   89%
   90%     * <name>[:<type>][=<default>]
   91%
   92%   Used a directive, =|:- record Constructor(Arg, ...)|= is expanded
   93%   info the following predicates:
   94%
   95%     * =|<constructor>_<name>|=(Record, Value)
   96%     * =|<constructor>_data|=(?Name, ?Record, ?Value)
   97%     * =|default_<constructor>|=(-Record)
   98%     * =|is_<constructor>|=(@Term)
   99%     * =|make_<constructor>|=(+Fields, -Record)
  100%     * =|make_<constructor>|=(+Fields, -Record, -RestFields)
  101%     * =|set_<name>_of_<constructor>|=(+Value, +OldRecord, -New)
  102%     * =|set_<name>_of_<constructor>|=(+Value, !Record)
  103%     * =|nb_set_<name>_of_<constructor>|=(+Value, !Record)
  104%     * =|set_<constructor>_fields|=(+Fields, +Record0, -Record).
  105%     * =|set_<constructor>_fields|=(+Fields, +Record0, -Record, -RestFields).
  106%     * =|set_<constructor>_field|=(+Field, +Record0, -Record).
  107%     * =|user:current_record|=(:<constructor>)
  108
  109record(Record) :-
  110    Record == '<compiled>',
  111    !.
  112record(Record) :-
  113    throw(error(context_error(nodirective, record(Record)), _)).
  114
  115
  116%!  compile_records(+RecordsDefs, -Clauses) is det.
  117%
  118%   Compile a record specification into a list of clauses.
  119
  120compile_records(Spec,
  121                [ (:- record('<compiled>')) % call to make xref aware of
  122                | Clauses                   % the dependency
  123                ]) :-
  124    phrase(compile_records(Spec), Clauses).
  125%       maplist(portray_clause, Clauses).
  126
  127compile_records(Var) -->
  128    { var(Var),
  129      !,
  130      instantiation_error(Var)
  131    }.
  132compile_records((A,B)) -->
  133    compile_record(A),
  134    compile_records(B).
  135compile_records(A) -->
  136    compile_record(A).
  137
  138%!  compile_record(+Record)// is det.
  139%
  140%   Create clauses for Record.
  141
  142compile_record(RecordDef) -->
  143    { RecordDef =.. [Constructor|Args],
  144      defaults(Args, Defs, TypedArgs),
  145      types(TypedArgs, Names, Types),
  146      atom_concat(default_, Constructor, DefName),
  147      atom_concat(Constructor, '_data', DataName),
  148      DefRecord =.. [Constructor|Defs],
  149      DefClause =.. [DefName,DefRecord],
  150      length(Names, Arity)
  151    },
  152    [ DefClause ],
  153    access_predicates(Names, 1, Arity, Constructor),
  154    data_predicate(Names, 1, Arity, Constructor, DataName),
  155    set_predicates(Names, 1, Arity, Types, Constructor),
  156    set_field_predicates(Names, 1, Arity, Types, Constructor),
  157    make_predicate(Constructor),
  158    is_predicate(Constructor, Types),
  159    current_clause(RecordDef).
  160
  161:- meta_predicate
  162    current_record(?, :),
  163    current_record_predicate(?, :).  164:- multifile
  165    current_record/5.               % Name, Module, Term, X, IsX
  166
  167%!  current_record(?Name, :Term)
  168%
  169%   True if Name is the  name  of   a  record  defined in the module
  170%   associated with Term  and  Term   is  the  user-provided  record
  171%   declaration.
  172
  173current_record(Name, M:Term) :-
  174    current_record(Name, M, Term, _, _).
  175
  176current_clause(RecordDef) -->
  177    { prolog_load_context(module, M),
  178      functor(RecordDef, Name, _),
  179      atom_concat(is_, Name, IsName),
  180      IsX =.. [IsName, X]
  181    },
  182    [ (record):current_record(Name, M, RecordDef, X, IsX)
  183    ].
  184
  185
  186%!  current_record_predicate(?Record, ?PI) is nondet.
  187%
  188%   True if PI is the predicate indicator for an access predicate to
  189%   Record. This predicate is intended   to support cross-referencer
  190%   tools.
  191
  192current_record_predicate(Record, M:PI) :-
  193    (   ground(PI)
  194    ->  Det = true
  195    ;   Det = false
  196    ),
  197    current_record(Record, M:RecordDef),
  198    (   general_record_pred(Record, M:PI)
  199    ;   RecordDef =.. [_|Args],
  200        defaults(Args, _Defs, TypedArgs),
  201        types(TypedArgs, Names, _Types),
  202        member(Field, Names),
  203        field_record_pred(Record, Field, M:PI)
  204    ),
  205    (   Det == true
  206    ->  !
  207    ;   true
  208    ).
  209
  210general_record_pred(Record, _:Name/1) :-
  211    atom_concat(is_, Record, Name).
  212general_record_pred(Record, _:Name/1) :-
  213    atom_concat(default_, Record, Name).
  214general_record_pred(Record, _:Name/A) :-
  215    member(A, [2,3]),
  216    atom_concat(make_, Record, Name).
  217general_record_pred(Record, _:Name/3) :-
  218    atom_concat(Record, '_data', Name).
  219general_record_pred(Record, _:Name/A) :-
  220    member(A, [3,4]),
  221    atomic_list_concat([set_, Record, '_fields'], Name).
  222general_record_pred(Record, _:Name/3) :-
  223    atomic_list_concat([set_, Record, '_field'], Name).
  224
  225field_record_pred(Record, Field, _:Name/2) :-
  226    atomic_list_concat([Record, '_', Field], Name).
  227field_record_pred(Record, Field, _:Name/A) :-
  228    member(A, [2,3]),
  229    atomic_list_concat([set_, Field, '_of_', Record], Name).
  230field_record_pred(Record, Field, _:Name/2) :-
  231    atomic_list_concat([nb_set_, Field, '_of_', Record], Name).
  232
  233prolog:generated_predicate(P) :-
  234    current_record_predicate(_, P).
  235
  236%!  make_predicate(+Constructor)// is det.
  237%
  238%   Creates the make_<constructor>(+Fields, -Record) predicate. This
  239%   looks like this:
  240%
  241%   ==
  242%   make_<constructor>(Fields, Record) :-
  243%           make_<constructor>(Fields, Record, [])
  244%
  245%   make_<constructor>(Fields, Record, RestFields) :-
  246%           default_<constructor>(Record0),
  247%           set_<constructor>_fields(Fields, Record0, Record, RestFields).
  248%
  249%   set_<constructor>_fields(Fields, Record0, Record) :-
  250%           set_<constructor>_fields(Fields, Record0, Record, []).
  251%
  252%   set_<constructor>_fields([], Record, Record, []).
  253%   set_<constructor>_fields([H|T], Record0, Record, RestFields) :-
  254%           (   set_<constructor>_field(H, Record0, Record1)
  255%           ->  set_<constructor>_fields(T, Record1, Record, RestFields)
  256%           ;   RestFields = [H|RF],
  257%               set_<constructor>_fields(T, Record0, Record, RF)
  258%           ).
  259%
  260%   set_<constructor>_field(<name1>(Value), Record0, Record).
  261%   ...
  262%   ==
  263
  264make_predicate(Constructor) -->
  265    { atomic_list_concat([make_, Constructor], MakePredName),
  266      atomic_list_concat([default_, Constructor], DefPredName),
  267      atomic_list_concat([set_, Constructor, '_fields'], SetFieldsName),
  268      atomic_list_concat([set_, Constructor, '_field'], SetFieldName),
  269      MakeHead3 =.. [MakePredName, Fields, Record],
  270      MakeHead4 =.. [MakePredName, Fields, Record, []],
  271      MakeClause3 = (MakeHead3 :- MakeHead4),
  272      MakeHead =.. [MakePredName, Fields, Record, RestFields],
  273      DefGoal  =.. [DefPredName, Record0],
  274      SetGoal  =.. [SetFieldsName, Fields, Record0, Record, RestFields],
  275      MakeClause = (MakeHead :- DefGoal, SetGoal),
  276      SetHead3 =.. [SetFieldsName, Fields, R0, R],
  277      SetHead4 =.. [SetFieldsName, Fields, R0, R, []],
  278      SetClause0 = (SetHead3 :- SetHead4),
  279      SetClause1 =.. [SetFieldsName, [], R, R, []],
  280      SetHead2  =.. [SetFieldsName, [H|T], R0, R, RF],
  281      SetGoal2a =.. [SetFieldName, H, R0, R1],
  282      SetGoal2b =.. [SetFieldsName, T, R1, R, RF],
  283      SetGoal2c =.. [SetFieldsName, T, R0, R, RF1],
  284      SetClause2 = (SetHead2 :- (SetGoal2a -> SetGoal2b ; RF=[H|RF1], SetGoal2c))
  285    },
  286    [ MakeClause3, MakeClause, SetClause0, SetClause1, SetClause2 ].
  287
  288%!  is_predicate(+Constructor, +Types)// is det.
  289%
  290%   Create a clause that tests for a given record type.
  291
  292is_predicate(Constructor, Types) -->
  293    { type_checks(Types, Vars, Body0),
  294      clean_body(Body0, Body),
  295      Term =.. [Constructor|Vars],
  296      atom_concat(is_, Constructor, Name),
  297      Head1 =.. [Name,Var],
  298      Head2 =.. [Name,Term]
  299    },
  300    [   (Head1 :- var(Var), !, fail) ],
  301    (   { Body == true }
  302    ->  [ Head2 ]
  303    ;   [ (Head2 :- Body) ]
  304    ).
  305
  306type_checks([], [], true).
  307type_checks([any|T], [_|Vars], Body) :-
  308    type_checks(T, Vars, Body).
  309type_checks([Type|T], [V|Vars], (Goal, Body)) :-
  310    type_goal(Type, V, Goal),
  311    type_checks(T, Vars, Body).
  312
  313%!  type_goal(+Type, +Var, -BodyTerm) is det.
  314%
  315%   Inline type checking calls.
  316
  317type_goal(Type, Var, Body) :-
  318    current_type(Type, Var, Body),
  319    !.
  320type_goal(record(Record), Var, Body) :-
  321    !,
  322    atom_concat(is_, Record, Pred),
  323    Body =.. [Pred,Var].
  324type_goal(Record, Var, Body) :-
  325    atom(Record),
  326    !,
  327    atom_concat(is_, Record, Pred),
  328    Body =.. [Pred,Var].
  329type_goal(Type, _, _) :-
  330    domain_error(type, Type).
  331
  332
  333clean_body(Var, G) :-
  334    var(Var),
  335    !,
  336    G = Var.
  337clean_body(M:C0, G) :-
  338    nonvar(C0),
  339    control(C0),
  340    !,
  341    C0 =.. [Name|Args0],
  342    clean_args(Args0, M, Args),
  343    G =.. [Name|Args].
  344clean_body((A0,true), A) :-
  345    !,
  346    clean_body(A0, A).
  347clean_body((true,A0), A) :-
  348    !,
  349    clean_body(A0, A).
  350clean_body(C0, G) :-
  351    control(C0),
  352    !,
  353    C0 =.. [Name|Args0],
  354    clean_args(Args0, Args),
  355    G =.. [Name|Args].
  356clean_body(_:A, A) :-
  357    predicate_property(system:A, built_in),
  358    \+ predicate_property(system:A, meta_predicate(_)),
  359    !.
  360clean_body(A, A).
  361
  362clean_args([], []).
  363clean_args([H0|T0], [H|T]) :-
  364    clean_body(H0, H),
  365    clean_args(T0, T).
  366
  367clean_args([], _, []).
  368clean_args([H0|T0], M, [H|T]) :-
  369    clean_body(M:H0, H),
  370    clean_args(T0, M, T).
  371
  372control((_,_)).
  373control((_;_)).
  374control((_->_)).
  375control((_*->_)).
  376control(\+(_)).
  377
  378
  379%!  access_predicates(+Names, +Idx0, +Arity, +Constructor)// is det.
  380%
  381%   Create the <constructor>_<name>(Record, Value) predicates.
  382
  383access_predicates([], _, _, _) -->
  384    [].
  385access_predicates([Name|NT], I, Arity, Constructor) -->
  386    { atomic_list_concat([Constructor, '_', Name], PredName),
  387      functor(Record, Constructor, Arity),
  388      arg(I, Record, Value),
  389      Clause =.. [PredName, Record, Value],
  390      I2 is I + 1
  391    },
  392    [Clause],
  393    access_predicates(NT, I2, Arity, Constructor).
  394
  395
  396%!  data_predicate(+Names, +Idx0, +Arity, +Constructor, +DataName)// is det.
  397%
  398%   Create the <constructor>_data(Name, Record, Value) predicate.
  399
  400data_predicate([], _, _, _, _) -->
  401    [].
  402data_predicate([Name|NT], I, Arity, Constructor, DataName) -->
  403    { functor(Record, Constructor, Arity),
  404      arg(I, Record, Value),
  405      Clause =.. [DataName, Name, Record, Value],
  406      I2 is I + 1
  407    },
  408    [Clause],
  409    data_predicate(NT, I2, Arity, Constructor, DataName).
  410
  411
  412%!  set_predicates(+Names, +Idx0, +Arity, +Types, +Constructor)// is det.
  413%
  414%   Create the clauses
  415%
  416%           * set_<name>_of_<constructor>(Value, Old, New)
  417%           * set_<name>_of_<constructor>(Value, Record)
  418
  419set_predicates([], _, _, _, _) -->
  420    [].
  421set_predicates([Name|NT], I, Arity, [Type|TT], Constructor) -->
  422    { atomic_list_concat(['set_', Name, '_of_', Constructor], PredName),
  423      atomic_list_concat(['nb_set_', Name, '_of_', Constructor], NBPredName),
  424      length(Args, Arity),
  425      replace_nth(I, Args, Value, NewArgs),
  426      Old =.. [Constructor|Args],
  427      New =.. [Constructor|NewArgs],
  428      Head =.. [PredName, Value, Old, New],
  429      SetHead =.. [PredName, Value, Term],
  430      NBSetHead =.. [NBPredName, Value, Term],
  431      (   Type == any
  432      ->  Clause = Head,
  433          SetClause = (SetHead :- setarg(I, Term, Value)),
  434          NBSetClause = (NBSetHead :- nb_setarg(I, Term, Value))
  435      ;   type_check(Type, Value, MustBe),
  436          Clause = (Head :- MustBe),
  437          SetClause = (SetHead :- MustBe,
  438                                  setarg(I, Term, Value)),
  439          NBSetClause = (NBSetHead :- MustBe,
  440                                      nb_setarg(I, Term, Value))
  441      ),
  442      I2 is I + 1
  443    },
  444    [ Clause, SetClause, NBSetClause ],
  445    set_predicates(NT, I2, Arity, TT, Constructor).
  446
  447type_check(Type, Value, must_be(Type, Value)) :-
  448    current_type(Type, Value, _),
  449    !.
  450type_check(record(Spec), Value, must_be(record(M:Name), Value)) :-
  451    !,
  452    prolog_load_context(module, C),
  453    strip_module(C:Spec, M, Name).
  454type_check(Atom, Value, Check) :-
  455    atom(Atom),
  456    !,
  457    type_check(record(Atom), Value, Check).
  458
  459
  460%!  set_field_predicates(+Names, +Idx0, +Arity, +Types, +Constructor)// is det.
  461%
  462%   Create the clauses
  463%
  464%           * set_<constructor>_field(<name>(Value), Old, New)
  465
  466set_field_predicates([], _, _, _, _) -->
  467    [].
  468set_field_predicates([Name|NT], I, Arity, [Type|TT], Constructor) -->
  469    { atomic_list_concat(['set_', Constructor, '_field'], FieldPredName),
  470      length(Args, Arity),
  471      replace_nth(I, Args, Value, NewArgs),
  472      Old =.. [Constructor|Args],
  473      New =.. [Constructor|NewArgs],
  474      NameTerm =.. [Name, Value],
  475      SetFieldHead =.. [FieldPredName, NameTerm, Old, New],
  476      (   Type == any
  477      ->  SetField = SetFieldHead
  478      ;   type_check(Type, Value, MustBe),
  479          SetField = (SetFieldHead :- MustBe)
  480      ),
  481      I2 is I + 1
  482    },
  483    [ SetField ],
  484    set_field_predicates(NT, I2, Arity, TT, Constructor).
  485
  486
  487%!  replace_nth(+Index, +List, +Element, -NewList) is det.
  488%
  489%   Replace the Nth (1-based) element of a list.
  490
  491replace_nth(1, [_|T], V, [V|T]) :- !.
  492replace_nth(I, [H|T0], V, [H|T]) :-
  493    I2 is I - 1,
  494    replace_nth(I2, T0, V, T).
  495
  496
  497%!  defaults(+ArgsSpecs, -Defaults, -Args)
  498%
  499%   Strip the default specification from the argument specification.
  500
  501defaults([], [], []).
  502defaults([Arg=Default|T0], [Default|TD], [Arg|TA]) :-
  503    !,
  504    defaults(T0, TD, TA).
  505defaults([Arg|T0], [_|TD], [Arg|TA]) :-
  506    defaults(T0, TD, TA).
  507
  508
  509%!  types(+ArgsSpecs, -Defaults, -Args)
  510%
  511%   Strip the default specification from the argument specification.
  512
  513types([], [], []).
  514types([Name:Type|T0], [Name|TN], [Type|TT]) :-
  515    !,
  516    must_be(atom, Name),
  517    types(T0, TN, TT).
  518types([Name|T0], [Name|TN], [any|TT]) :-
  519    must_be(atom, Name),
  520    types(T0, TN, TT).
  521
  522
  523                 /*******************************
  524                 *            EXPANSION         *
  525                 *******************************/
  526
  527:- multifile
  528    system:term_expansion/2,
  529    sandbox:safe_primitive/1.  530:- dynamic
  531    system:term_expansion/2.  532
  533system:term_expansion((:- record(Record)), Clauses) :-
  534    compile_records(Record, Clauses).
  535
  536sandbox:safe_primitive((record):is_record(_,_,_))