View source with raw 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:- 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]).

Access compound arguments by name

This module creates a set of predicates to create a default instance, access and modify records represented as a compound term.

The full documentation is with record/1, which must be used as a directive. Here is a simple example declaration and some calls.

:- record point(x:integer=0, y:integer=0).

        default_point(Point),
        point_x(Point, X),
        set_x_of_point(10, Point, Point1),

        make_point([y(20)], YPoint),
author
- Jan Wielemaker
- Richard O'Keefe */
   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).
 record(+RecordDef)
Define access predicates for a compound-term. RecordDef is of the form <constructor>(<argument>, ...), where each argument is of the form:

Used a directive, :- record Constructor(Arg, ...) is expanded info the following predicates:

  109record(Record) :-
  110    Record == '<compiled>',
  111    !.
  112record(Record) :-
  113    throw(error(context_error(nodirective, record(Record)), _)).
 compile_records(+RecordsDefs, -Clauses) is det
Compile a record specification into a list of clauses.
  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).
 compile_record(+Record)// is det
Create clauses for Record.
  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
 current_record(?Name, :Term)
True if Name is the name of a record defined in the module associated with Term and Term is the user-provided record declaration.
  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    ].
 current_record_predicate(?Record, ?PI) is nondet
True if PI is the predicate indicator for an access predicate to Record. This predicate is intended to support cross-referencer tools.
  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).
 make_predicate(+Constructor)// is det
Creates the make_<constructor>(+Fields, -Record) predicate. This looks like this: 
make_<constructor>(Fields, Record) :-
        make_<constructor>(Fields, Record, [])

make_<constructor>(Fields, Record, RestFields) :-
        default_<constructor>(Record0),
        set_<constructor>_fields(Fields, Record0, Record, RestFields).

set_<constructor>_fields(Fields, Record0, Record) :-
        set_<constructor>_fields(Fields, Record0, Record, []).

set_<constructor>_fields([], Record, Record, []).
set_<constructor>_fields([H|T], Record0, Record, RestFields) :-
        (   set_<constructor>_field(H, Record0, Record1)
        ->  set_<constructor>_fields(T, Record1, Record, RestFields)
        ;   RestFields = [H|RF],
            set_<constructor>_fields(T, Record0, Record, RF)
        ).

set_<constructor>_field(<name1>(Value), Record0, Record).
...
  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 ].
 is_predicate(+Constructor, +Types)// is det
Create a clause that tests for a given record type.
  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).
 type_goal(+Type, +Var, -BodyTerm) is det
Inline type checking calls.
  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(\+(_)).
 access_predicates(+Names, +Idx0, +Arity, +Constructor)// is det
Create the <constructor>_<name>(Record, Value) predicates.
  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).
 data_predicate(+Names, +Idx0, +Arity, +Constructor, +DataName)// is det
Create the <constructor>_data(Name, Record, Value) predicate.
  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).
 set_predicates(+Names, +Idx0, +Arity, +Types, +Constructor)// is det
Create the clauses 
  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).
 set_field_predicates(+Names, +Idx0, +Arity, +Types, +Constructor)// is det
Create the clauses 
  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).
 replace_nth(+Index, +List, +Element, -NewList) is det
Replace the Nth (1-based) element of a list.
  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).
 defaults(+ArgsSpecs, -Defaults, -Args)
Strip the default specification from the argument specification.
  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).
 types(+ArgsSpecs, -Defaults, -Args)
Strip the default specification from the argument specification.
  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(_,_,_))