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    defined_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
 325defined_type(Type, Var, error:Body) :-
 326    clause(error:has_type(Type, Var), Body).
 327
 328
 329clean_body(M:(A0,B0), G) :-
 330    !,
 331    clean_body(M:A0, A),
 332    clean_body(M:B0, B),
 333    clean_body((A,B), G).
 334clean_body((A0,true), A) :-
 335    !,
 336    clean_body(A0, A).
 337clean_body((true,A0), A) :-
 338    !,
 339    clean_body(A0, A).
 340clean_body((A0,B0), (A,B)) :-
 341    clean_body(A0, A),
 342    clean_body(B0, B).
 343clean_body(_:A, A) :-
 344    predicate_property(A, built_in),
 345    !.
 346clean_body(A, A).
 347
 348
 349%!  access_predicates(+Names, +Idx0, +Arity, +Constructor)// is det.
 350%
 351%   Create the <constructor>_<name>(Record, Value) predicates.
 352
 353access_predicates([], _, _, _) -->
 354    [].
 355access_predicates([Name|NT], I, Arity, Constructor) -->
 356    { atomic_list_concat([Constructor, '_', Name], PredName),
 357      functor(Record, Constructor, Arity),
 358      arg(I, Record, Value),
 359      Clause =.. [PredName, Record, Value],
 360      I2 is I + 1
 361    },
 362    [Clause],
 363    access_predicates(NT, I2, Arity, Constructor).
 364
 365
 366%!  data_predicate(+Names, +Idx0, +Arity, +Constructor, +DataName)// is det.
 367%
 368%   Create the <constructor>_data(Name, Record, Value) predicate.
 369
 370data_predicate([], _, _, _, _) -->
 371    [].
 372data_predicate([Name|NT], I, Arity, Constructor, DataName) -->
 373    { functor(Record, Constructor, Arity),
 374      arg(I, Record, Value),
 375      Clause =.. [DataName, Name, Record, Value],
 376      I2 is I + 1
 377    },
 378    [Clause],
 379    data_predicate(NT, I2, Arity, Constructor, DataName).
 380
 381
 382%!  set_predicates(+Names, +Idx0, +Arity, +Types, +Constructor)// is det.
 383%
 384%   Create the clauses
 385%
 386%           * set_<name>_of_<constructor>(Value, Old, New)
 387%           * set_<name>_of_<constructor>(Value, Record)
 388
 389set_predicates([], _, _, _, _) -->
 390    [].
 391set_predicates([Name|NT], I, Arity, [Type|TT], Constructor) -->
 392    { atomic_list_concat(['set_', Name, '_of_', Constructor], PredName),
 393      atomic_list_concat(['nb_set_', Name, '_of_', Constructor], NBPredName),
 394      length(Args, Arity),
 395      replace_nth(I, Args, Value, NewArgs),
 396      Old =.. [Constructor|Args],
 397      New =.. [Constructor|NewArgs],
 398      Head =.. [PredName, Value, Old, New],
 399      SetHead =.. [PredName, Value, Term],
 400      NBSetHead =.. [NBPredName, Value, Term],
 401      (   Type == any
 402      ->  Clause = Head,
 403          SetClause = (SetHead :- setarg(I, Term, Value)),
 404          NBSetClause = (NBSetHead :- nb_setarg(I, Term, Value))
 405      ;   type_check(Type, Value, MustBe),
 406          Clause = (Head :- MustBe),
 407          SetClause = (SetHead :- MustBe,
 408                                  setarg(I, Term, Value)),
 409          NBSetClause = (NBSetHead :- MustBe,
 410                                      nb_setarg(I, Term, Value))
 411      ),
 412      I2 is I + 1
 413    },
 414    [ Clause, SetClause, NBSetClause ],
 415    set_predicates(NT, I2, Arity, TT, Constructor).
 416
 417type_check(Type, Value, must_be(Type, Value)) :-
 418    defined_type(Type, Value, _),
 419    !.
 420type_check(record(Spec), Value, must_be(record(M:Name), Value)) :-
 421    !,
 422    prolog_load_context(module, C),
 423    strip_module(C:Spec, M, Name).
 424type_check(Atom, Value, Check) :-
 425    atom(Atom),
 426    !,
 427    type_check(record(Atom), Value, Check).
 428
 429
 430%!  set_field_predicates(+Names, +Idx0, +Arity, +Types, +Constructor)// is det.
 431%
 432%   Create the clauses
 433%
 434%           * set_<constructor>_field(<name>(Value), Old, New)
 435
 436set_field_predicates([], _, _, _, _) -->
 437    [].
 438set_field_predicates([Name|NT], I, Arity, [Type|TT], Constructor) -->
 439    { atomic_list_concat(['set_', Constructor, '_field'], FieldPredName),
 440      length(Args, Arity),
 441      replace_nth(I, Args, Value, NewArgs),
 442      Old =.. [Constructor|Args],
 443      New =.. [Constructor|NewArgs],
 444      NameTerm =.. [Name, Value],
 445      SetFieldHead =.. [FieldPredName, NameTerm, Old, New],
 446      (   Type == any
 447      ->  SetField = SetFieldHead
 448      ;   type_check(Type, Value, MustBe),
 449          SetField = (SetFieldHead :- MustBe)
 450      ),
 451      I2 is I + 1
 452    },
 453    [ SetField ],
 454    set_field_predicates(NT, I2, Arity, TT, Constructor).
 455
 456
 457%!  replace_nth(+Index, +List, +Element, -NewList) is det.
 458%
 459%   Replace the Nth (1-based) element of a list.
 460
 461replace_nth(1, [_|T], V, [V|T]) :- !.
 462replace_nth(I, [H|T0], V, [H|T]) :-
 463    I2 is I - 1,
 464    replace_nth(I2, T0, V, T).
 465
 466
 467%!  defaults(+ArgsSpecs, -Defaults, -Args)
 468%
 469%   Strip the default specification from the argument specification.
 470
 471defaults([], [], []).
 472defaults([Arg=Default|T0], [Default|TD], [Arg|TA]) :-
 473    !,
 474    defaults(T0, TD, TA).
 475defaults([Arg|T0], [_|TD], [Arg|TA]) :-
 476    defaults(T0, TD, TA).
 477
 478
 479%!  types(+ArgsSpecs, -Defaults, -Args)
 480%
 481%   Strip the default specification from the argument specification.
 482
 483types([], [], []).
 484types([Name:Type|T0], [Name|TN], [Type|TT]) :-
 485    !,
 486    must_be(atom, Name),
 487    types(T0, TN, TT).
 488types([Name|T0], [Name|TN], [any|TT]) :-
 489    must_be(atom, Name),
 490    types(T0, TN, TT).
 491
 492
 493                 /*******************************
 494                 *            EXPANSION         *
 495                 *******************************/
 496
 497:- multifile
 498    system:term_expansion/2,
 499    sandbox:safe_primitive/1.
 500:- dynamic
 501    system:term_expansion/2.
 502
 503system:term_expansion((:- record(Record)), Clauses) :-
 504    compile_records(Record, Clauses).
 505
 506sandbox:safe_primitive((record):is_record(_,_,_)).