This repository has been archived on 2023-08-20. You can view files and clone it, but cannot push or open issues or pull requests.
yap-6.3/LGPL/record.pl
2010-07-23 12:06:56 +01:00

406 lines
12 KiB
Prolog

/* $Id$
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: wielemak@science.uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 2007, University of Amsterdam
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- module((record),
[ (record)/1, % +Record
current_record/2, % ?Name, ?Term
op(1150, fx, record)
]).
:- use_module(library(error)).
/** <module> 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
@author Richard O'Keefe
*/
:- multifile
error:has_type/2.
error:has_type(record(M:Name), X) :-
current_record(Name, M, _, X, IsX), !,
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:
%
% * <name>[:<type>][=<default>]
%
% Used a directive, =|:- record Constructor(Arg, ...)|= is expanded
% info the following predicates:
%
% * <constructor>_<name>(Record, Value)
% * default_<constructor>(-Record)
% * is_<constructor>(@Term)
% * make_<constructor>(+Fields, -Record)
% * make_<constructor>(+Fields, -Record, -RestFields)
% * set_<name>_of_<constructor>(+Value, +OldRecord, -New)
% * set_<name>_of_<constructor>(+Value, !Record)
% * nb_set_<name>_of_<constructor>(+Value, !Record)
% * set_<constructor>_fields(+Fields, +Record0, -Record).
% * set_<constructor>_fields(+Fields, +Record0, -Record, -RestFields).
% * set_<constructor>_field(+Field, +Record0, -Record).
% * user:current_record(:<constructor>)
record(Record) :-
throw(error(context_error(nodirective, record(Record)), _)).
%% compile_records(+RecordsDefs, -Clauses) is det.
%
% Compile a record specification into a list of clauses.
compile_records(Spec, Clauses) :-
phrase(compile_records(Spec), Clauses).
% maplist(portray_clause, Clauses).
compile_records(Var) -->
{ var(Var), !,
instantiation_error(Var)
}.
compile_records((A,B)) -->
compile_record(A),
compile_records(B).
compile_records(A) -->
compile_record(A).
%% compile_record(+Record)// is det.
%
% Create clauses for Record.
compile_record(RecordDef) -->
{ RecordDef =.. [Constructor|Args],
defaults(Args, Defs, TypedArgs),
types(TypedArgs, Names, Types),
atom_concat(default_, Constructor, DefName),
DefRecord =.. [Constructor|Defs],
DefClause =.. [DefName,DefRecord],
length(Names, Arity)
},
[ DefClause ],
access_predicates(Names, 1, Arity, Constructor),
set_predicates(Names, 1, Arity, Types, Constructor),
set_field_predicates(Names, 1, Arity, Types, Constructor),
make_predicate(Constructor),
is_predicate(Constructor, Types),
current_clause(RecordDef).
:- meta_predicate
current_record(:).
:- multifile
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.
current_record(Name, M:Term) :-
current_record(Name, M, Term, _, _).
current_clause(RecordDef) -->
{ prolog_load_context(module, M),
functor(RecordDef, Name, _),
atom_concat(is_, Name, IsName),
IsX =.. [IsName, X]
},
[ (record):current_record(Name, M, RecordDef, X, IsX)
].
%% 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).
% ...
% ==
make_predicate(Constructor) -->
{ atomic_list_concat([make_, Constructor], MakePredName),
atomic_list_concat([default_, Constructor], DefPredName),
atomic_list_concat([set_, Constructor, '_fields'], SetFieldsName),
atomic_list_concat([set_, Constructor, '_field'], SetFieldName),
MakeHead3 =.. [MakePredName, Fields, Record],
MakeHead4 =.. [MakePredName, Fields, Record, []],
MakeClause3 = (MakeHead3 :- MakeHead4),
MakeHead =.. [MakePredName, Fields, Record, RestFields],
DefGoal =.. [DefPredName, Record0],
SetGoal =.. [SetFieldsName, Fields, Record0, Record, RestFields],
MakeClause = (MakeHead :- DefGoal, SetGoal),
SetHead3 =.. [SetFieldsName, Fields, R0, R],
SetHead4 =.. [SetFieldsName, Fields, R0, R, []],
SetClause0 = (SetHead3 :- SetHead4),
SetClause1 =.. [SetFieldsName, [], R, R, []],
SetHead2 =.. [SetFieldsName, [H|T], R0, R, RF],
SetGoal2a =.. [SetFieldName, H, R0, R1],
SetGoal2b =.. [SetFieldsName, T, R1, R, RF],
SetGoal2c =.. [SetFieldsName, T, R0, R, RF1],
SetClause2 = (SetHead2 :- (SetGoal2a -> SetGoal2b ; RF=[H|RF1], SetGoal2c))
},
[ MakeClause3, MakeClause, SetClause0, SetClause1, SetClause2 ].
%% is_predicate(+Constructor, +Types)// is det.
%
% Create a clause that tests for a given record type.
is_predicate(Constructor, Types) -->
{ type_checks(Types, Vars, Body0),
clean_body(Body0, Body),
Term =.. [Constructor|Vars],
atom_concat(is_, Constructor, Name),
Head1 =.. [Name,Var],
Head2 =.. [Name,Term]
},
[ (Head1 :- var(Var), !, fail) ],
( { Body == true }
-> [ Head2 ]
; [ (Head2 :- Body) ]
).
type_checks([], [], true).
type_checks([any|T], [_|Vars], Body) :-
type_checks(T, Vars, Body).
type_checks([Type|T], [V|Vars], (Goal, Body)) :-
type_goal(Type, V, Goal),
type_checks(T, Vars, Body).
%% type_goal(+Type, +Var, -BodyTerm) is det.
%
% Inline type checking calls.
type_goal(Type, Var, Body) :-
defined_type(Type, Var, Body), !.
type_goal(record(Record), Var, Body) :- !,
atom_concat(is_, Record, Pred),
Body =.. [Pred,Var].
type_goal(Record, Var, Body) :-
atom(Record), !,
atom_concat(is_, Record, Pred),
Body =.. [Pred,Var].
type_goal(Type, _, _) :-
domain_error(type, Type).
defined_type(Type, Var, error:Body) :-
clause(error:has_type(Type, Var), Body).
clean_body(M:(A0,B0), G) :- !,
clean_body(M:A0, A),
clean_body(M:B0, B),
clean_body((A,B), G).
clean_body((A0,true), A) :- !,
clean_body(A0, A).
clean_body((true,A0), A) :- !,
clean_body(A0, A).
clean_body((A0,B0), (A,B)) :-
clean_body(A0, A),
clean_body(B0, B).
clean_body(_:A, A) :-
predicate_property(A, built_in), !.
clean_body(A, A).
%% access_predicates(+Names, +Idx0, +Arity, +Constructor)// is det.
%
% Create the <constructor>_<name>(Record, Value) predicates.
access_predicates([], _, _, _) -->
[].
access_predicates([Name|NT], I, Arity, Constructor) -->
{ atomic_list_concat([Constructor, '_', Name], PredName),
functor(Record, Constructor, Arity),
arg(I, Record, Value),
Clause =.. [PredName, Record, Value],
I2 is I + 1
},
[Clause],
access_predicates(NT, I2, Arity, Constructor).
%% set_predicates(+Names, +Idx0, +Arity, +Types, +Constructor)// is det.
%
% Create the clauses
%
% * set_<name>_of_<constructor>(Value, Old, New)
% * set_<name>_of_<constructor>(Value, Record)
set_predicates([], _, _, _, _) -->
[].
set_predicates([Name|NT], I, Arity, [Type|TT], Constructor) -->
{ atomic_list_concat(['set_', Name, '_of_', Constructor], PredName),
atomic_list_concat(['nb_set_', Name, '_of_', Constructor], NBPredName),
length(Args, Arity),
replace_nth(I, Args, Value, NewArgs),
Old =.. [Constructor|Args],
New =.. [Constructor|NewArgs],
Head =.. [PredName, Value, Old, New],
SetHead =.. [PredName, Value, Term],
NBSetHead =.. [NBPredName, Value, Term],
( Type == any
-> Clause = Head,
SetClause = (SetHead :- setarg(I, Term, Value)),
NBSetClause = (NBSetHead :- nb_setarg(I, Term, Value))
; type_check(Type, Value, MustBe),
Clause = (Head :- MustBe),
SetClause = (SetHead :- MustBe,
setarg(I, Term, Value)),
NBSetClause = (NBSetHead :- MustBe,
nb_setarg(I, Term, Value))
),
I2 is I + 1
},
[ Clause, SetClause, NBSetClause ],
set_predicates(NT, I2, Arity, TT, Constructor).
type_check(Type, Value, must_be(Type, Value)) :-
defined_type(Type, Value, _), !.
type_check(record(Spec), Value, must_be(record(M:Name), Value)) :- !,
prolog_load_context(module, C),
strip_module(C:Spec, M, Name).
type_check(Atom, Value, Check) :-
atom(Atom), !,
type_check(record(Atom), Value, Check).
%% set_field_predicates(+Names, +Idx0, +Arity, +Types, +Constructor)// is det.
%
% Create the clauses
%
% * set_<constructor>_field(<name>(Value), Old, New)
set_field_predicates([], _, _, _, _) -->
[].
set_field_predicates([Name|NT], I, Arity, [Type|TT], Constructor) -->
{ atomic_list_concat(['set_', Constructor, '_field'], FieldPredName),
length(Args, Arity),
replace_nth(I, Args, Value, NewArgs),
Old =.. [Constructor|Args],
New =.. [Constructor|NewArgs],
NameTerm =.. [Name, Value],
SetFieldHead =.. [FieldPredName, NameTerm, Old, New],
( Type == any
-> SetField = SetFieldHead
; type_check(Type, Value, MustBe),
SetField = (SetFieldHead :- MustBe)
),
I2 is I + 1
},
[ SetField ],
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.
replace_nth(1, [_|T], V, [V|T]) :- !.
replace_nth(I, [H|T0], V, [H|T]) :-
I2 is I - 1,
replace_nth(I2, T0, V, T).
%% defaults(+ArgsSpecs, -Defaults, -Args)
%
% Strip the default specification from the argument specification.
defaults([], [], []).
defaults([Arg=Default|T0], [Default|TD], [Arg|TA]) :- !,
defaults(T0, TD, TA).
defaults([Arg|T0], [_|TD], [Arg|TA]) :-
defaults(T0, TD, TA).
%% types(+ArgsSpecs, -Defaults, -Args)
%
% Strip the default specification from the argument specification.
types([], [], []).
types([Name:Type|T0], [Name|TN], [Type|TT]) :- !,
must_be(atom, Name),
types(T0, TN, TT).
types([Name|T0], [Name|TN], [any|TT]) :-
must_be(atom, Name),
types(T0, TN, TT).
/*******************************
* EXPANSION *
*******************************/
:- multifile
system:term_expansion/2.
:- dynamic
system:term_expansion/2.
system:term_expansion((:- record(Record)), Clauses) :-
compile_records(Record, Clauses).