forked from newspeaklanguage/newspeak
-
Notifications
You must be signed in to change notification settings - Fork 0
/
MiscBrowsing.ns
1945 lines (1894 loc) · 57 KB
/
MiscBrowsing.ns
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
Newspeak3
'HopscotchIDE'
class MiscBrowsing usingPlatform: p ide: ide = (
(* Copyright 2008 Cadence Design Systems, Inc.
Copyright 2009-2011 Ryan Macnak and other contributors.
Copyright 2012 Cadence Design Systems, Inc.
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 *)
||
private Smalltalk = p squeak Smalltalk.
private Preferences = p squeak Preferences.
private SmalltalkImage = p squeak SmalltalkImage.
private Undeclared = p squeak Undeclared.
private Utilities = p squeak Utilities.
private HopscotchImages = p squeak HopscotchImages.
private PackageOrganizer = p squeak PackageOrganizer.
private MCPackage = p squeak MCPackage.
private MCWorkingCopy = p squeak MCWorkingCopy.
private MCWorkingCopyBrowser = p squeak MCWorkingCopyBrowser.
private PackageInfo = p squeak PackageInfo.
private SystemOrganization = p squeak SystemOrganization.
private FileDirectory = p squeak FileDirectory.
private MultiByteFileStream = p squeak MultiByteFileStream.
private TextConverter = p squeak TextConverter.
private PNGReadWriter = p squeak PNGReadWriter.
private SqueakSet = p squeak Set.
private NewspeakGlobalState = p squeak NewspeakGlobalState.
private VFSerializer = p victoryFuel Serializer.
private VFDeserializer = p victoryFuel Deserializer.
private VMMirror = p squeak VMMirror.
private Color = p graphics Color.
private ObjectMirror = p mirrors ObjectMirror.
private Time = p time Time.
private Subject = p hopscotch core Subject.
private Presenter = p hopscotch core Presenter.
private TextEditorFragment = p hopscotch fragments TextEditorFragment.
private TextDisplayFragment = p hopscotch fragments TextDisplayFragment.
private EditableLinePresenter = p hopscotch fragments EditableLinePresenter.
private List = p collections List.
private Map = p collections Map.
private Set = p collections Set.
private Gradient = p brazil plumbing Gradient.
private NewspeakObject = Object.
private ClassDeclarationBuilder = p mirrors ClassDeclarationBuilder.
private platform = p.
private ide = ide.
private systemScope = ide systemScope.
private workspaceManager = ide theWorkspaceManager.
private EditableDefinitionPresenter = ide tools EditableDefinitionPresenter.
private DefinitionListPresenter = ide tools DefinitionListPresenter.
private ProgrammingPresenter = ide tools ProgrammingPresenter.
private AssortedMethodsPresenter = ide browsing AssortedMethodsPresenter.
private AssortedMethodsSubject = ide browsing AssortedMethodsSubject.
private MethodSubject = ide browsing MethodSubject.
private SelectorPresenter = ide browsing SelectorPresenter.
private SelectorSubject = ide browsing SelectorSubject.
public (* BOGUS *) ClassCommentPresenter = ide tools ClassCommentPresenter.
private ClassNamePresenter = ide tools ClassNamePresenter.
private DefinitionTemplate = ide tools DefinitionTemplate.
private OneLineDefinitionTemplate = ide tools OneLineDefinitionTemplate.
private ClassActionsPresenter = ide browsingNS ClassActionsPresenter.
||#ACCESSBOGUS) (
public class BitOfWisdom = (|
public text
public image
public actionLabel
public actionBlock
|) (
) : (
public text: aString = (
^self new text: aString
)
public text: aString actionLabel: labelString actionBlock: aBlock = (
^self new
text: aString;
actionLabel: labelString;
actionBlock: aBlock
)
public text: aString image: aForm = (
^self new
text: aString;
image: aForm
)
)
class ClassCategoryPresenter onSubject: s = DefinitionListPresenter onSubject: s (
(* Displays a class category as a collection of lines identifying the classes in the category, expandable into full class presenters. *)
| categoryNamePresenter |) (
brightnessForN: n midpoint: gamma = (
(* Return the value of brightness to use for the number of elements n, with the constraints that the brightness for 0 is 1, the brightness for gamma is 0.5 and the brighness asymptotically approaches 0 as n increases. *)
^(gamma / (gamma + n)) asFloat
)
captionForClassSubject: aSubject = (
^row: {
ClassNamePresenter onSubject: aSubject.
maybeShowRunTestLinkFor: (Array with: aSubject).
filler.
(deferred: [subclassCountLabelFor: aSubject]) width: 25.
blank: 5.
(deferred: [methodCountLabelFor: aSubject]) width: 30.
}
)
contentPresenters = (
^(subject classSubjects) collect:
[:each |
expandableLineForClassSubject: each]
)
definition = (
^
column: {
minorHeadingBlock: (
row: {
[categoryNamePresenter:: EditableClassCategoryPresenter onSubject: subject.
categoryNamePresenter] value.
mediumBlank.
linkImage: HopscotchImages default editImage
action: [respondToRename].
largeBlank.
packageLink.
largeBlank.
(* addButtonWithAction: [addClassTemplate]. *)
deferred: [maybeShowRunTestLink].
filler.
expandButtonWithAction: [expandAll].
blank: 3.
collapseButtonWithAction: [collapseAll].
}
).
mediumBlank.
super definition.
mediumBlank.
}
)
expandableLineForClassSubject: aSubject = (
| toggle |
toggle::
collapsed: [captionForClassSubject: aSubject]
expanded: [aSubject presenter].
toggle onUserToggled: [toggle requestVisibility].
^toggle
)
maybeShowRunTestLink = (
^nothing
(* | subjects |
subjects:: subject classSubjectsUsingReflection: reflection.
^maybeShowRunTestLinkFor: subjects *)
)
maybeShowRunTestLinkFor: collectionOfSubjects = (
^nothing
(* | testCases |
testCases:: (collectionOfSubjects select: [:aSubject | aSubject isTestCase]).
testCases:: (testCases collect: [:aSubject | aSubject model]) asSet.
^testCases notEmpty
ifTrue:
[row: {
smallBlank.
(link: 'tests' action: [respondToRunTestsUsing: (testCases)]) tinyFont
}]
ifFalse: [nothing] *)
)
methodCountLabelFor: aSubject = (
| count brightness caption holder |
count:: aSubject methodCount.
brightness:: brightnessForN: count midpoint: 40.
caption:: (label: count printString) tinyFont.
caption color: ((brightness < 0.7)
ifTrue: [Color white]
ifFalse: [Color black]).
^(row: {filler. caption. blank: 5})
color: (patchColorWithHue: 170 value: brightness)
)
packageLink = (
^
(subject packageName
ifNil: [label: '(no package)']
ifNotNil:
[:packageName |
link: packageName action: [browsePackage: packageName]])
tinyFont
)
patchColorWithHue: hue value: brightness = (
^Color h: hue s: 1 - brightness v: brightness
)
respondToRename = (
categoryNamePresenter enterEditState
)
subclassCountLabelFor: aSubject = (
| count brightness caption holder |
count:: aSubject totalSubclassCount.
brightness:: brightnessForN: count midpoint: 20.
caption:: (label: count printString) tinyFont.
caption color: ((brightness < 0.8)
ifTrue: [Color white]
ifFalse: [Color black]).
^(row: {filler. caption. blank: 5})
color: (patchColorWithHue: 210 value: brightness)
)
) : (
)
public class ClassCategorySubject onModel: m = Subject onModel: m (
(* Represents a viewpoint of a class category as a collection of classes. The model is the category name. *)
) (
public = anotherSubject = (
^anotherSubject class == self class
and: [anotherSubject categoryName = categoryName]
)
public categoryName = (
^model asSymbol
)
public classSubjects = (
^retrieveClasses collect:
[:each |
flag: #BOGUS. (* calling onto the presenter may not be right *)
presenter subjectForClass: each]
)
public classTemplateText = (
^
'class ClassNameHere = (
|
slot1
slot2
|
) ()'
)
public colorizeClassSource: sourceText <String | Text> ^<Text> = (
^ide newspeakColorization NS3BrowserColorizer new
parseText: sourceText asString
fromClass: Object mixin
usingSelector: #classDeclaration
)
public createPresenter = (
^ClassCategoryPresenter onSubject: self
)
public hash = (
^model hash
)
public name = (
^model
)
public packageName ^<String | nil> = (
^(PackageInfo allPackages
detect: [:some | some includesSystemCategory: model]
ifNone: [^nil])
packageName
)
rename: newName ifSuccessful: successAction ifFailed: failAction = (
(SystemOrganization categories includes: newName)
ifTrue: [^failAction value: newName asString, ' already exist'].
(newName select: [:each | Character lf = each or: [Character cr = each]]) isEmpty not
ifTrue: [^failAction value: 'Cannot contain newlines.'].
SystemOrganization renameCategory: model toBe: newName.
model:: newName.
^successAction value
)
retrieveClasses = (
^((Smalltalk organization listAtCategoryNamed: model)
collect: [:each | Smalltalk at: each])
reject: [:each | each isNil]
)
public title = (
^model, ' category'
)
) : (
)
class DeletedClassPresenter onSubject: s = ProgrammingPresenter onSubject: s (
) (
definition = (
^
majorHeadingBlock:
(label: 'Class ', subject className, ' has been deleted. * sniff *')
)
) : (
)
public class DeletedClassSubject onModel: m = Subject onModel: m (
(* Represents a class that has been deleted from the system. The model is the name of the class. *)
) (
public className = (
^model
)
public createPresenter = (
^DeletedClassPresenter onSubject: self
)
public title = (
^className, ' (deleted class)'
)
) : (
)
class EditableClassCategoryPresenter onSubject: s = EditableLinePresenter onSubject: s (
(* Presents an editory for renaming a class category. *)
) (
browseClassCategory: categoryName <Symbol> = (
ide defaultPopularityRecord
rememberCategoryVisit: categoryName.
enterSubject: (ClassCategorySubject onModel: categoryName)
)
definitionText = (
^subject model asString
)
respondToAccept = (
(* A subclass must redefine this to do whatever is needed to be done with <editor text> to save its as the new state of the subject, and send #leaveEditState if the save was successful. *)
| newName |
newName:: editor text asString asSymbol.
subject rename: newName ifSuccessful: [leaveEditState] ifFailed: [:reason |]
)
viewerDefinition = (
^link: [subject title asText allBold]
action: [browseClassCategory: subject model]
)
) : (
)
class HomePresenter onSubject: s = ProgrammingPresenter onSubject: s (
| helpHolder |) (
aboutSystemDefinition = (
^(link: 'About this system' action: [respondToAboutSystem]) smallFont.
)
column1: definitions1 column2: definitions2 column3: definitions3 = (
^row: {
(column: definitions1) width: 0 elasticity: 1.
(column: definitions2) width: 0 elasticity: 1.
(column: definitions3) width: 0 elasticity: 1.
}
)
definition = (
^homePageDefinition
)
didYouKnow = (
| wisdom |
wisdom:: subject randomBitOfWisdom.
wisdom actionLabel notNil ifTrue:
[^textAndActionWisdom: wisdom].
wisdom image notNil ifTrue:
[^textAndImageWisdom: wisdom].
^TextDisplayFragment new text: wisdom text
)
helpButton = (
^helpText isNil
ifTrue: [nothing]
ifFalse: [(link: '[?]' action: [respondToHelp]) tinyFont]
)
helpText ^<String | nil> = (
(* If this method answers a string, a help button will appear on the Home page. Clicking on that button will display the string. *)
^'This is the home page. You can always return to the home page of a Newspeak browser by clicking on the home icon at the top of the browser.
The home page includes links to a variety of useful places, like recently visited classes and packages, the source control page and more.
If you look at the list of classes, you will see each class has a round icon next to it. The icon tells you which language the class is written in; the current system mixes Smalltalk and Newspeak code. So, for example, a gray icon represents Smalltalk. Golden icons represent Newspeak3, which is the currently operational dialect of Newspeak.'
)
homePageDefinition = (
helpHolder:: list.
^
column: {
helpHolder.
majorHeadingBlock: (
row: {
label: 'Navigation' asText allBold.
filler.
helpButton.
}
).
mediumBlank.
indentedBlock:
(column1: {
link: 'Newspeak Source' asText allBold
action: [enterSubject:: NamespaceSubject new].
link: 'Smalltalk Source' asText allBold
action: [browseSystem].
link: 'Repositories' asText allBold
action: [enterSubject: ide vcs ui mainSubject]
}
column2: {
link: 'Workspaces'
action: [navigateToWorkspaces].
link: 'Pasteboard'
action: [navigateToPasteboard].
}
column3: {
link: 'Under the Hood'
action: [navigateToInternals].
undeclaredDefinition.
}
).
mediumBlank.
majorHeadingBlock: (label: 'Recently Visited' asText allBold).
mediumBlank.
indentedBlock:
(holder: [recentStuffDefinition]).
largeBlank.
majorHeadingBlock: (label: 'Did you know?' asText allBold).
smallBlank.
indentedBlock:
(holder: [didYouKnow]).
mediumBlank.
indentedBlock: aboutSystemDefinition.
}
)
navigateToInternals = (
enterSubject:: InternalsSubject new
)
navigateToPasteboard = (
enterSubject:: PasteboardSubject new
)
navigateToWorkspaces = (
enterSubject:: ide theWorkspaceManager AllWorkspacesSubject new
)
public noticeExposure = (
(* Whenever the page is revisited we want the recent stuff and the 'did you know' sections updated. They are created in holders, so a simple refresh will do that. *)
refresh
)
recentStuffDefinition = (
^
column1: {
label: 'Packages' asText allBold.
mediumBlank.
column: (subject recentPackages collect:
[:each | link: each action: [browsePackage: each]]).
mediumBlank.
label: 'Categories' asText allBold.
mediumBlank.
column: (subject recentCategories collect:
[:each | linkToBrowseCategory: each]).
}
column2: {
label: 'Namespaces' asText allBold.
mediumBlank.
column: (subject recentNamespaces collect:
[:each | linkToBrowseNamespace: (ide namespacing categoryNamespace: each) key: each]).
}
column3: {
label: 'Classes' asText allBold.
mediumBlank.
list:
((subject recentClassesForPresenter: self) collect:
[:each |
(ClassNamePresenter onSubject: each)
highlightIfRecent: false]).
}
)
respondToAboutSystem = (
enterSubject: (SystemInformationSubject onModel: SmalltalkImage current)
)
respondToHelp = (
helpHolder setPresenters: {
row: {
filler.
(link: 'close help' action: [helpHolder setPresenters: {}]) tinyFont.
}.
textDisplay: helpText.
}
)
respondToUndeclared = (
enterSubject::
UndeclaredReferencesSubject on: systemScope allUsersOfUndeclared
)
textAndActionWisdom: wisdom = (
^
column: {
TextDisplayFragment new text: wisdom text.
(link: wisdom actionLabel action: wisdom actionBlock) tinyFont
}
)
textAndImageWisdom: wisdom = (
^
row: {
image: wisdom image.
mediumBlank.
elastic:
(TextDisplayFragment new text: wisdom text).
}
)
undeclaredDefinition = (
Undeclared isEmpty ifTrue: [^nothing].
^link: 'Unresolved references (', Undeclared size asString, ')' action: [respondToUndeclared]
)
) : (
)
public class HomeSubject onModel: m = Subject onModel: m () (
public = anotherSubject = (
(* As there is just one possible logical home of the system, all subjects representing it are considered equal. *)
^self class = anotherSubject class
)
bitsOfWisdom = (
(* This defines the bits of wisdom displayed at the bottom of the Hopscotch home page. Each time a page opens a new element is selected at random. An element may evaluate to nil, which will select another element at random. *)
^
{
[BitOfWisdom text: 'Holding down the Shift key and clicking a link opens the link target in a new window. This also works for menu items and navigation buttons.'].
[BitOfWisdom
text: 'Hold down the Shift key while clicking the "new window" toolbar button to open a copy of the current page instead of the default home page.'
image: HopscotchImages default hsNewImage].
[BitOfWisdom
text: 'The Refresh toolbar button rebuilds the current page from scratch. Use it if you suspect the current page got out of sync with the data it displays.'
image: HopscotchImages default hsRefreshImage].
[Undeclared size > 0
ifTrue:
[BitOfWisdom
text: 'There are ', Undeclared size printString, ' entries in the Undeclared dictionary right now.'
actionLabel: 'show them'
actionBlock: [Undeclared inspect]]
ifFalse: [nil]].
[BitOfWisdom
text: 'The following packages have unsaved modifications: ',
(String streamContents:
[:s |
(MCWorkingCopy registry select: [:each | each modified]) do:
[:each | s cr; nextPutAll: each package name]])].
[BitOfWisdom
text: 'This icon identifies a class whose language does not yet have a dedicated icon.'
image: HopscotchImages default classUnknownImage].
[BitOfWisdom
text: 'This is the "expand all" button which appears in headers of expandable item groups.'
image: HopscotchImages default hsExpandImage].
[BitOfWisdom
text: 'This is the "collapse all" button which appears in headers of expandable item groups.'
image: HopscotchImages default hsCollapseImage].
[BitOfWisdom
text: 'This is the "add" button which appears in headers of groups of items you can add to, such as methods of a class or classes of a package.'
image: HopscotchImages default hsAddImage].
[BitOfWisdom
text: 'This is the "reorder" button. It appears in lists of methods and switches the method sort order. The default is to group methods by category, the alternative is to sort them alphabetically by selector ignoring the category.'
image: HopscotchImages default hsReorderImage].
[BitOfWisdom
text: 'Recently visited classes are highlighted in yellow in category and package views to make them easier to notice.'].
[BitOfWisdom
text: 'This icon indicates that the method is overridden in one of the subclasses.'
image: HopscotchImages default itemSubOverride].
[BitOfWisdom
text: 'This icon indicates that the method overrides one defined in a superclass.'
image: HopscotchImages default itemSuperOverride].
[BitOfWisdom
text: 'This icon indicates that the method both overrides one defined in a superclass and is overridden in one of the subclasses.'
image: HopscotchImages default itemBothOverride].
[BitOfWisdom
text: 'You can search for multiple patterns simultaneously by separating the patterns with a semicolon. For example: "includes;contains".'].
[BitOfWisdom
text: 'By default, the search function finds anything that contains the search term. For example, a search for "foo" will find all of the following: "foo", "foos", "afoo" and "afoos". For a different match policy, include explicit wildcards. A * will match any number of any characters; a # will match any single character.'].
[BitOfWisdom
text: 'The colored bars on the right of class names in the category and package views are "heat maps" of the number of subclasses (blue) and the number of methods (green) of the classes. They make "important" and "big" classes easy to spot.'].
[BitOfWisdom
text: 'Expressions evaluated in debuggers and inspectors can access a workspace via the name _. This allows you to bypass modularity during development and access values you forgot to import, e.g. _ collections List.'].
[BitOfWisdom
text: 'War is peace. Freedom is slavery. Ignorance is strength.'].
},
ide languageUiDescriptionRegistry bitsOfWisdom
)
public createPresenter = (
^HomePresenter onSubject: self
)
lateNightWisdom = (
^BitOfWisdom
text: 'It''s ', Time now printString, '. Go get some rest!'
)
public randomBitOfWisdom = (
| bits |
Time now hour < 5 ifTrue: [^lateNightWisdom].
bits:: bitsOfWisdom.
^bits atRandom value ifNil: [randomBitOfWisdom]
)
public recentCategories = (
^ide defaultPopularityRecord categoryVisits asSortedList
)
public recentClassesForPresenter: presenter <Presenter> = (
^ide defaultPopularityRecord classVisits collect:
[:each |
presenter subjectForClass: each]
)
public recentNamespaces = (
^ide defaultPopularityRecord namespaceVisits asSortedList
)
public recentPackages = (
^ide defaultPopularityRecord packageVisits asSortedList
)
public title = (
^'Home'
)
) : (
public new = (
^onModel: nil
)
)
class InternalsPresenter onSubject: s = ProgrammingPresenter onSubject: s (
(* A presenter for queries such as browseAllSelect: *)
| queries |) (
definition = (
^column: {
majorHeadingBlock: headingDefinition.
mediumBlank.
inspect: platform yourself name: 'platform' initiallyExpanded: false.
inspect: ide yourself name: 'ide' initiallyExpanded: false.
inspect: ide vcs yourself name: 'memoryHole' initiallyExpanded: false.
inspect: ide settings yourself name: 'settings' initiallyExpanded: true.
mediumBlank.
holder: [installationStatus].
largeBlank.
queries:: list: {QuerySubject new presenter}.
button: 'Add Query' action: [respondToAddQuery] }
)
headingDefinition = (
^row: {
label: 'Under the Hood' asText allBold.
filler.
dropDownMenu: [menuWithLabelsAndActions: {
'Inspect Presenter' -> [respondToInspectPresenter].
}].
}
)
inspect: object name: name initiallyExpanded: initiallyExpanded = (
| toggle |
^toggle::
collapsed: [(link: name action: [toggle expand]) color: actionLinkColor]
expanded: [(objectSubjectFor: object) presenter selfCaption: name]
initiallyExpanded: initiallyExpanded
)
installationStatus = (
shell isDebugger & shell isInNamespace ifTrue:
[^column: {
textDisplay: 'This is an ordinary IDE instance. It is affected by changes to the IDE and platform code in the namespace and is the debugger of unhandled exceptions.'.
link: 'Open a supervisor IDE.' action: [respondToOpenSupervisorIDE]}].
shell isDebugger & shell isInNamespace not ifTrue:
[^column: {
textDisplay: 'This is the supervisor IDE instance. It IS NOT affected by changes to the IDE and platform code in the namespace and IS the debugger of unhandled exceptions.'.
link: 'Open a supervisee window.' action: [respondToOpenSuperviseeWindow]}].
shell isDebugger not & shell isInNamespace ifTrue:
[^column: {
textDisplay: 'This is a supervisee IDE instance. It IS affected by changes to the IDE and platform code in the namespace and IS NOT the debugger of unhandled exceptions.'.
link: 'Open a supervisor window.' action: [respondToOpenSupervisorWindow].
link: 'Takeover debugging (become ordinary IDE instance).' action: [respondToBecomeDebugger]}].
^column: {
textDisplay: 'This is an orphaned IDE instance. It IS NOT affected by changes to the IDE and platform code in the namespace and IS NOT the debugger of unhandled exceptions.'.
link: 'Open a supervisor/ordinary window.' action: [respondToOpenSupervisorWindow].
link: 'Takeover debugging (become ordinary IDE instance).' action: [respondToBecomeDebugger]
}
)
respondToAddQuery = (
queries add: QuerySubject new presenter
)
respondToBecomeDebugger = (
NewspeakGlobalState ide: ide.
refresh.
shell updateToolbar.
)
respondToOpenSuperviseeWindow = (
|
manifest = ide namespacing manifestForSqueak.
|
((manifest HopscotchIDEApp packageUsing: manifest)
main: platform args: {})
IDEWindow open.
refresh.
shell updateToolbar.
)
respondToOpenSupervisorIDE = (
subject openSupervisorIDE.
refresh.
shell updateToolbar.
)
respondToOpenSupervisorWindow = (
NewspeakGlobalState ide IDEWindow open.
refresh.
shell updateToolbar.
)
) : (
)
class InternalsSubject onModel: m = Subject onModel: m (
(* A subject for queries such as browseAllSelect: *)
) (
public = other = (
^self class = other class
)
public createPresenter = (^InternalsPresenter onSubject: self)
deepCopy: object = (
| globals stream serializer deserializer bytes |
globals:: platform squeak Smalltalk globals.
stream:: ByteArray new writeStream.
serializer:: VFSerializer over: stream withGlobals: globals.
serializer serialize: object.
serializer:: nil.
stream:: stream contents readStream.
deserializer:: VFDeserializer over: stream withGlobals: globals.
^deserializer deserialize
)
public hash = (
^self class hash
)
public openSupervisorIDE = (
|
manifest = ide namespacing manifestForSqueak.
HopscotchIDEApp = manifest HopscotchIDEApp.
RuntimeForSqueak = manifest RuntimeForSqueak.
runtime = (RuntimeForSqueak packageUsing: manifest).
ideapp = (HopscotchIDEApp packageUsing: manifest).
copy = deepCopy: {runtime. ideapp}.
runtimeCopy = copy at: 1.
ideappCopy = copy at: 2.
platformCopy = runtimeCopy using: VMMirror new.
ideCopy = ideappCopy main: platformCopy args: {}.
|
NewspeakGlobalState ide: ideCopy.
ideCopy IDEWindow open.
)
public title = (
^'Under the Hood'
)
) : (
public new = (
^self onModel: nil
)
)
class NamespacePresenter onSubject: s = DefinitionListPresenter onSubject: s (
) (
class ClassEntryPresenter onSubject: s = EntryPresenter onSubject: s (| nameLink |) (
collapsedDefinition = (
(* BOGUS: we are displaying the class's name. we should display its key *)
| part |
part:: row1: {
image: subject classUiDescription classIcon.
smallBlank.
nameLink:: row: {link: [subject className] action: [browseClassMirror: subject classMirror]}.
} row2: {
(row: {deferred: [(label: subject classCommentText withBlanksTrimmed)
smallFont;
color: secondaryTextColor]})
compressibility: 1.
filler
compressibility: 0.
(* In the face of namespace nesting, should application and test configuration be invoked with the root namespace or the local namespace? If the local namespace, these links only make sense in the context of the namespace view and should not be part of the class presenter itself. *)
ClassActionsPresenter onSubject: subject.
mediumBlank.
dropDownMenu: [entryActionsMenuFor: subject className].
}.
(* subject isRecentlyVisited ifTrue: [part color: recentlyVisitedColor]. *)
^part
)
expandedDefinition = (
^subject presenter
)
public noticeExposure = (
nameLink visual color:
(subject isRecentlyVisited ifTrue: [recentlyVisitedColor] ifFalse: [Color transparent]).
^super noticeExposure
)
) : (
)
class EntryPresenter onSubject: s = ProgrammingPresenter onSubject: s () (
public collapse = (
substance collapse
)
definition = (
^collapsed: [collapsedDefinition] expanded: [expandedDefinition]
)
public expand = (
substance expand
)
) : (
)
class NamespaceEntryPresenter onSubject: s = EntryPresenter onSubject: s (| nameLink |) (
collapsedDefinition = (
^row1: {
defaultBlank.
image: HopscotchImages default classPresenterImage.
defaultBlank.
nameLink:: row: {link: subject key action: [
ide defaultPopularityRecord
rememberNamespaceVisit: subject key. (* Should be the namespace itself, but non-strings break the home page. *)
enterSubject:: subject refreshmentSubject]}.
} row2: {
(label: subject summaryText)
smallFont;
compressibility: 1;
color: secondaryTextColor.
filler
compressibility: 0.
mediumBlank.
dropDownMenu: [entryActionsMenuFor: subject key]
}.
)
expandedDefinition = (
^subject presenter
)
public noticeExposure = (
nameLink visual color:
(subject isRecentlyVisited ifTrue: [recentlyVisitedColor] ifFalse: [Color transparent]).
^super noticeExposure
)
) : (
)
class ValueEntryPresenter onSubject: s = EntryPresenter onSubject: s (|
public key
|) (
collapsedDefinition = (
^row1: {
image: HopscotchImages default classUnknownImage.
smallBlank.
link: key action: [enterPresenter:: subject createPresenter selfCaption: key].
} row2: {
(label: subject title)
smallFont;
compressibility: 1;
color: secondaryTextColor.
filler
compressibility: 0.
mediumBlank.
dropDownMenu: [entryActionsMenuFor: key]
}
)
definition = (
(* Should provide someway to edit the value. Possibly like the slots experiment with the inspectors. Evaluate in the context of a workspace. *)
^collapsed: [collapsedDefinition]
expanded: [subject presenter selfCaption: key]
)
expandedDefinition = (
(* Should provide someway to edit the value. Possibly like the slots experiment with the inspectors. Evaluate in the context of a workspace. *)
^subject presenter selfCaption: key
)
) : (
)
acceptNewClassDefinitionFrom: aTemplate = (
subject
addClassFromDefinition: aTemplate text
ifSuccess:
[prefixes remove: aTemplate. refresh]
ifFailure:
[:msg | aTemplate editor showMessage: msg]
)
acceptNewNamespaceDefinitionFrom: aTemplate = (
subject
addNamespaceFromDefinition: aTemplate text
ifSuccess:
[prefixes remove: aTemplate. refresh]
ifFailure:
[:msg | aTemplate editor showMessage: msg]
)
addClassTemplate = (
prefixes add:
(DefinitionTemplate new
caption: 'Defining a new class:';
initialText: subject classTemplateText;
colorizerBlock: [:text | subject colorizeClassSource: text];
acceptResponse:
[:template | acceptNewClassDefinitionFrom: template];
cancelResponse:
[:template | prefixes remove: template])
)
addNamespaceTemplate = (
prefixes add:
(DefinitionTemplate new
caption: 'Defining a new namespace:';
initialText: 'NewNamespace';
colorizerBlock: [:text | ];
acceptResponse:
[:template | acceptNewNamespaceDefinitionFrom: template];
cancelResponse:
[:template | prefixes remove: template])
)
contentList = (
^zebra: super contentList
)
contentPresenters = (
^subject namespace keys asSortedList collect: [:key | presenterForEntryAt: key]
)
definition = (
^column: {
minorHeadingBlock: (row: {
label: subject key asText allBold.
largeBlank.
subject namespace isCategoryNamespace
ifTrue: [addButtonWithAction: [respondToAddForCategory]]
ifFalse: [addButtonWithAction: [respondToAddForRoot]].
filler.
expandButtonWithAction: [expandAll].
blank: 3.
collapseButtonWithAction: [collapseAll].
blank: 3.
dropDownMenu: [namespaceMenu].
}).
smallBlank.
super definition.
}
)
entryActionsMenuFor: key = (
^menuWithLabelsAndActions: {
'Remove ', key -> [ide namespacing removeKey: key. refresh].
}
)
public icon = (
^HopscotchImages default classPresenterImage
)
namespaceMenu = (
^menuWithLabelsAndActions: {
'Inspect Presenter' -> [respondToInspectPresenter].
}
)
presenterForEntryAt: key = (
| entry = subject namespace at: key. |
entry isBehavior
ifTrue: [^ClassEntryPresenter onSubject: (subjectForClass: entry)].
([entry isNamespace] ifError: [false])
ifTrue: [^NamespaceEntryPresenter onSubject: (NamespaceSubject onModel: entry key: key)].
^(ValueEntryPresenter onSubject: (objectSubjectFor: entry)) key: key
)
respondToAddForCategory = (
openMenuWithLabelsAndActions: {
'Add Class' -> [addClassTemplate].
(* 'Add Namespace' -> [addNamespaceTemplate]. *)
'Add Image From File' -> [respondToAddImage].
'Add Text From File' -> [respondToAddText].
(* 'Add Value' -> [Error signal: 'Unimplemented']. *)
}
)
respondToAddForRoot = (
openMenuWithLabelsAndActions: {
'Add Namespace' -> [addNamespaceTemplate].
}
)
respondToAddImage = (
| fileRequester |
fileRequester:: request File new.
fileRequester allowedFileTypes: {'Image files (*.png)' ->'*.png'}.
fileRequester initialDirectory: (FileDirectory default fullName).
fileRequester openModal ifNotNil: [:fn |
| key form |
key:: (FileDirectory on: fn) localName allButLast: 4.
key:: key select: [:letter | letter isAlphaNumeric].
form:: PNGReadWriter formFromFileNamed: fn.
subject namespace at: key asSymbol put: form.
].
)
respondToAddText = (
| fileRequester |
fileRequester:: request File new.
fileRequester allowedFileTypes: {'Text files (*.txt)' ->'*.txt'}.
fileRequester initialDirectory: (FileDirectory default fullName).
fileRequester openModal ifNotNil: [:fn |
| key text |
key:: (FileDirectory on: fn) localName allButLast: 4.
key:: key select: [:letter | letter isAlphaNumeric].
text:: ((MultiByteFileStream oldFileNamed: fn)
converter: (TextConverter newForEncoding: 'utf8')) contents.
subject namespace at: key asSymbol put: text.
].
)
row1: row1 row2: row2 = (
^row: {
(row: row1) width: 0 elasticity: 1.
(row: {mediumBlank}, row2) width: 0 elasticity: 2.
}
)
) : (
)
public class NamespaceSubject onModel: m key: k = Subject onModel: m (|
public key = k.
|ide namespacing refreshCategoryNamespaces) (
public = other ^<Boolean> = (
^class = other class
and: [namespace = other namespace]
and: [key = other key].
)
public addClassFromDefinition: definitionString ifSuccess: successBlock ifFailure: failureBlock = (
| builder mixin klass |
[builder:: ClassDeclarationBuilder fromSource: definitionString]
on: Error
do: [:ex | ^failureBlock value: ex description].
(namespace includesKey: builder name) ifTrue:
[^failureBlock value: 'A class named ', builder simpleName, ' already exists in this namespace'].
mixin:: builder install reflectee.
klass:: mixin apply: Object withName: builder name.
klass mixin category: #Unclassified.
namespace at: klass name put: klass.
successBlock value