1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936 | -----------------------------------------------------------------------
-- gen-model-xmi -- UML-XMI model
-- Copyright (C) 2012, 2013, 2015, 2016, 2021, 2022 Stephane Carrez
-- Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
-- You may obtain a copy of the License at
--
-- http://www.apache.org/licenses/LICENSE-2.0
--
-- Unless required by applicable law or agreed to in writing, software
-- distributed under the License is distributed on an "AS IS" BASIS,
-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-- See the License for the specific language governing permissions and
-- limitations under the License.
-----------------------------------------------------------------------
with Ada.Tags;
with Util.Strings;
with Util.Log.Loggers;
package body Gen.Model.XMI is
use Ada.Strings.Unbounded;
Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Gen.Model.XMI");
procedure Append_Message (Into : in out UString;
Message : in String);
-- ------------------------------
-- Append a message to the error message. A newline is inserted if the buffer contains
-- an existing message.
-- ------------------------------
procedure Append_Message (Into : in out UString;
Message : in String) is
begin
if Length (Into) > 0 then
Append (Into, ASCII.LF);
end if;
Append (Into, Message);
end Append_Message;
-- ------------------------------
-- Iterate on the model element of the type <tt>On</tt> and execute the <tt>Process</tt>
-- procedure.
-- ------------------------------
procedure Iterate (Model : in Model_Map.Map;
On : in Element_Type;
Process : not null access procedure (Id : in UString;
Node : in Model_Element_Access)) is
Iter : Model_Map_Cursor := Model.First;
begin
while Has_Element (Iter) loop
declare
Node : constant Model_Element_Access := Element (Iter);
begin
if Node.Get_Type = On then
Process (Model_Map.Key (Iter), Node);
end if;
end;
Next (Iter);
end loop;
end Iterate;
-- ------------------------------
-- Iterate over the model elements of the list.
-- ------------------------------
procedure Iterate_Elements (Closure : in out T;
List : in Model_Vector;
Process : not null access
procedure (Closure : in out T;
Node : in Model_Element_Access)) is
Iter : Model_Cursor := List.First;
begin
while Model_Vectors.Has_Element (Iter) loop
Process (Closure, Model_Vectors.Element (Iter));
Model_Vectors.Next (Iter);
end loop;
end Iterate_Elements;
-- ------------------------------
-- Find the model element with the given XMI id or given name.
-- Returns null if the model element is not found.
-- ------------------------------
function Find (Model : in Model_Map.Map;
Key : in String;
Mode : in Search_Type := BY_ID) return Model_Element_Access is
begin
if Mode = BY_ID then
declare
Pos : constant Model_Map_Cursor := Model.Find (To_UString (Key));
begin
if Has_Element (Pos) then
return Element (Pos);
else
Log.Error ("Model element id '{0}' not found", Key);
return null;
end if;
end;
else
declare
Iter : Model_Map_Cursor := Model.First;
Pos : Natural;
begin
if Key (Key'First) /= '@' then
Pos := Util.Strings.Index (Key, '.');
else
Pos := 0;
end if;
while Has_Element (Iter) loop
declare
Node : Model_Element_Access := Element (Iter);
begin
-- Find in the package only. If there is no '.', check the package name only.
if Node.Get_Type = XMI_PACKAGE then
if Pos = 0 and then Node.Name = Key then
return Node;
end if;
-- Check that the package name matches and look in it.
if Pos > 0 and then Node.Name = Key (Key'First .. Pos - 1) then
Node := Node.Find (Key (Pos + 1 .. Key'Last));
if Node /= null then
return Node;
end if;
end if;
end if;
end;
Next (Iter);
end loop;
end;
return null;
end if;
end Find;
-- ------------------------------
-- Find from the model file identified by <tt>Name</tt>, the model element with the
-- identifier or name represented by <tt>Key</tt>.
-- Returns null if the model element is not found.
-- ------------------------------
function Find_Element (Model : in UML_Model;
Name : in String;
Key : in String;
Mode : in Search_Type := BY_ID)
return Element_Type_Access is
Model_Pos : constant UML_Model_Map.Cursor := Model.Find (To_UString (Name));
Item : Model_Element_Access;
begin
if UML_Model_Map.Has_Element (Model_Pos) then
if Mode = BY_ID or else Mode = BY_NAME then
Item := Find (UML_Model_Map.Element (Model_Pos), Key, Mode);
else
declare
Iter : Model_Map_Cursor := UML_Model_Map.Element (Model_Pos).First;
begin
while Has_Element (Iter) loop
declare
Node : constant Model_Element_Access := Element (Iter);
begin
if Node.all in Element_Type'Class and then Node.Name = Key then
return Element_Type'Class (Node.all)'Access;
end if;
end;
Next (Iter);
end loop;
end;
end if;
if Item = null then
Log.Error ("The model file {0} does not define {1}",
Name, Key);
return null;
end if;
if not (Item.all in Element_Type'Class) then
Log.Error ("The model file {0} defines the element {1}",
Name, Key);
return null;
end if;
return Element_Type'Class (Item.all)'Access;
else
Log.Error ("Model file {0} not found", Name);
return null;
end if;
end Find_Element;
-- ------------------------------
-- Find the model element within all loaded UML models.
-- Returns null if the model element is not found.
-- ------------------------------
function Find (Model : in UML_Model;
Current : in Model_Map.Map;
Id : in UString)
return Model_Element_Access is
Pos : constant Natural := Index (Id, "#");
First : Natural;
begin
if Pos = 0 then
return Find (Current, To_String (Id));
end if;
First := Index (Id, "/", Pos, Ada.Strings.Backward);
if First = 0 then
First := 1;
else
First := First + 1;
end if;
declare
Len : constant Natural := Length (Id);
Name : constant UString := Unbounded_Slice (Id, First, Pos - 1);
Model_Pos : constant UML_Model_Map.Cursor := Model.Find (Name);
begin
if UML_Model_Map.Has_Element (Model_Pos) then
return Find (UML_Model_Map.Element (Model_Pos),
Slice (Id, Pos + 1, Len));
else
Log.Error ("Model element {0} not found", To_String (Id));
return null;
end if;
end;
end Find;
-- ------------------------------
-- Dump the XMI model elements.
-- ------------------------------
procedure Dump (Map : in Model_Map.Map) is
Iter : Model_Map_Cursor := Map.First;
begin
while Has_Element (Iter) loop
Element (Iter).Dump;
Next (Iter);
end loop;
end Dump;
-- ------------------------------
-- Reconcile all the UML model elements by resolving all the references to UML elements.
-- ------------------------------
procedure Reconcile (Model : in out UML_Model;
Debug : in Boolean := False) is
procedure Reconcile_Model (Key : in UString;
Map : in out Model_Map.Map);
procedure Reconcile_Model (Key : in UString;
Map : in out Model_Map.Map) is
pragma Unreferenced (Key);
Iter : Model_Map_Cursor := Map.First;
begin
while Has_Element (Iter) loop
declare
Node : constant Model_Element_Access := Element (Iter);
begin
Node.Reconcile (Model);
end;
Next (Iter);
end loop;
if Debug then
Gen.Model.XMI.Dump (Map);
end if;
end Reconcile_Model;
Iter : UML_Model_Map.Cursor := Model.First;
begin
while UML_Model_Map.Has_Element (Iter) loop
UML_Model_Map.Update_Element (Model, Iter, Reconcile_Model'Access);
UML_Model_Map.Next (Iter);
end loop;
end Reconcile;
-- ------------------------------
-- Reconcile the element by resolving the references to other elements in the model.
-- ------------------------------
procedure Reconcile (Node : in out Model_Element;
Model : in UML_Model) is
Iter : Model_Cursor := Node.Stereotypes.First;
begin
while Model_Vectors.Has_Element (Iter) loop
Model_Vectors.Element (Iter).Reconcile (Model);
Model_Vectors.Next (Iter);
end loop;
end Reconcile;
-- ------------------------------
-- Find the element with the given name. If the name is a qualified name, navigate
-- down the package/class to find the appropriate element.
-- Returns null if the element was not found.
-- ------------------------------
function Find (Node : in Model_Element;
Name : in String) return Model_Element_Access is
Pos : constant Natural := Util.Strings.Index (Name, '.');
Iter : Model_Cursor;
Item : Model_Element_Access;
begin
if Pos = 0 or else Name (Name'First) = '@' then
Iter := Node.Elements.First;
while Model_Vectors.Has_Element (Iter) loop
Item := Model_Vectors.Element (Iter);
if Item.Name = Name then
return Item;
end if;
Model_Vectors.Next (Iter);
end loop;
return null;
else
Item := Node.Find (Name (Name'First .. Pos - 1));
if Item = null then
return null;
end if;
return Item.Find (Name (Pos + 1 .. Name'Last));
end if;
end Find;
-- ------------------------------
-- Set the model name.
-- ------------------------------
procedure Set_Name (Node : in out Model_Element;
Value : in UBO.Object) is
begin
if not UBO.Is_Null (Value) then
Node.Set_Name (UBO.To_Unbounded_String (Value));
end if;
end Set_Name;
-- ------------------------------
-- Set the model XMI unique id.
-- ------------------------------
procedure Set_XMI_Id (Node : in out Model_Element;
Value : in UBO.Object) is
begin
Node.XMI_Id := UBO.To_Unbounded_String (Value);
end Set_XMI_Id;
-- ------------------------------
-- Validate the node definition as much as we can before the reconcile phase.
-- If an error is detected, return a message. Returns an empty string if everything is ok.
-- ------------------------------
function Get_Error_Message (Node : in Model_Element) return String is
Result : UString;
begin
if Length (Node.XMI_Id) = 0 then
Append (Result, "the 'xmi.id' attribute is empty");
end if;
return To_String (Result);
end Get_Error_Message;
-- ------------------------------
-- Dump the node to get some debugging description about it.
-- ------------------------------
procedure Dump (Node : in Model_Element) is
begin
Log.Info ("XMI {0} - {2}: {1}",
Element_Type'Image (Model_Element'Class (Node).Get_Type),
To_String (Node.XMI_Id), To_String (Node.Name));
if Node.Parent /= null then
Log.Info (" Parent: {0} ({1})", To_String (Node.Parent.Name),
Element_Type'Image (Node.Parent.Get_Type));
end if;
declare
Iter : Model_Cursor := Node.Tagged_Values.First;
Tag : Tagged_Value_Element_Access;
begin
while Model_Vectors.Has_Element (Iter) loop
Tag := Tagged_Value_Element'Class (Model_Vectors.Element (Iter).all)'Access;
if Tag.Tag_Def /= null then
Log.Info (" Tag: {0} = {1}",
To_String (Tag.Tag_Def.Name),
To_String (Tag.Value));
else
Log.Info (" Undef tag: {0} = {1}",
To_String (Tag.XMI_Id), To_String (Tag.Value));
end if;
Model_Vectors.Next (Iter);
end loop;
end;
declare
Stereotype : Model_Cursor := Node.Stereotypes.First;
begin
while Model_Vectors.Has_Element (Stereotype) loop
Log.Info (" Stereotype: <<{0}>>: {1}",
To_String (Model_Vectors.Element (Stereotype).Name),
To_String (Model_Vectors.Element (Stereotype).XMI_Id));
Model_Vectors.Next (Stereotype);
end loop;
end;
end Dump;
-- ------------------------------
-- Find the tag value element with the given name.
-- Returns null if there is no such tag.
-- ------------------------------
function Find_Tag_Value (Node : in Model_Element;
Name : in String) return Tagged_Value_Element_Access is
Pos : Model_Cursor := Node.Tagged_Values.First;
Tag : Model_Element_Access;
begin
while Model_Vectors.Has_Element (Pos) loop
Tag := Model_Vectors.Element (Pos);
if Tag.Name = Name then
return Tagged_Value_Element'Class (Tag.all)'Access;
end if;
Model_Vectors.Next (Pos);
end loop;
return null;
end Find_Tag_Value;
-- ------------------------------
-- Find the tag value associated with the given tag definition.
-- Returns the tag value if it was found, otherwise returns the default
-- ------------------------------
function Find_Tag_Value (Node : in Model_Element;
Definition : in Tag_Definition_Element_Access;
Default : in String := "") return String is
Pos : Model_Cursor := Node.Tagged_Values.First;
Tag : Model_Element_Access;
begin
while Model_Vectors.Has_Element (Pos) loop
Tag := Model_Vectors.Element (Pos);
if Tag.all in Tagged_Value_Element'Class and then
Tagged_Value_Element'Class (Tag.all).Tag_Def = Definition
then
return To_String (Tagged_Value_Element'Class (Tag.all).Value);
end if;
Model_Vectors.Next (Pos);
end loop;
return Default;
end Find_Tag_Value;
-- ------------------------------
-- Get the documentation and comment associated with the model element.
-- Returns the empty string if there is no comment.
-- ------------------------------
function Get_Comment (Node : in Model_Element) return String is
procedure Collect_Comment (Id : in UString;
Item : in Model_Element_Access);
Doc : constant Tagged_Value_Element_Access := Node.Find_Tag_Value (TAG_DOCUMENTATION);
Result : UString;
procedure Collect_Comment (Id : in UString;
Item : in Model_Element_Access) is
pragma Unreferenced (Id);
Comment : constant Comment_Element_Access := Comment_Element'Class (Item.all)'Access;
begin
if Comment.Ref_Id = Node.XMI_Id then
Append (Result, Comment.Text);
end if;
end Collect_Comment;
begin
Iterate (Node.Model.all, XMI_COMMENT, Collect_Comment'Access);
if Doc /= null then
Append (Result, Doc.Value);
end if;
return To_String (Result);
end Get_Comment;
-- ------------------------------
-- Get the full qualified name for the element.
-- ------------------------------
function Get_Qualified_Name (Node : in Model_Element) return String is
begin
if Node.Parent /= null then
return Node.Parent.Get_Qualified_Name & "." & To_String (Node.Name);
else
return To_String (Node.Name);
end if;
end Get_Qualified_Name;
-- ------------------------------
-- Get the element type.
-- ------------------------------
overriding
function Get_Type (Node : in Ref_Type_Element) return Element_Type is
begin
if Node.Ref /= null then
return Node.Ref.Get_Type;
else
return XMI_UNKNOWN;
end if;
end Get_Type;
-- ------------------------------
-- Reconcile the element by resolving the references to other elements in the model.
-- ------------------------------
overriding
procedure Reconcile (Node : in out Ref_Type_Element;
Model : in UML_Model) is
Item : constant Model_Element_Access := Find (Model, Node.Model.all, Node.Ref_Id);
begin
if Item /= null then
Node.Set_Name (Item.Name);
Node.Ref := Item;
Node.XMI_Id := Item.XMI_Id;
end if;
Model_Element (Node).Reconcile (Model);
end Reconcile;
-- ------------------------------
-- Set the reference id and collect in the profiles set the UML profiles that must
-- be loaded to get the reference.
-- ------------------------------
procedure Set_Reference_Id (Node : in out Ref_Type_Element;
Ref : in String;
Profiles : in out Util.Strings.Sets.Set) is
Pos : constant Natural := Util.Strings.Index (Ref, '#');
begin
Node.Ref_Id := To_UString (Ref);
if Pos > 0 then
declare
First : constant Natural := Util.Strings.Rindex (Ref, '/', Pos);
begin
Profiles.Include (Ref (First + 1 .. Pos - 1));
end;
end if;
end Set_Reference_Id;
-- ------------------------------
-- Get the element type.
-- ------------------------------
overriding
function Get_Type (Node : in Data_Type_Element) return Element_Type is
pragma Unreferenced (Node);
begin
return XMI_DATA_TYPE;
end Get_Type;
-- ------------------------------
-- Get the element type.
-- ------------------------------
overriding
function Get_Type (Node : in Enum_Element) return Element_Type is
pragma Unreferenced (Node);
begin
return XMI_ENUMERATION;
end Get_Type;
-- ------------------------------
-- Validate the node definition as much as we can before the reconcile phase.
-- An enum must not be empty, it must have at least one literal.
-- If an error is detected, return a message. Returns an empty string if everything is ok.
-- ------------------------------
overriding
function Get_Error_Message (Node : in Enum_Element) return String is
Result : UString;
begin
Append (Result, Model_Element (Node).Get_Error_Message);
if Node.Elements.Is_Empty then
Append_Message (Result, "the enum '" & To_String (Node.Name) & "' is empty.");
end if;
return To_String (Result);
end Get_Error_Message;
-- ------------------------------
-- Create an enum literal and add it to the enum.
-- ------------------------------
procedure Add_Literal (Node : in out Enum_Element;
Id : in UBO.Object;
Name : in UBO.Object;
Literal : out Literal_Element_Access) is
begin
Literal := new Literal_Element (Node.Model);
Literal.XMI_Id := UBO.To_Unbounded_String (Id);
Literal.Set_Name (UBO.To_Unbounded_String (Name));
Node.Elements.Append (Literal.all'Access);
end Add_Literal;
-- ------------------------------
-- Get the element type.
-- ------------------------------
overriding
function Get_Type (Node : in Literal_Element) return Element_Type is
pragma Unreferenced (Node);
begin
return XMI_ENUMERATION_LITERAL;
end Get_Type;
-- ------------------------------
-- Get the element type.
-- ------------------------------
overriding
function Get_Type (Node : in Stereotype_Element) return Element_Type is
pragma Unreferenced (Node);
begin
return XMI_STEREOTYPE;
end Get_Type;
-- ------------------------------
-- Returns True if the model element has the stereotype with the given name.
-- ------------------------------
function Has_Stereotype (Node : in Model_Element'Class;
Stereotype : in Stereotype_Element_Access) return Boolean is
Iter : Model_Cursor := Node.Stereotypes.First;
begin
if Stereotype = null then
return False;
end if;
while Model_Vectors.Has_Element (Iter) loop
declare
S : constant Model_Element_Access := Model_Vectors.Element (Iter);
begin
if S = Stereotype.all'Access then
return True;
end if;
if S.XMI_Id = Stereotype.XMI_Id then
return True;
end if;
end;
Model_Vectors.Next (Iter);
end loop;
return False;
end Has_Stereotype;
-- ------------------------------
-- Get the element type.
-- ------------------------------
overriding
function Get_Type (Node : in Comment_Element) return Element_Type is
pragma Unreferenced (Node);
begin
return XMI_COMMENT;
end Get_Type;
-- ------------------------------
-- Get the element type.
-- ------------------------------
overriding
function Get_Type (Node : in Operation_Element) return Element_Type is
pragma Unreferenced (Node);
begin
return XMI_OPERATION;
end Get_Type;
-- ------------------------------
-- Get the element type.
-- ------------------------------
overriding
function Get_Type (Node : in Attribute_Element) return Element_Type is
pragma Unreferenced (Node);
begin
return XMI_ATTRIBUTE;
end Get_Type;
-- ------------------------------
-- Reconcile the element by resolving the references to other elements in the model.
-- ------------------------------
overriding
procedure Reconcile (Node : in out Attribute_Element;
Model : in UML_Model) is
Item : Model_Element_Access;
begin
if Length (Node.Ref_Id) = 0 then
return;
end if;
Item := Find (Model, Node.Model.all, Node.Ref_Id);
Model_Element (Node).Reconcile (Model);
if Item = null then
return;
end if;
if not (Item.all in Data_Type_Element'Class) then
Log.Error ("Invalid data type {0}", To_String (Node.Ref_Id));
return;
end if;
Node.Data_Type := Data_Type_Element'Class (Item.all)'Access;
end Reconcile;
-- ------------------------------
-- Get the element type.
-- ------------------------------
overriding
function Get_Type (Node : in Parameter_Element) return Element_Type is
pragma Unreferenced (Node);
begin
return XMI_PARAMETER;
end Get_Type;
-- ------------------------------
-- Get the element type.
-- ------------------------------
overriding
function Get_Type (Node : in Association_End_Element) return Element_Type is
pragma Unreferenced (Node);
begin
return XMI_ASSOCIATION_END;
end Get_Type;
-- ------------------------------
-- Get the documentation and comment associated with the model element.
-- Integrates the comment from the association itself as well as this association end.
-- Returns the empty string if there is no comment.
-- ------------------------------
overriding
function Get_Comment (Node : in Association_End_Element) return String is
Comment : constant String := Model_Element (Node).Get_Comment;
Association_Comment : constant String := Node.Parent.Get_Comment;
begin
if Association_Comment'Length = 0 then
return Comment;
elsif Comment'Length = 0 then
return Association_Comment;
else
return Association_Comment & ASCII.LF & Comment;
end if;
end Get_Comment;
-- ------------------------------
-- Reconcile the element by resolving the references to other elements in the model.
-- ------------------------------
overriding
procedure Reconcile (Node : in out Association_End_Element;
Model : in UML_Model) is
begin
Model_Element (Node).Reconcile (Model);
end Reconcile;
-- ------------------------------
-- Make the association between the two ends.
-- ------------------------------
procedure Make_Association (From : in out Association_End_Element;
To : in out Association_End_Element'Class;
Model : in UML_Model) is
Target : Model_Element_Access;
Source : Model_Element_Access;
begin
Log.Info ("Reconcile association {0} - {1}",
To_String (From.Name), To_String (To.Name));
Target := Find (Model, From.Model.all, To.Ref_Id);
if Target = null then
Log.Error ("Association end {0} not found", To_String (From.Name));
return;
end if;
Source := Find (Model, From.Model.all, From.Ref_Id);
if Source = null then
Log.Error ("Association end {0} not found", To_String (To.Name));
return;
end if;
if From.Navigable then
Class_Element'Class (Target.all).Associations.Append (From'Unchecked_Access);
From.Target_Element := Target.all'Access;
From.Source_Element := Source.all'Access;
Log.Info ("Class {0} { {1}: {2} }",
To_String (Target.Name),
To_String (From.Name),
To_String (Source.Name));
if Length (From.Name) = 0 then
Log.Error ("Class {0}: missing association end name to class {1}",
To_String (Target.Name), To_String (Source.Name));
end if;
end if;
end Make_Association;
-- ------------------------------
-- Get the element type.
-- ------------------------------
overriding
function Get_Type (Node : in Association_Element) return Element_Type is
pragma Unreferenced (Node);
begin
return XMI_ASSOCIATION;
end Get_Type;
-- ------------------------------
-- Validate the node definition as much as we can before the reconcile phase.
-- An association must contain two ends and a name is necessary on the navigable ends.
-- If an error is detected, return a message. Returns an empty string if everything is ok.
-- ------------------------------
overriding
function Get_Error_Message (Node : in Association_Element) return String is
use type Ada.Containers.Count_Type;
Result : UString;
begin
Append (Result, Model_Element (Node).Get_Error_Message);
if Length (Node.Name) = 0 then
Append_Message (Result, "Association has an empty name.");
end if;
if Node.Connections.Length = 2 then
declare
First, Second : Association_End_Element_Access;
begin
First := Association_End_Element'Class (Node.Connections.Element (1).all)'Access;
Second := Association_End_Element'Class (Node.Connections.Element (2).all)'Access;
if First.Navigable and then Length (First.Name) = 0 then
Append_Message (Result, "Association '" & To_String (Node.Name) &
"' has a navigable association end with an empty name.");
end if;
if Second.Navigable and then Length (Second.Name) = 0 then
Append_Message (Result, "Association '" & To_String (Node.Name) &
"' has a navigable association end with an empty name.");
end if;
if not First.Navigable and then not Second.Navigable then
Append_Message (Result, "Association '" & To_String (Node.Name) &
"' has no navigable association ends.");
end if;
end;
elsif Node.Connections.Length /= 0 then
Append_Message (Result, "Association '" & To_String (Node.Name)
& "' needs 2 association ends");
end if;
return To_String (Result);
end Get_Error_Message;
-- ------------------------------
-- Reconcile the association between classes in the package. Find the association
-- ends and add the necessary links to the corresponding class elements.
-- ------------------------------
overriding
procedure Reconcile (Node : in out Association_Element;
Model : in UML_Model) is
use type Ada.Containers.Count_Type;
begin
Model_Element (Node).Reconcile (Model);
if Node.Connections.Length >= 2 then
declare
First, Second : Association_End_Element_Access;
begin
First := Association_End_Element'Class (Node.Connections.Element (1).all)'Access;
Second := Association_End_Element'Class (Node.Connections.Element (2).all)'Access;
First.Make_Association (Second.all, Model);
Second.Make_Association (First.all, Model);
end;
elsif Node.Connections.Length > 0 then
Log.Info ("Association {0} needs 2 association ends", To_String (Node.Name));
end if;
end Reconcile;
-- ------------------------------
-- Get the element type.
-- ------------------------------
overriding
function Get_Type (Node : in Generalization_Element) return Element_Type is
pragma Unreferenced (Node);
begin
return XMI_GENERALIZATION;
end Get_Type;
-- ------------------------------
-- Reconcile the association between classes in the package. Find the association
-- ends and add the necessary links to the corresponding class elements.
-- ------------------------------
overriding
procedure Reconcile (Node : in out Generalization_Element;
Model : in UML_Model) is
begin
Ref_Type_Element (Node).Reconcile (Model);
Node.Child_Class := Find (Model, Node.Model.all, Node.Child_Id);
if Node.Child_Class /= null then
if Node.Child_Class.all in Class_Element'Class then
Class_Element'Class (Node.Child_Class.all).Parent_Class := Node'Unchecked_Access;
elsif Node.Child_Class.all in Data_Type_Element'Class then
Data_Type_Element'Class (Node.Child_Class.all).Parent_Type := Node'Unchecked_Access;
end if;
end if;
end Reconcile;
-- ------------------------------
-- Get the element type.
-- ------------------------------
overriding
function Get_Type (Node : in Tagged_Value_Element) return Element_Type is
pragma Unreferenced (Node);
begin
return XMI_TAGGED_VALUE;
end Get_Type;
-- ------------------------------
-- Reconcile the element by resolving the references to other elements in the model.
-- ------------------------------
overriding
procedure Reconcile (Node : in out Tagged_Value_Element;
Model : in UML_Model) is
Item : constant Model_Element_Access := Find (Model, Node.Model.all, Node.Ref_Id);
begin
Model_Element (Node).Reconcile (Model);
if Item /= null then
Node.Set_Name (Item.Name);
if not (Item.all in Tag_Definition_Element'Class) then
Log.Error ("Element {0} is not a tag definition. Tag is {1}, reference is {2}",
To_String (Item.Name),
Ada.Tags.Expanded_Name (Item'Tag),
To_String (Node.Ref_Id));
else
Node.Tag_Def := Tag_Definition_Element'Class (Item.all)'Access;
end if;
end if;
end Reconcile;
-- ------------------------------
-- Get the element type.
-- ------------------------------
overriding
function Get_Type (Node : in Tag_Definition_Element) return Element_Type is
pragma Unreferenced (Node);
begin
return XMI_TAG_DEFINITION;
end Get_Type;
-- ------------------------------
-- Get the element type.
-- ------------------------------
overriding
function Get_Type (Node : in Class_Element) return Element_Type is
pragma Unreferenced (Node);
begin
return XMI_CLASS;
end Get_Type;
-- ------------------------------
-- Reconcile the element by resolving the references to other elements in the model.
-- ------------------------------
overriding
procedure Reconcile (Node : in out Class_Element;
Model : in UML_Model) is
begin
if Node.Parent_Class /= null then
Node.Parent_Class.Reconcile (Model);
end if;
Data_Type_Element (Node).Reconcile (Model);
end Reconcile;
-- ------------------------------
-- Get the element type.
-- ------------------------------
overriding
function Get_Type (Node : in Package_Element) return Element_Type is
pragma Unreferenced (Node);
begin
return XMI_PACKAGE;
end Get_Type;
end Gen.Model.XMI;
|