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