-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathxdkpm.oz
1680 lines (1555 loc) · 54.6 KB
/
xdkpm.oz
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
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
%% Copyright 2001-2008
%% by Ralph Debusmann <[email protected]> (Saarland University) and
%% Denys Duchier <[email protected]> (LIFO, Orleans) and
%% Jorge Marques Pelizzoni <[email protected]> (ICMC, Sao Paulo) and
%% Jochen Setz <[email protected]> (Saarland University)
%%
functor
import
Application(exit getArgs)
Browser(browse)
Inspector(configure inspect)
Module(link)
OS(getDir mkDir pipe)
Property(put)
System(show showError)
Tk(addYScrollbar batch button entry frame label listbox return
scrollbar toplevel variable)
TkTools(dialog menubar)
Path at 'x-oz://system/os/Path.ozf'
String1 at 'x-oz://system/String.ozf'
Regex at 'x-oz://contrib/regex'
Helpers at 'Helpers.ozf'
prepare
ListDrop = List.drop
ListIsPrefix = List.isPrefix
ListLast = List.last
ListTake = List.take
ListTakeDropWhile = List.takeDropWhile
ListToTuple = List.toTuple
%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
A2S = Atom.toString
V2S = VirtualString.toString
V2A = VirtualString.toAtom
S2I = String.toInt
S2A = String.toAtom
define
%% Plan:
%%
%% Create mappings:
%% principle ID
%% -> Definition file name
%% Need helper mapping Definition file name -> principle ID, create
%% by scanning all principles in Solver/Principles/Source/*.ul
%% -> Definition functor name
%% Need helper mapping Definition functor name -> principle ID, create
%% by scanning all principles in Solver/Principles/*.oz
%% -> Constraint functors name
%%
%% Resolve either locally (add path prefix Solver/Principles) or globally
%%
%% Find out paths to relevant files given the principle ID
%% a) scan Solver/Principles/Source/*.ul files for those with the
%% principle ID
%% -> Definition File
%% b) scan Solver/Principles/*.oz files for those with the
%% principle ID
%% -> Definition Functor
%% c) constraint functors given in principle definition "constraints":
%% -> Constraint Functors
%% d) other control files:
%% -> Solver/Principles/Principles.oz
%% -> Solver/Principles/principles.xml
%% -> Solver/Principles/makefile.oz
%% -> Solver/Principles/Lib/makefile.oz
%% -> Solver/Principles/Source/makefile.oz
%% Add principle:
%% Select either Definition file or Definition functor
%% Definition file: read principle ID, ID -> principle file name,
%% Must be in Solver/Principles/Source/*.ul
%% Add Definition file to
%% Solver/Principles/Source/makefile.oz
%% Compile Definition file
%% Call pw.exe in PrincipleWriter/
%% Definition functor to
%% Solver/Principles/<principle file name.oz>
%% Constraint functor to
%% Solver/Principles/Lib/<principle file name.oz>
%% Definition functor: read principle ID
%% Add Definition functor to Solver/Principles/Principles.oz
%% Add principle ID to Solver/Principles/principles.xml
%% Add Definition functor to Solver/Principles/makefile.oz
%% Compile Definition functor
%% Call oz -c <Definition functor name> in Solver/Principles/
%% Compile Solver/Principles/Principles.oz
%% Call oz -c Principles.oz in Solver/Principles/
%% Link Definition functor
%% Read Constraint functors from Definition functor
%% Add Constraint functors to Solver/Principles/Lib/makefile.oz
%% Compile Constraint functors
%% For each Constraint functor,
%% call oz -c <Constraint functor name> in Solver/Principles/Lib
%%
%% Delete principle:
%% Remove Definition functor from Solver/Principles/Principles.oz
%% Remove principle ID from Solver/Principles/principles.xml
%% Remove Definition functor from Solver/Principles/makefile.oz
%% Remove Constraint functors from Solver/Principles/Lib/makefile.oz
%% Remove Definition file from Solver/Principles/Source/makefile.oz
%% Move Definition functor to Solver/Principles/Trash/
%% Remove compiled Definition functor
%% Move Constraint functors to Solver/Principles/Trash/Lib
%% Remove compiled Constraint functors
%% Move Definition file to Solver/Principles/Trash/Source
%%
%% Recover principle:
%% Select either Definition file or Definition functor
%% Definition file:
%% Move Definition file from Trash to Solver/Principles/Source
%% Go to Add principle
%% Definition functor:
%% Compile Definition functor
%% Move Definition functor to Solver/Principles
%% Call oz -c <Definition functor> in Solver/Principles/
%% Link Definition functor
%% Read Constraint functors from Definition functor
%% Move Constraint functors from Trash to Solver/Principles/Lib
%% Go to Add principle
%%
%% Rename principle (not directly supported, can be done using delete/add)
%% Definition file:
%% Write new definition file with the new name.
%% Delete old principle.
%% Add new principle.
%% Definition functor:
%% Write new Definition functor with the new name,
%% perhaps also let it point to Constraint functors with a new name
%% Delete old principle.
%% Add new principle.
%%
%% Rebuild principle:
%% If the option is checked and if a Definition file exists,
%% recompile Definition file
%% Call pw.exe in Solver/Principles/Source
%% Definition functor to
%% Solver/Principles/<principle file name.oz>
%% Constraint functor to
%% Solver/Principles/Lib/<principle file name.oz>
%% Compile Definition functor
%% Link Definition functor
%% Read Constraint functors from Definition functor
%% Compile Constraint functors
%% Update Solver/Principles/Lib/makefile.oz if the Constraint
%% functors have changed.
%%
%% Rebuild all principles:
%% do Rebuild principle for all principles in the list.
%%
%% PrincipleWriter principle definition file
%% (auch in Solver/Principles)
%% -> principle definition 'functor' -> compiled,
%% -> principle constraint 'functor'(s) -> compiled
%%
%% andere Files:
%% makefile.oz,
%% Solver/Principles/Principles.oz -> compiled,
%% Solver/Principles/makefile.oz, (nicht bei Aenderung)
%% Solver/Principles/principles.xml, (nicht bei Aenderung)
%% Solver/Principles/Lib/makefile.oz
%%
%% Build
%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
{Helpers.addHandlers}
{Inspector.configure widgetTreeFont font(family:courier size:10 weight:normal)}
{Inspector.configure widgetShowStrings true}
{Property.put 'errors.depth' 10000}
{Property.put 'errors.width' 10000}
{Property.put 'print.depth' 10000}
{Property.put 'print.width' 10000}
%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
proc {ShowInLogDebug V}
DebugB = {DebugTkvar tkReturnInt($)}==1
in
if DebugB then {ShowInLog V} end
end
proc {ShowInLog V}
ShowLogA = {LogTkvar tkReturnAtom($)}
A = {V2A V}
in
case ShowLogA
of inspector then {Inspector.inspect A}
[] browser then {Browser.browse A}
[] shell then {System.show A}
end
end
proc {BeginLog V}
{ShowInLog '------------------------------------------------------------'}
{ShowInLog V#'...'}
{ShowInLog '------------------------------------------------------------'}
end
proc {EndLog V}
{ShowInLog '------------------------------------------------------------'}
{ShowInLog V#' done.'}
{ShowInLog '------------------------------------------------------------'}
end
proc {ShowBuildResultsInLog DefFilePathV BuildDefFileB DefFunctorPathV BuildDefFunctorB ConstraintPathVs BuildConstraintBs BuildPrinciplesB}
{ShowInLog 'Build summary'}
%%
if {Not DefFilePathV==""} then
{ShowInLog ' Definition file (Principle Writer)'}
{ShowInLog ' '#DefFilePathV}
{ShowInLog ' '#if BuildDefFileB then 'Ok' else 'Failed' end}
end
%%
{ShowInLog ' Definition functor'}
{ShowInLog ' '#DefFunctorPathV}
{ShowInLog ' '#if BuildDefFunctorB then 'Ok' else 'Failed' end}
%%
{ShowInLog ' Constraint functors'}
for ConstraintPathV in ConstraintPathVs I in 1..{Length ConstraintPathVs} do
{ShowInLog ' '#ConstraintPathV}
BuildConstraintB = {Nth BuildConstraintBs I}
in
{ShowInLog ' '#if BuildConstraintB then 'Ok' else 'Failed' end}
end
%%
{ShowInLog ' Control file "Principles.oz"'}
{ShowInLog ' '#'"Solver/Principles/Principles.oz"'}
{ShowInLog ' '#if BuildPrinciplesB then 'Ok' else 'Failed' end}
%%
{ShowInLog 'Build '#
if BuildDefFileB andthen
BuildDefFunctorB andthen
{All BuildConstraintBs fun {$ B} B end} andthen
BuildPrinciplesB then
'successful'
else
'failed'
end}
end
proc {HandleException E}
DebugB = {DebugTkvar tkReturnInt($)}==1
V = {Helpers.e2V E}
if DebugB orelse V=='unhandled error' then {Inspector.inspect E} end
in
{Helpers.tkError 'XDK: Principle Manager: Error' V}
end
%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
GlobalDict = {Dictionary.new}
GlobalDict.ozEditor := unit
GlobalDict.ulEditor := unit
GlobalDict.xmlEditor := unit
GlobalDict.principleDefs := unit
proc {SetPrincipleDefs}
[PrinciplesFunctor] =
{Module.link ['Solver/Principles/Principles.ozf']}
in
GlobalDict.principleDefs := PrinciplesFunctor.principles
end
fun {GetPrincipleDefs}
if GlobalDict.principleDefs==unit then
{SetPrincipleDefs}
end
GlobalDict.principleDefs
end
%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
fun {SplitLines Ss BeginPrefixS EndPrefixS IndentS EditProc}
Ss1
Ss2
{ListTakeDropWhile
Ss
fun {$ S} {Not {ListIsPrefix BeginPrefixS S}} end
Ss1
Ss2}
Ss11 = {Append Ss1 {ListTake Ss2 1}}
Ss21 = {ListDrop Ss2 1}
Ss3
Ss4
{ListTakeDropWhile
Ss21
fun {$ S} {Not {ListIsPrefix EndPrefixS S}} end
Ss3
Ss4}
Ss31 =
{Map Ss3
fun {$ S} {String1.lstrip S unit} end}
%%
Ss32 = {EditProc Ss31}
%%
Ss33 = {Map Ss32
fun {$ S} {Append IndentS S} end}
in
Ss11#Ss33#Ss4
end
fun {EditLines Ss BeginPrefixS EndPrefixS IndentS EditProc}
Ss1#Ss2#Ss3 = {SplitLines Ss BeginPrefixS EndPrefixS IndentS EditProc}
in
{Append Ss1 {Append Ss2 Ss3}}
end
fun {MakeAddLinesProc LineVs}
LineSs = {Map LineVs V2S}
fun {EditProc Ss}
Ss1 = {Append LineSs Ss}
Ss2 = {Helpers.noDoubles Ss1}
Ss3 = {Sort Ss2
fun {$ S1 S2}
A1 = {S2A S1}
A2 = {S2A S2}
in
A1 < A2
end}
in
Ss3
end
in
EditProc
end
fun {MakeRemoveLinesProc LineVs}
LineSs = {Map LineVs V2S}
fun {EditProc Ss}
Ss1 =
{Filter Ss
fun {$ S}
{All LineSs
fun {$ LineS}
{Not {ListIsPrefix LineS S}}
end}
end}
in
Ss1
end
in
EditProc
end
%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
fun {CompileDefFile DefFileS DefFunctorS ConstraintS}
Ss
in
try
_
WriteSocketI
in
{OS.pipe "PrincipleWriter/pw"
["-p" DefFileS
"-e" DefFunctorS
"-c" ConstraintS] _ _#WriteSocketI}
Ss = {Helpers.readFromSocket WriteSocketI}
catch E then
{HandleException E}
end
Ss
end
fun {CompileOz FileS}
Ss
in
try
WriteSocketI
in
{OS.pipe "ozc"
["-c" FileS "-o" FileS#"f" "-v"] _ _#WriteSocketI}
Ss = {Helpers.readFromSocket WriteSocketI}
catch E then
{HandleException E}
end
Ss
end
%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
fun {GetFileNames DirS ExcludeFileNameSs ExtensionS SubS}
FileNameSs = {OS.getDir DirS}
ExcludeFileNameSs1 = {Append ExcludeFileNameSs ["." ".."]}
SubS1 = {Append &'|SubS "'"}
SubS2 = {Append &"|SubS "\""}
FileNameSs1 = {Filter FileNameSs
fun {$ FileNameS}
{Not {Member FileNameS ExcludeFileNameSs1}} andthen
{Path.extension FileNameS}==ExtensionS andthen
local
FileContentS = {Helpers.getS DirS#"/"#FileNameS}
in
{Helpers.isSubstring SubS1 FileContentS} orelse
{Helpers.isSubstring SubS2 FileContentS}
end
end}
in
FileNameSs1
end
fun {GetPrincipleIDs UrlV}
S = {Helpers.getS UrlV}
RE = {Regex.make "principle\\.[A-Za-z0-9]*"}
MATCHES = {Regex.allMatches RE S}
BS = {ByteString.make S}
Ss =
{Map MATCHES
fun {$ MATCH}
BS1 = {ByteString.slice BS MATCH.0.1 MATCH.0.2}
S1 = {ByteString.toString BS1}
in
S1
end}
in
Ss
end
fun {GetPrinciples FilterV}
PrincipleDefs = {GetPrincipleDefs}
PrincipleAs = {Map PrincipleDefs
fun {$ PrincipleDef} PrincipleDef.id.data end}
RE = {Regex.make FilterV}
PrincipleAs1 = {Filter PrincipleAs
fun {$ PrincipleA}
PrincipleS = {A2S PrincipleA}
MATCH = {Regex.search RE PrincipleS}
in
{Not MATCH==false}
end}
in
PrincipleAs1
end
%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
proc {AddToPrinciples IDSuffixS}
{ShowInLogDebug 'Adding "'#IDSuffixS#"(principle)"#'" to "'#"Solver/Principles/Principles.oz"}
Ss = {Helpers.getLines "Solver/Principles/Principles.oz"}
EditProc1 = {MakeAddLinesProc [IDSuffixS#"(principle)"]}
Ss1 = {EditLines Ss "% begin list 1" "% end list 1" " " EditProc1}
%%
{ShowInLogDebug 'Adding "'#IDSuffixS#".principle"#'" to "'#"Solver/Principles/Principles.oz"}
EditProc2 = {MakeAddLinesProc [IDSuffixS#".principle"]}
Ss2 = {EditLines Ss1 "% begin list 2" "% end list 2" " " EditProc2}
in
{Helpers.putLines Ss2 "Solver/Principles/Principles.oz"}
end
proc {RemoveFromPrinciples IDSuffixS}
{ShowInLogDebug 'Removing "'#IDSuffixS#"(principle)"#'" from "'#"Solver/Principles/Principles.oz"}
Ss = {Helpers.getLines "Solver/Principles/Principles.oz"}
EditProc1 = {MakeRemoveLinesProc [IDSuffixS#"(principle)"]}
Ss1 = {EditLines Ss "% begin list 1" "% end list 1" " " EditProc1}
%%
{ShowInLogDebug 'Removing "'#IDSuffixS#".principle"#'" from "'#"Solver/Principles/Principles.oz"}
EditProc2 = {MakeRemoveLinesProc [IDSuffixS#".principle"]}
Ss2 = {EditLines Ss1 "% begin list 2" "% end list 2" " " EditProc2}
in
{Helpers.putLines Ss2 "Solver/Principles/Principles.oz"}
end
proc {AddToPrinciplesMakefile IDSuffixS}
{ShowInLogDebug 'Adding "\''#IDSuffixS#".ozf\'"#'" to "'#"Solver/Principles/makefile.oz"}
Ss = {Helpers.getLines "Solver/Principles/makefile.oz"}
EditProc1 = {MakeAddLinesProc ["'"#IDSuffixS#".ozf'"]}
Ss1 = {EditLines Ss "% begin list 1" "% end list 1" "\t " EditProc1}
in
{Helpers.putLines Ss1 "Solver/Principles/makefile.oz"}
end
proc {RemoveFromPrinciplesMakefile IDSuffixS}
{ShowInLogDebug 'Removing "\''#IDSuffixS#".ozf\'"#'" from "'#"Solver/Principles/makefile.oz"}
Ss = {Helpers.getLines "Solver/Principles/makefile.oz"}
EditProc1 = {MakeRemoveLinesProc ["'"#IDSuffixS#".ozf'"]}
Ss1 = {EditLines Ss "% begin list 1" "% end list 1" "\t " EditProc1}
in
{Helpers.putLines Ss1 "Solver/Principles/makefile.oz"}
end
proc {AddToLibMakefile ConstraintFileVs}
for ConstraintFileV in ConstraintFileVs do
{ShowInLogDebug 'Adding "\''#ConstraintFileV#".ozf\'"#'" to "'#"Solver/Principles/Lib/makefile.oz"}
end
Ss = {Helpers.getLines "Solver/Principles/Lib/makefile.oz"}
EditProc1 = {MakeAddLinesProc
{Map ConstraintFileVs
fun {$ ConstraintFileV} "'"#ConstraintFileV#".ozf'" end}}
Ss1 = {EditLines Ss "% begin list 1" "% end list 1" "\t " EditProc1}
in
{Helpers.putLines Ss1 "Solver/Principles/Lib/makefile.oz"}
end
proc {RemoveFromLibMakefile ConstraintFileVs}
for ConstraintFileV in ConstraintFileVs do
{ShowInLogDebug 'Removing "\''#ConstraintFileV#".ozf\'"#'" from "'#"Solver/Principles/Lib/makefile.oz"}
end
Ss = {Helpers.getLines "Solver/Principles/Lib/makefile.oz"}
EditProc1 = {MakeRemoveLinesProc
{Map ConstraintFileVs
fun {$ ConstraintFileV} "'"#ConstraintFileV#".ozf'" end}}
Ss1 = {EditLines Ss "% begin list 1" "% end list 1" "\t " EditProc1}
in
{Helpers.putLines Ss1 "Solver/Principles/Lib/makefile.oz"}
end
proc {AddToSourceMakefile IDSuffixS}
{ShowInLogDebug 'Adding "\''#IDSuffixS#".ul\'"#'" to "'#"Solver/Principles/Source/makefile.oz"}
Ss = {Helpers.getLines "Solver/Principles/Source/makefile.oz"}
EditProc1 = {MakeAddLinesProc ["'"#IDSuffixS#".ul'"]}
Ss1 = {EditLines Ss "% begin list 1" "% end list 1" "\t " EditProc1}
in
{Helpers.putLines Ss1 "Solver/Principles/Source/makefile.oz"}
end
proc {RemoveFromSourceMakefile IDSuffixS}
{ShowInLogDebug 'Removing "\''#IDSuffixS#".ul\'"#'" from "'#"Solver/Principles/Source/makefile.oz"}
Ss = {Helpers.getLines "Solver/Principles/Source/makefile.oz"}
EditProc1 = {MakeRemoveLinesProc ["'"#IDSuffixS#".ul'"]}
Ss1 = {EditLines Ss "% begin list 1" "% end list 1" "\t " EditProc1}
in
{Helpers.putLines Ss1 "Solver/Principles/Source/makefile.oz"}
end
proc {AddToPrinciplesXML IDSuffixS}
{ShowInLogDebug 'Adding "<principleDef id="principle.'#IDSuffixS#'/>" to "'#"Solver/Principles/principles.xml"}
Ss = {Helpers.getLines "Solver/Principles/principles.xml"}
EditProc1 = {MakeAddLinesProc ["<principleDef id=\"principle."#IDSuffixS#"\"/>"]}
Ss1 = {EditLines Ss "<!-- begin list 1" "<!-- end list 1" "" EditProc1}
in
{Helpers.putLines Ss1 "Solver/Principles/principles.xml"}
end
proc {RemoveFromPrinciplesXML IDSuffixS}
{ShowInLogDebug 'Removing "<principleDef id="principle.'#IDSuffixS#'/>" from "'#"Solver/Principles/principles.xml"}
Ss = {Helpers.getLines "Solver/Principles/principles.xml"}
EditProc1 = {MakeRemoveLinesProc ["<principleDef id=\"principle."#IDSuffixS#"\"/>"]}
Ss1 = {EditLines Ss "<!-- begin list 1" "<!-- end list 1" "" EditProc1}
in
{Helpers.putLines Ss1 "Solver/Principles/principles.xml"}
end
%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
proc {CopyDefFile SourcePathS IDS IDSuffixS}
SuffixS = {Helpers.getSuffix SourcePathS}
DestPathV =
case SuffixS
of "ul" then "Solver/Principles/Source/"#IDSuffixS#".ul"
[] "oz" then "Solver/Principles/"#IDSuffixS#".oz"
else
raise error1('functor':'xdkpm.ozf' 'proc':'CopyDefFile' msg:'Expected either suffix "ul" (principle definition file) or "oz" (principle definition functor) but got: "'#SuffixS#'".' info:o(IDS IDSuffixS SuffixS) coord:noCoord file:noFile) end
end
DestPathS = {V2S DestPathV}
%%
IDAs = {GetPrinciples ""}
IDA = {S2A IDS}
if {Member IDA IDAs} then
raise error1('functor':'xdkpm.ozf' 'proc':'CopyDefFile' msg:'Principle ID already exists: "'#IDA#'".' info:o(IDS IDSuffixS SuffixS SourcePathS DestPathS IDA IDAs) coord:noCoord file:noFile) end
end
FileFunctorA =
case SuffixS
of "ul" then 'principle definition file'
[] "oz" then 'principle definition functor'
end
in
if SourcePathS==DestPathS then
{ShowInLog FileFunctorA#' "'#SourcePathS#'" is already in the appropriate directory.'}
else
if {Helpers.fileExists DestPathS} then
OverwriteB = {Helpers.tkDialog2 'XDK: Principle Manager' FileFunctorA#' "'#DestPathS#'" already exists. Are you sure to overwrite it with '#FileFunctorA#' "'#SourcePathS#'"?'}
in
if {Not OverwriteB} then
raise error1('functor':'xdkpm.ozf' 'proc':'CopyDefFile' msg:'Add principle canceled.' info:o(IDS IDSuffixS SuffixS SourcePathS DestPathS IDA IDAs) coord:noCoord file:noFile) end
end
end
{ShowInLog 'Copying '#FileFunctorA#' from "'#SourcePathS#'" to "'#DestPathS#'".'}
{Helpers.dup SourcePathS DestPathS}
end
end
proc {CopyConstraints DefFunctorDirS ConstraintFileVs}
for ConstraintFileV in ConstraintFileVs continue:Continue do
SourcePathV = DefFunctorDirS#"/Lib/"#ConstraintFileV#".oz"
DestPathV = "Solver/Principles/Lib/"#ConstraintFileV#".oz"
in
if {Not {Helpers.fileExists SourcePathV}} then
{ShowInLog 'Constraint functor "'#SourcePathV#'" not found. Continuing.'}
{Continue}
end
if {Helpers.fileExists DestPathV} then
OverwriteB = {Helpers.tkDialog2 'XDK: Principle Manager' 'Constraint functor "'#DestPathV#'" already exists. Are you sure to overwrite it with "'#SourcePathV#'"?'}
in
if {Not OverwriteB} then
{ShowInLog 'Constraint functor "'#SourcePathV#'" not copied. Continuing.'}
{Continue}
end
end
{ShowInLog 'Copying constraint functor from "'#SourcePathV#'" to "'#DestPathV#'".'}
{Helpers.dup SourcePathV DestPathV}
end
end
%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
fun {BuildDefFile DefFilePathV DefFunctorPathV ConstraintPathV}
{ShowInLog 'Compiling principle definition file '#DefFilePathV}
DefFileOutputSs =
{CompileDefFile
DefFilePathV
DefFunctorPathV
ConstraintPathV}
in
for S in DefFileOutputSs do
{ShowInLog " "#S}
end
if DefFileOutputSs==nil then
false
else
{ListIsPrefix "Saved constraint functor in " {ListLast DefFileOutputSs}}
end
end
fun {BuildDefFunctor DefFunctorPathV}
{ShowInLog {V2A 'Compiling principle definition functor '#DefFunctorPathV}}
DefFunctorOutputSs = {CompileOz DefFunctorPathV}
in
for S in DefFunctorOutputSs do
{ShowInLog " "#S}
end
if DefFunctorOutputSs==nil then
false
else
{ListLast DefFunctorOutputSs}=="% -------------------- accepted"
end
end
fun {BuildConstraints ConstraintPathVs}
BuildConstraintBs =
for ConstraintPathV in ConstraintPathVs collect:Collect do
{ShowInLog 'Compiling principle constraint functor '#ConstraintPathV}
ConstraintOutputSs = {CompileOz ConstraintPathV}
in
for S in ConstraintOutputSs do
{ShowInLog " "#S}
end
if ConstraintOutputSs==nil then
{Collect false}
else
{Collect {ListLast ConstraintOutputSs}=="% -------------------- accepted"}
end
end
in
BuildConstraintBs
end
fun {BuildPrinciples}
{ShowInLog 'Compiling control file Solver/Principles/Principles.oz'}
PrinciplesOutputSs = {CompileOz "Solver/Principles/Principles.oz"}
in
for S in PrinciplesOutputSs do
{ShowInLog " "#S}
end
GlobalDict.principleDefs := unit
if PrinciplesOutputSs==nil then
false
else
{ListLast PrinciplesOutputSs}=="% -------------------- accepted"
end
end
%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
proc {HighlightPrinciple IDS}
SizeS = {ListW tkReturn(size $)}
in
if {Not SizeS=="0"} then
SizeI = {S2I SizeS}
in
for IndexI in 0..SizeI-1 break:Break do
IDS1 = {ListW tkReturn(get(IndexI) $)}
in
if IDS1==IDS then
CurIndexS = {ListW tkReturn(curselection $)}
in
if {Not CurIndexS==nil} then {ListW tk(selection clear CurIndexS)} end
{ListW tk(selection set IndexI)}
{ListW tk(see IndexI)}
{Break}
end
end
end
end
proc {SetPrinciples PrincipleAs}
PrincipleARec = {ListToTuple o PrincipleAs}
SizeI = {ListW tkReturnInt(size $)}
in
{ListW tk(delete 0 SizeI-1)}
if {Not PrincipleAs == nil} then
{ListW tk(insert 'end' PrincipleARec)}
end
{ListRemoveButtonW tk(configure state:disabled)}
end
%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
proc {About}
{Helpers.tkDialogImage 'XDK: About' 'XDG Development Kit: Principle Manager\n\nCopyright 2008\n\nby Ralph Debusmann <[email protected]>' 'xdk.gif'}
end
proc {Quit}
Status=0
end
%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
proc {AddPrinciple}
try
PathS =
{Tk.return tk_getOpenFile(title: 'XDK: Principle Manager: Add...'
filetypes: q(q('Principle definition file/functor' '*.ul')
q('Principle definition file/functor' '*.oz')
q('All files' '*')))}
if PathS=="" then
raise error1('functor':'xdkpm.ozf' 'proc':'AddPrinciple' msg:'No principle definition file/functor selected.' info:o(PathS) coord:noCoord file:noFile) end
end
%%
{BeginLog 'Add principle'}
%%
IDSs = {GetPrincipleIDs PathS}
if IDSs==nil then
raise error1('functor':'xdkpm.ozf' 'proc':'AddPrinciple' msg:'Principle definition file/definition functor does not contain a principle ID.' info:o(PathS) coord:noCoord file:noFile) end
end
IDS = IDSs.1
IDSuffixS = {Helpers.getSuffix IDS}
IDSuffixCh|IDSuffixS1 = IDSuffixS
IDSuffixS2 = {Char.toUpper IDSuffixCh}|IDSuffixS1
%%
SuffixS = {Helpers.getSuffix PathS}
%% Copy principle definition file/functor
{CopyDefFile PathS IDS IDSuffixS2}
%% Build principle definition file
DefFilePathV#BuildDefFileB =
case SuffixS
of "ul" then
{AddToSourceMakefile IDSuffixS2}
DefFilePathV = "Solver/Principles/Source/"#IDSuffixS2#".ul"
DefFunctorPathV = "Solver/Principles/"#IDSuffixS2#".oz"
ConstraintPathV = "Solver/Principles/Lib/"#IDSuffixS2#".oz"
BuildDefFileB = {BuildDefFile DefFilePathV DefFunctorPathV ConstraintPathV}
in
DefFilePathV#BuildDefFileB
[] "oz" then
""#true
end
%% Build principle definition functor
DefFunctorPathV = "Solver/Principles/"#IDSuffixS2#".oz"
BuildDefFunctorB = {BuildDefFunctor DefFunctorPathV}
%% Build principles
{AddToPrinciples IDSuffixS2}
{AddToPrinciplesMakefile IDSuffixS2}
{AddToPrinciplesXML IDSuffixS}
BuildPrinciplesB = {BuildPrinciples}
%% Build constraint functors
ConstraintFileVs =
case SuffixS
of "ul" then
[IDSuffixS2]
[] "oz" then
[DefFunctor] = {Module.link [DefFunctorPathV#"f"]}
ConstraintILs = DefFunctor.principle.constraints
ConstraintAs = {Map ConstraintILs
fun {$ ConstraintIL} ConstraintIL.1.data end}
DirS = {Path.dirname PathS}
{CopyConstraints DirS ConstraintAs}
in
ConstraintAs
end
%%
{AddToLibMakefile ConstraintFileVs}
ConstraintPathVs = {Map ConstraintFileVs
fun {$ ConstraintFileV}
"Solver/Principles/Lib/"#ConstraintFileV#".oz"
end}
BuildConstraintBs = {BuildConstraints ConstraintPathVs}
in
{ShowBuildResultsInLog
DefFilePathV BuildDefFileB
DefFunctorPathV BuildDefFunctorB
ConstraintPathVs BuildConstraintBs
BuildPrinciplesB}
%%
{FilterPrinciples}
{HighlightPrinciple IDS}
{SetPrinciple}
catch E then
{HandleException E}
end
{EndLog 'Add principle'}
end
proc {RemovePrinciple}
{BeginLog 'Remove principle'}
%%
IndexS = {ListW tkReturn(curselection $)}
IDS = {ListW tkReturn(get(IndexS) $)}
IDSuffixS = {Helpers.getSuffix IDS}
IDSuffixCh|IDSuffixS1 = IDSuffixS
IDSuffixS2 = {Char.toUpper IDSuffixCh}|IDSuffixS1
%%
IDA = {S2A IDS}
%%
DefFilePathV = IDADefFilePathVDict.IDA
%%
{RemoveFromPrinciplesXML IDSuffixS}
{RemoveFromPrinciples IDSuffixS2}
{RemoveFromPrinciplesMakefile IDSuffixS2}
if {Not DefFilePathV==""} then
{RemoveFromSourceMakefile IDSuffixS2}
end
%%
if {Not {Helpers.fileExists "Solver/Principles/Trash"}} then
{OS.mkDir "Solver/Principles/Trash" ['S_IWUSR' 'S_IRUSR' 'S_IRGRP' 'S_IROTH']}
end
if {Not {Helpers.fileExists "Solver/Principles/Trash/Source"}} then
{OS.mkDir "Solver/Principles/Trash/Source" ['S_IWUSR' 'S_IRUSR' 'S_IRGRP' 'S_IROTH']}
end
if {Not {Helpers.fileExists "Solver/Principles/Trash/Lib"}} then
{OS.mkDir "Solver/Principles/Trash/Lib" ['S_IWUSR' 'S_IRUSR' 'S_IRGRP' 'S_IROTH']}
end
%%
if DefFilePathV=="" then
{ShowInLog 'Moving "Solver/Principles/'#IDSuffixS2#'.oz" to "Solver/Principles/Trash/'#IDSuffixS2#'.oz".'}
{Helpers.mv "Solver/Principles/"#IDSuffixS2#".oz" "Solver/Principles/Trash/"#IDSuffixS2#".oz"}
else
{ShowInLog 'Moving "Solver/Principles/Source/'#IDSuffixS2#'.ul" to "Solver/Principles/Trash/Source"'#IDSuffixS2#'.ul".'}
{Helpers.mv "Solver/Principles/Source/"#IDSuffixS2#".ul" "Solver/Principles/Trash/Source/"#IDSuffixS2#".ul"}
end
%%
BuildPrinciplesB = {BuildPrinciples}
in
{ShowInLog 'Build summary'}
{ShowInLog ' Control file "Principles.oz"'}
{ShowInLog ' '#'"Solver/Principles/Principles.oz"'}
{ShowInLog ' '#if BuildPrinciplesB then 'Ok' else 'Failed' end}
{ShowInLog 'Build '#if BuildPrinciplesB then 'successful' else 'failed' end}
%%
{FilterPrinciples}
%%
{EndLog 'Remove principle'}
end
fun {PathS2FilterV PathS}
IDSs = {GetPrincipleIDs PathS}
if IDSs==nil then
raise error1('functor':'xdkpm.ozf' 'proc':'ImportFilterFromGrammar' msg:'Selected file does not contain a principle ID.' info:o(PathS) coord:noCoord file:noFile) end
end
{ShowInLogDebug 'File "'#PathS#'" contains the following principle IDs:'}
for IDS in IDSs do
{ShowInLogDebug ' '#IDS}
end
IDS1|IDSs1 = IDSs
FilterV = IDS1#"$"#{FoldL IDSs1
fun {$ AccV IDS}
AccV#"|"#IDS#"$"
end ""}
in
FilterV
end
proc {ImportFilterFromGrammar}
try
PathS =
{Tk.return tk_getOpenFile(title: 'XDK: Principle Manager: Import filter from grammar...'
filetypes: q(q('Grammar files' '*.ul')
q('Grammar files' '*.xml')
q('All files' '*')))}
if PathS=="" then
raise error1('functor':'xdkpm.ozf' 'proc':'ImportFilterFromGrammar' msg:'No file selected.' info:o(PathS) coord:noCoord file:noFile) end
end
%%
{BeginLog 'Import filter from grammar'}
%%
FilterV = {PathS2FilterV PathS}
in
{FilterEntryW tk(delete 0 'end')}
{FilterEntryW tk(insert 'end' FilterV)}
{FilterPrinciples}
catch E then
{HandleException E}
end
{EndLog 'Import filter from grammar'}
end
proc {RemoveUnusedConstraintFunctors}
{BeginLog 'Remove unused constraint functors'}
PrincipleDefs = {GetPrincipleDefs}
AllUsedConstraintFileAs =
for PrincipleDef in PrincipleDefs append:Append do
UsedConstraintAs = {Map PrincipleDef.constraints
fun {$ ConstraintsIL}
ConstraintsIL.1.data
end}
in
{Append UsedConstraintAs}
end
AllUsedConstraintFileAs1 = {Helpers.noDoubles AllUsedConstraintFileAs}
%%
Ss = {Helpers.getLines "Solver/Principles/Lib/makefile.oz"}
EditProc1 = fun {$ Ss}
{Map Ss
fun {$ S}
S1 = {String1.strip S "'"}
in
{Helpers.removeSuffix S1 &.}
end}
end
_#Ss1#_ = {SplitLines Ss "% begin list 1" "% end list 1" "" EditProc1}
AllConstraintFileAs = {Map Ss1 S2A}
AllUnusedConstraintFileAs =
{Filter AllConstraintFileAs
fun {$ ConstraintFileA}
{Not {Member ConstraintFileA AllUsedConstraintFileAs1}}
end}
%%
{RemoveFromLibMakefile AllUnusedConstraintFileAs}
in
if AllUnusedConstraintFileAs==nil then
{ShowInLog 'No unused constraint functors found.'}
else
for ConstraintFileA in AllUnusedConstraintFileAs do
{ShowInLog 'Moving "Solver/Principles/Lib'#ConstraintFileA#'.oz" to "Solver/Principles/Trash/Lib/'#ConstraintFileA#'.oz".'}
{Helpers.mv "Solver/Principles/Lib/"#ConstraintFileA#".oz" "Solver/Principles/Trash/Lib/"#ConstraintFileA#".oz"}
end
end
{EndLog 'Remove unused constraint functors'}
end
proc {EditConstraint}
FileNameS =
{ConstraintsEntryW tkReturnString(get $)}
in
{EditOz FileNameS}
end
proc {EditOtherFile}
FileNameS =
{OtherFilesEntryW tkReturnString(get $)}
SuffixS = {Helpers.getSuffix FileNameS}
in
case SuffixS
of "oz" then {EditOz FileNameS}
[] "xml" then {EditXML FileNameS}
end
end
proc {FilterPrinciples}
FilterS = {FilterEntryW tkReturnString(get $)}
PrincipleAs = {GetPrinciples FilterS}
in
{SetPrinciples PrincipleAs}
{ClearDefFile}
{ClearDefFunctor}
{ClearConstraints}
{ClearOtherFiles}
{BuildButtonW tk(configure state:disabled)}
end
fun {BuildPrinciple}
{BeginLog 'Build principle'}
%%
SizeS = {ListW tkReturn(size $)}
BuildPrincipleB =
if SizeS=="0" then
{EndLog 'Build principle'}
%%
true
else
IndexS = {ListW tkReturn(curselection $)}
IDS = {ListW tkReturn(get(IndexS) $)}
IDA = {S2A IDS}
BuildDefFileB = {BuildDefFileTkvar tkReturnInt($)} == 1
DefFilePathV = if BuildDefFileB then IDADefFilePathVDict.IDA else "" end
DefFunctorPathV = IDADefFunctorPathVDict.IDA
ConstraintPathVs = IDAConstraintPathVsDict.IDA
BuildDefFileB1 =
if {V2S DefFilePathV}=="" then
true
else
{BuildDefFile DefFilePathV DefFunctorPathV ConstraintPathVs.1}
end
BuildDefFunctorB = {BuildDefFunctor DefFunctorPathV}
BuildConstraintBs = {BuildConstraints ConstraintPathVs}
BuildPrinciplesB = {BuildPrinciples}
{ShowBuildResultsInLog
DefFilePathV BuildDefFileB1
DefFunctorPathV BuildDefFunctorB