34
35:- module((record),
36 [ (record)/1, 37 current_record/2, 38 current_record_predicate/2, 39 op(1150, fx, record)
40 ]).
41:- use_module(library(error)).
42
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
101
102record(Record) :-
103 Record == '<compiled>',
104 !.
105record(Record) :-
106 throw(error(context_error(nodirective, record(Record)), _)).
107
108
112
113compile_records(Spec,
114 [ (:- record('<compiled>')) % call to make xref aware of
115 | Clauses % the dependency
116 ]) :-
117 phrase(compile_records(Spec), 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
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. 159
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
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
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
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
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
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
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
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
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
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
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
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 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(_,_,_)).