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