diff --git a/src/BlocHost-Morphic/BlBlocUIManager.class.st b/src/BlocHost-Morphic/BlBlocUIManager.class.st deleted file mode 100644 index 10a387a4e..000000000 --- a/src/BlocHost-Morphic/BlBlocUIManager.class.st +++ /dev/null @@ -1,575 +0,0 @@ -" -I provide a solution for handling the opening of the debugger that supports both the Bloc UI and the Morphic UI processes. - -I assume there is only one UI Process either in Bloc or Morphic. If the error happened in either one of these processes, I restart the correct one. If both Bloc and Morphic have two distinct UI processes I will not work correctly. - -Normally I should only be used when running Bloc natively. When running Bloc using inside the Morphic UI process the a `MorphicUIManager` can be used instead. -However for now I can also be used to handle just the case of the Morhic UI process. Later I should be simplified to take into account only the Bloc UI process. - -" -Class { - #name : #BlBlocUIManager, - #superclass : #MorphicUIManager, - #category : #'BlocHost-Morphic-Support' -} - -{ #category : #'class initialization' } -BlBlocUIManager class >> handledId [ - ^ self name -] - -{ #category : #'class initialization' } -BlBlocUIManager class >> initialize [ - "has to be executed at the end of the user category" - SessionManager default - register: self - inCategory: SessionManager default userCategory - atPriority: SmallInteger maxVal + 1 -] - -{ #category : #testing } -BlBlocUIManager class >> isValidForCurrentSystemConfiguration [ - | isHeadlessVM isInteractiveMode | - - SystemVersion current major <= 9 - ifFalse: [ ^ false ]. - - isHeadlessVM := Smalltalk os windowSystemName isNil or: [ Smalltalk os windowSystemName = 'null' ]. - - "The --interactive parameter should be passed in order to select a graphical UI manager. - This parameter is passe automatically when double clicking on the Headless VM." - isInteractiveMode := CommandLineArguments new hasOption: 'interactive'. - - ^ isHeadlessVM and: [ isInteractiveMode ] -] - -{ #category : #'class initialization' } -BlBlocUIManager class >> shutdown: isImageQuitting [ - "Prepare the shutdown and the next startup" - - UIManager default: StartupUIManager new - -] - -{ #category : #'class initialization' } -BlBlocUIManager class >> startup: isImageStarting [ - "Install the right UIManager" - - UIManager default: (self isValidForCurrentSystemConfiguration - ifTrue: [ self new ] - ifFalse: [ UIManager forCurrentSystemConfiguration ]) -] - -{ #category : #actions } -BlBlocUIManager class >> useAsDefault [ - |uiManager| - uiManager := self new. - uiManager beDefault. -] - -{ #category : #services } -BlBlocUIManager >> abort: aStringOrText title: aString [ - ^ BlBlocUIManagerNotification - request: #abort:title: - with: - {aStringOrText. - aString} - default: [ true ] -] - -{ #category : #services } -BlBlocUIManager >> alert: aStringOrText title: aString configure: aBlock [ - ^ BlBlocUIManagerNotification - request: #alert:title:configure: - with: - {aStringOrText. - aString. - aBlock} - default: [ true ] -] - -{ #category : #services } -BlBlocUIManager >> centeredAlert: aStringOrText title: aString configure: aBlock [ - ^ BlBlocUIManagerNotification - request: #centeredAlert:title:configure: - with: - {aStringOrText. - aString. - aBlock} - default: [ true ] -] - -{ #category : #services } -BlBlocUIManager >> chooseColor: aColor [ - ^ self chooseColor: aColor title: 'Colour Selector' translated -] - -{ #category : #services } -BlBlocUIManager >> chooseColor: aColor title: title [ - ^ BlBlocUIManagerNotification - requestOrNil: #chooseColor:title: - with: - {aColor. - title} -] - -{ #category : #'ui requests' } -BlBlocUIManager >> chooseDirectory: label from: dir [ - ^ BlBlocUIManagerNotification - requestOrNil: #chooseDirectory:from: - with: - {label. - dir} -] - -{ #category : #services } -BlBlocUIManager >> chooseDirectory: title path: path [ - ^ BlBlocUIManagerNotification - requestOrNil: #chooseDirectory:path: - with: - {title. - path} -] - -{ #category : #services } -BlBlocUIManager >> chooseDropList: aStringOrText title: aString list: aList [ - ^ BlBlocUIManagerNotification - requestOrNil: #chooseDropList:title:list: - with: - {aStringOrText. - aString. - aList} -] - -{ #category : #services } -BlBlocUIManager >> chooseExistingFileReference: title extensions: exts path: path preview: preview [ - ^ BlBlocUIManagerNotification - requestOrNil: #chooseExistingFileReference:extensions:path:preview: - with: - {title. - exts. - path. - preview} -] - -{ #category : #services } -BlBlocUIManager >> chooseFont: aFont [ - ^ BlBlocUIManagerNotification - requestOrNil: #chooseFont: - with: {aFont} -] - -{ #category : #services } -BlBlocUIManager >> chooseForSaveFileReference: title extensions: exts path: path preview: preview [ - ^ BlBlocUIManagerNotification - requestOrNil: #chooseForSaveFileReference:extensions:path:preview: - with: - {title. - exts. - path. - preview} -] - -{ #category : #services } -BlBlocUIManager >> chooseFrom: labelList values: valueList lines: linesArray message: messageString title: aString [ - ^ BlBlocUIManagerNotification - request: #chooseFrom:values:lines:message:title: - with: - {labelList. - valueList. - linesArray. - messageString. - aString} - default: [ 0 ] -] - -{ #category : #'ui requests' } -BlBlocUIManager >> chooseFrom: labelList values: valueList lines: linesArray title: aString [ - ^ BlBlocUIManagerNotification - request: #chooseFrom:values:lines:title: - with: - {labelList. - valueList. - linesArray. - aString} - default: [ 0 ] -] - -{ #category : #services } -BlBlocUIManager >> chooseFullFileName: title extensions: exts path: path preview: preview [ - ^ BlBlocUIManagerNotification - requestOrNil: #chooseFullFileName:extensions:path:preview: - with: - {title. - exts. - path. - preview} -] - -{ #category : #'ui requests' } -BlBlocUIManager >> chooseFullFileNameMatching: patterns label: label [ - ^ BlBlocUIManagerNotification - requestOrNil: #chooseFullFileNameMatching:label: - with: - {patterns. - label} -] - -{ #category : #services } -BlBlocUIManager >> chooseOrRequestFrom: labelList values: valueList lines: linesArray title: aString [ - ^ BlBlocUIManagerNotification - requestOrNil: #chooseOrRequestFrom:values:lines:title: - with: - {labelList. - valueList. - linesArray. - aString} -] - -{ #category : #'ui requests' } -BlBlocUIManager >> confirm: questionStringOrText label: labelStringOrText [ - ^ BlBlocUIManagerNotification - request: #confirm:label: - with: - {questionStringOrText. - labelStringOrText} - default: [ false ] -] - -{ #category : #services } -BlBlocUIManager >> confirm: queryString label: title trueChoice: trueChoice falseChoice: falseChoice cancelChoice: cancelChoice default: defaultOption [ - ^ BlBlocUIManagerNotification - requestOrNil: #confirm:label:trueChoice:falseChoice:cancelChoice:default: - with: - {queryString. - title. - trueChoice. - falseChoice. - cancelChoice. - defaultOption} -] - -{ #category : #'ui requests' } -BlBlocUIManager >> confirm: aStringOrText orCancel: cancelBlock [ - ^ BlBlocUIManagerNotification - request: #confirm:orCancel: - with: - {aStringOrText. - cancelBlock} - default: cancelBlock -] - -{ #category : #debug } -BlBlocUIManager >> debugProcess: process context: context label: title fullView: bool notification: notificationString [ - "Open the default debugger registered in the system as a result of the error." - self - debugProcess: process - context: context - label: title - spawningDebuggingUsing: [ :debugSession | - Smalltalk tools debugger - openOn: debugSession withFullView: bool andNotification: notificationString ] -] - -{ #category : #debug } -BlBlocUIManager >> debugProcess: process context: context label: title spawningDebuggingUsing: debuggerSpawnBlock [ - "I open the default debugger and add support for detecting if the - debugged process is the Morphic or Bloc UI process. - I spawn a new Bloc UI process if the debugged process is the Bloc UI process - or a Morphic UI process if the debugged process is the Morphic UI process." - | debugSession isForBlocUIProcess aBlocUniverseIfAny aDebuggerOpeningAction | - - debugSession := process newDebugSessionNamed: title startedAt: context. - debugSession logStackToFileIfNeeded. - - isForBlocUIProcess := false. - aBlocUniverseIfAny := nil. - - self - universeForSession: debugSession - ifPresent: [ :aUniverse | - isForBlocUIProcess := true. - aBlocUniverseIfAny := aUniverse. - debugSession errorWasInUIProcess: true ] - ifAbsent: []. - - debugSession isAboutUIProcess ifTrue: [ - DefaultExecutionEnvironment beActiveDuring: [ - isForBlocUIProcess "Handle the case of the Bloc UI process" - ifTrue: [ self spawnNewBlocProcess: aBlocUniverseIfAny ] - ifFalse: [ self spawnNewProcess ] ] ]. - - aDebuggerOpeningAction := [ - [ - debuggerSpawnBlock value: debugSession. - ] on: Error do: [ :ex | - debugSession signalDebuggerError: ex ] ]. - - "Perform the opening of the debugger in defer action to suspend the UI." - isForBlocUIProcess - ifTrue: [ self defer: aDebuggerOpeningAction universe: aBlocUniverseIfAny ] - ifFalse: [ debugSession isAboutUIProcess - ifTrue: [ self defer: aDebuggerOpeningAction ] - ifFalse: [ self - universeDo: [ :aBlocUniverse | self defer: aDebuggerOpeningAction universe: aBlocUniverse ] - ifAbsent: [ self defer: aDebuggerOpeningAction ] ] ]. - - process suspend -] - -{ #category : #'ui process' } -BlBlocUIManager >> defer: aBlock universe: aBlocUniverseIfAny [ - "Defer aBloc in a given universe" - - aBlocUniverseIfAny defer: aBlock. - aBlocUniverseIfAny hostClass isRunning - ifFalse: [ aBlocUniverseIfAny startUniverse ] -] - -{ #category : #services } -BlBlocUIManager >> deny: aStringOrText title: aString [ - ^ BlBlocUIManagerNotification - request: #deny:title: - with: - {aStringOrText. - aString} - default: [ false ] -] - -{ #category : #'ui requests' } -BlBlocUIManager >> edit: aText label: labelString accept: aBlockOrNil [ - ^ BlBlocUIManagerNotification - request: #edit:label:accept: - with: - {aText. - labelString. - aBlockOrNil} -] - -{ #category : #services } -BlBlocUIManager >> enterOrRequestFrom: labelList values: valueList lines: linesArray title: aString [ - ^ BlBlocUIManagerNotification - requestOrNil: #enterOrRequestFrom:values:lines:title: - with: - {labelList. - valueList. - linesArray. - aString} -] - -{ #category : #'ui requests' } -BlBlocUIManager >> inform: aStringOrText [ - ^ BlBlocUIManagerNotification - requestOrNil: #inform: - with: {aStringOrText} -] - -{ #category : #'ui process' } -BlBlocUIManager >> isBlocUIProcess: aProcess [ - "Check if the given process is a Bloc UI process. - We consider it a Bloc UI process if is the UI process of a Universe." - self - universeForProcess: aProcess - ifPresent: [ :processUniverse | ^ true ] - ifAbsent: [ ^ false ]. - ^ false -] - -{ #category : #services } -BlBlocUIManager >> longMessage: aStringOrText title: aString [ - ^ BlBlocUIManagerNotification - request: #longMessage:title: - with: - {aStringOrText. - aString} - default: [ false ] -] - -{ #category : #'ui requests' } -BlBlocUIManager >> merge: merger informing: aString [ - ^ BlBlocUIManagerNotification - request: #merge:informing: - with: - {merger. - aString} -] - -{ #category : #services } -BlBlocUIManager >> message: aStringOrText title: aString [ - ^ BlBlocUIManagerNotification - requestOrNil: #message:title: - with: - {aStringOrText. - aString} -] - -{ #category : #'ui requests' } -BlBlocUIManager >> multiLineRequest: queryString initialAnswer: defaultAnswer answerHeight: answerHeight [ - ^ BlBlocUIManagerNotification - requestOrNil: #multiLineRequest:initialAnswer:answerHeight: - with: - {queryString. - defaultAnswer. - answerHeight} -] - -{ #category : #services } -BlBlocUIManager >> proceed: aStringOrText title: aString [ - ^ BlBlocUIManagerNotification - request: #proceed:title: - with: - {aStringOrText. - aString} - default: [ false ] -] - -{ #category : #services } -BlBlocUIManager >> question: aStringOrText title: aString [ - ^ BlBlocUIManagerNotification - requestOrNil: #question:title: - with: - {aStringOrText. - aString} -] - -{ #category : #services } -BlBlocUIManager >> questionWithoutCancel: aStringOrText title: aString [ - ^ BlBlocUIManagerNotification - request: #questionWithoutCancel:title: - with: - {aStringOrText. - aString} - default: [ false ] -] - -{ #category : #'ui requests' } -BlBlocUIManager >> request: aStringOrText initialAnswer: defaultAnswer title: aTitle [ - ^ BlBlocUIManagerNotification - requestOrNil: #request:initialAnswer:title: - with: - {aStringOrText. - defaultAnswer. - aTitle} -] - -{ #category : #'ui requests' } -BlBlocUIManager >> request: aStringOrText initialAnswer: defaultAnswer title: aTitle entryCompletion: anEntryCompletion [ - ^ BlBlocUIManagerNotification - requestOrNil: #request:initialAnswer:title:entryCompletion: - with: - {aStringOrText. - defaultAnswer. - aTitle. - anEntryCompletion} -] - -{ #category : #'ui requests' } -BlBlocUIManager >> requestPassword: aStringOrText [ - ^ BlBlocUIManagerNotification - requestOrNil: #requestPassword: - with: {aStringOrText} -] - -{ #category : #'ui process' } -BlBlocUIManager >> resumeBlocUIProcess: aProcess [ - "Adopt aProcess as the UI process for Bloc -- probably because of proceeding from a debugger" - - "Resume the Bloc UI process normally by delegating the resume operation through the host. - This assumes that the debugger was opened and runs in the Bloc UI process. - In case Bloc is embedded inside the Morphic World, the Bloc UI process is going to - be the Morphic UI process. Delegating the process operations through the host - ensures that the Morphic UI process will be resumed correctly." - - self - universeForProcess: aProcess - ifPresent: [ :aUniverse | - "aUniverse stopPulsation." - aUniverse hostClass forceResumeOfUIProcess: aProcess ] - ifAbsent: [ ]. -] - -{ #category : #'ui process' } -BlBlocUIManager >> resumeMorphicUIProcess: aProcess [ - "Adopt aProcess as the UI process for morphic -- probably because of proceeding from a debugger" - - "Resume the Morphic UI process normally without any special logic. - This assumes that the debugger was opened and runs in the Morphic UI process." - UIProcess := aProcess. - UIProcess resume -] - -{ #category : #'ui process' } -BlBlocUIManager >> resumeUIProcess: aProcess [ - "Adopt aProcess as the project process -- probably because of proceeding from a debugger" - - "I explicitly check if the process corresponds to the Bloc UI process or not so I can determine which UI process to resume." - (self isBlocUIProcess: aProcess) - ifTrue: [ - "Resume the Bloc UI process." - self resumeBlocUIProcess: aProcess ] - ifFalse: [ - "Resume the Moprhic UI process." - self resumeMorphicUIProcess: aProcess ] -] - -{ #category : #debug } -BlBlocUIManager >> spawnNewBlocProcess: aUniverse [ - aUniverse hostClass forceStartNewUIProcess -] - -{ #category : #services } -BlBlocUIManager >> syntaxErrorNotificationDefaultAction: anException [ - ^ BlBlocUIManagerNotification - requestOrNil: #syntaxErrorNotificationDefaultAction: - with: {anException} -] - -{ #category : #services } -BlBlocUIManager >> textEntry: aStringOrText title: aString entryText: defaultEntryText [ - ^ BlBlocUIManagerNotification - requestOrNil: #textEntry:title:entryText: - with: - {aStringOrText. - aString. - defaultEntryText} -] - -{ #category : #'ui process' } -BlBlocUIManager >> universeDo: aPresentBlock ifAbsent: anExceptionBlock [ - | theUniversesWithUIProcess | - theUniversesWithUIProcess := (BlParallelUniverse all select: [ :eachUniverse | - eachUniverse hasSpaces - and: [ eachUniverse hasUIProcess - and: [ eachUniverse hostClass new isRunning ] ] ]) - sorted: [ :a :b | a hostClass priority < b hostClass priority ]. - - theUniversesWithUIProcess - ifEmpty: anExceptionBlock - ifNotEmpty: [ :theUniverses | aPresentBlock value: theUniverses first ] -] - -{ #category : #'ui process' } -BlBlocUIManager >> universeForProcess: aProcess ifPresent: aPresentBlock ifAbsent: anExceptionBlock [ - ^ BlParallelUniverse all - detect: [ :eachUniverse | - | isInterruptedProcess | - isInterruptedProcess := false. - eachUniverse hostClass - uiProcessDo: [ :eachUIProcess | isInterruptedProcess := eachUIProcess name = aProcess name ]. - isInterruptedProcess ] - ifFound: aPresentBlock - ifNone: anExceptionBlock -] - -{ #category : #'ui process' } -BlBlocUIManager >> universeForSession: debugSession ifPresent: aPresentBlock ifAbsent: anExceptionBlock [ - ^ BlParallelUniverse all - detect: [ :eachUniverse | - | isInterruptedProcess | - isInterruptedProcess := false. - eachUniverse hostClass - uiProcessDo: [ :eachUIProcess | isInterruptedProcess := eachUIProcess == debugSession interruptedProcess ]. - isInterruptedProcess ] - ifFound: aPresentBlock - ifNone: anExceptionBlock -] diff --git a/src/BlocHost-Morphic/BlBlocUIManagerNotification.class.st b/src/BlocHost-Morphic/BlBlocUIManagerNotification.class.st deleted file mode 100644 index 70bb548c5..000000000 --- a/src/BlocHost-Morphic/BlBlocUIManagerNotification.class.st +++ /dev/null @@ -1,116 +0,0 @@ -Class { - #name : #BlBlocUIManagerNotification, - #superclass : #Notification, - #instVars : [ - 'request', - 'arguments', - 'defaultBlock' - ], - #classVars : [ - 'NotificationHandlers' - ], - #category : #'BlocHost-Morphic-Support' -} - -{ #category : #accessing } -BlBlocUIManagerNotification class >> notificationHandlers [ - ^ BlBlocUIManagerNotificationHandler notificationHandlers -] - -{ #category : #signaling } -BlBlocUIManagerNotification class >> request: aSymbol with: anArray [ - ^ self new - request: aSymbol; - arguments: anArray; - signal -] - -{ #category : #signaling } -BlBlocUIManagerNotification class >> request: aSymbol with: anArray default: aBlock [ - ^ self new - request: aSymbol; - arguments: anArray; - defaultBlock: aBlock; - signal -] - -{ #category : #signaling } -BlBlocUIManagerNotification class >> requestOrNil: aSymbol with: anArray [ - ^ self new - request: aSymbol; - arguments: anArray; - defaultBlock: [ nil ]; - signal -] - -{ #category : #accessing } -BlBlocUIManagerNotification >> arguments [ - ^ arguments -] - -{ #category : #accessing } -BlBlocUIManagerNotification >> arguments: anArray [ - arguments := anArray -] - -{ #category : #'exception handling' } -BlBlocUIManagerNotification >> defaultAction [ - self isFromMorphic ifTrue: [ ^ self processInMorphic ]. - self handlerDo: [ :aHandler | ^ aHandler show ]. - ^ self unhandledAction -] - -{ #category : #accessing } -BlBlocUIManagerNotification >> defaultBlock: aBlock [ - defaultBlock := aBlock -] - -{ #category : #'private - accessing' } -BlBlocUIManagerNotification >> handlerDo: aBlock [ - | aClass anInstance | - aClass := BlBlocUIManagerNotificationHandler preferredHandler. - aClass ifNil: [ ^ self ]. - anInstance := aClass managerNotification: self. - aBlock cull: anInstance. -] - -{ #category : #testing } -BlBlocUIManagerNotification >> isFromMorphic [ - | context worldMorphClass | - worldMorphClass := Smalltalk at: #WorldMorph. - worldMorphClass isNil - ifTrue: [ ^ false ]. - context := thisContext. - [ context notNil ] - whileTrue: [ (context receiver isKindOf: worldMorphClass) - ifTrue: [ ^ true ]. - context := context sender ]. - ^ false -] - -{ #category : #private } -BlBlocUIManagerNotification >> processInMorphic [ - ^ self - resume: - ((MorphicUIManager whichClassIncludesSelector: self request) - >> self request - valueWithReceiver: UIManager default - arguments: self arguments) -] - -{ #category : #accessing } -BlBlocUIManagerNotification >> request [ - ^ request -] - -{ #category : #accessing } -BlBlocUIManagerNotification >> request: aSymbol [ - request := aSymbol -] - -{ #category : #private } -BlBlocUIManagerNotification >> unhandledAction [ - ^ defaultBlock isNil - ifTrue: [ self error: 'No handler for request: ' , self request ] - ifFalse: [ defaultBlock value ] -] diff --git a/src/BlocHost-Morphic/BlBlocUIManagerNotificationBasicHandler.class.st b/src/BlocHost-Morphic/BlBlocUIManagerNotificationBasicHandler.class.st deleted file mode 100644 index c29d01646..000000000 --- a/src/BlocHost-Morphic/BlBlocUIManagerNotificationBasicHandler.class.st +++ /dev/null @@ -1,24 +0,0 @@ -Class { - #name : #BlBlocUIManagerNotificationBasicHandler, - #superclass : #BlBlocUIManagerNotificationHandler, - #category : #'BlocHost-Morphic-Support' -} - -{ #category : #'api - accessing' } -BlBlocUIManagerNotificationBasicHandler class >> priority [ - "Return an integer indicating the priority of the publisher. The higher the number, the higher the priority" - - ^ 1 -] - -{ #category : #'private - displaying' } -BlBlocUIManagerNotificationBasicHandler >> elementDoOrSpaceDo: aBlock [ - - | context | - context := thisContext. - [ context notNil ] - whileTrue: [ ((context receiver isKindOf: BlElement) - or: [ context receiver isKindOf: BlSpace ]) - ifTrue: [ ^ aBlock value: context receiver ]. - context := context sender ] -] diff --git a/src/BlocHost-Morphic/BlBlocUIManagerNotificationHandler.class.st b/src/BlocHost-Morphic/BlBlocUIManagerNotificationHandler.class.st deleted file mode 100644 index be4d990a1..000000000 --- a/src/BlocHost-Morphic/BlBlocUIManagerNotificationHandler.class.st +++ /dev/null @@ -1,113 +0,0 @@ -Class { - #name : #BlBlocUIManagerNotificationHandler, - #superclass : #Object, - #instVars : [ - 'managerNotification' - ], - #classVars : [ - 'NotificationHandlers' - ], - #category : #'BlocHost-Morphic-Support' -} - -{ #category : #'api - instance creation' } -BlBlocUIManagerNotificationHandler class >> managerNotification: aManagerNotification [ - ^ self new managerNotification: aManagerNotification -] - -{ #category : #accessing } -BlBlocUIManagerNotificationHandler class >> notificationHandlers [ - ^ NotificationHandlers - ifNil: [ NotificationHandlers := Dictionary new ] -] - -{ #category : #'api - accessing' } -BlBlocUIManagerNotificationHandler class >> preferredHandler [ - | aSelectedClass | - aSelectedClass := BlBlocUIManagerNotificationBasicHandler. - self allSubclassesDo: [ :aClass | - (aClass isAbstract not and: [ - aClass priority > aSelectedClass priority ]) - ifTrue: [ aSelectedClass := aClass ] ]. - ^ aSelectedClass -] - -{ #category : #'api - accessing' } -BlBlocUIManagerNotificationHandler class >> priority [ - "Return an integer indicating the priority of the publisher. The higher the number, the higher the priority" - - ^ -100 -] - -{ #category : #'private - accessing' } -BlBlocUIManagerNotificationHandler >> arguments [ - ^ self managerNotification arguments -] - -{ #category : #'private - displaying' } -BlBlocUIManagerNotificationHandler >> continue: debugSession with: anObject [ - | context | - context := debugSession interruptedContext. - [ context notNil - and: [ context isBlockContext or: [ context receiver ~~ self ] ] ] - whileTrue: [ context := context sender ]. - debugSession - returnValue: anObject - from: (context ifNil: [ debugSession interruptedContext ]). - debugSession resume -] - -{ #category : #'private - accessing' } -BlBlocUIManagerNotificationHandler >> elementDoOrSpaceDo: aBlock [ - "Provide an element or space and evaluate the block" - self subclassResponsibility -] - -{ #category : #'private - accessing' } -BlBlocUIManagerNotificationHandler >> managerNotification [ - - ^ managerNotification -] - -{ #category : #'api - initialization' } -BlBlocUIManagerNotificationHandler >> managerNotification: aManagerNotification [ - managerNotification := aManagerNotification -] - -{ #category : #'private - accessing' } -BlBlocUIManagerNotificationHandler >> request [ - ^ self managerNotification request -] - -{ #category : #'api - displaying' } -BlBlocUIManagerNotificationHandler >> show [ - self elementDoOrSpaceDo: [ :each | ^ self showNotificationIn: each ]. - ^ self unhandledAction -] - -{ #category : #'private - displaying' } -BlBlocUIManagerNotificationHandler >> showNotificationIn: anElementOrSpace [ - self class notificationHandlers - at: self request - ifPresent: [ :creationBlock | - creationBlock numArgs <= 2 - ifTrue: [ anElementOrSpace - showNotification: (creationBlock cull: self request cull: self arguments) ] - ifFalse: [ ^ UIManager default - debugProcess: Processor activeProcess - context: thisContext - label: 'UIManager Notification' - spawningDebuggingUsing: [ :session | - anElementOrSpace - showNotification: - (creationBlock - cull: self request - cull: self arguments - cull: [ :object | self continue: session with: object ]) ] ] ]. - ^ self unhandledAction -] - -{ #category : #'private - handling exceptions' } -BlBlocUIManagerNotificationHandler >> unhandledAction [ - ^ self managerNotification unhandledAction -] diff --git a/src/BlocHost-Morphic/BlBlocUINotificationBasicPublisher.class.st b/src/BlocHost-Morphic/BlBlocUINotificationBasicPublisher.class.st deleted file mode 100644 index b0b7722b6..000000000 --- a/src/BlocHost-Morphic/BlBlocUINotificationBasicPublisher.class.st +++ /dev/null @@ -1,17 +0,0 @@ -Class { - #name : #BlBlocUINotificationBasicPublisher, - #superclass : #BlBlocUINotificationPublisher, - #category : #'BlocHost-Morphic-Support' -} - -{ #category : #'api - accessing' } -BlBlocUINotificationBasicPublisher class >> priority [ - "Return an integer indicating the priority of the publisher. The higher the number, the higher the priority" - - ^ 1 -] - -{ #category : #'api - displaying' } -BlBlocUINotificationBasicPublisher >> addNotification [ - ^ self element addChild: self notification asElement -] diff --git a/src/BlocHost-Morphic/BlBlocUINotificationPublisher.class.st b/src/BlocHost-Morphic/BlBlocUINotificationPublisher.class.st deleted file mode 100644 index b52d95234..000000000 --- a/src/BlocHost-Morphic/BlBlocUINotificationPublisher.class.st +++ /dev/null @@ -1,73 +0,0 @@ -Class { - #name : #BlBlocUINotificationPublisher, - #superclass : #Object, - #instVars : [ - 'notification', - 'element' - ], - #category : #'BlocHost-Morphic-Support' -} - -{ #category : #'api - accessing' } -BlBlocUINotificationPublisher class >> preferredPublisher [ - | aSelectedClass | - aSelectedClass := BlBlocUINotificationBasicPublisher. - self allSubclassesDo: [ :aClass | - (aClass isAbstract not and: [ - aClass priority > aSelectedClass priority ]) - ifTrue: [ aSelectedClass := aClass ] ]. - ^ aSelectedClass -] - -{ #category : #'api - accessing' } -BlBlocUINotificationPublisher class >> priority [ - "Return an integer indicating the priority of the publisher. The higher the number, the higher the priority" - - ^ -100 -] - -{ #category : #'api - instance creation' } -BlBlocUINotificationPublisher class >> showNotification: aNotification inElement: anElement [ - ^ self preferredPublisher new - element: anElement; - notification: aNotification; - show -] - -{ #category : #'private - displaying' } -BlBlocUINotificationPublisher >> addNotification [ - self subclassResponsibility -] - -{ #category : #'api - accessing' } -BlBlocUINotificationPublisher >> element [ - - ^ element -] - -{ #category : #'api - accessing' } -BlBlocUINotificationPublisher >> element: anElement [ - element := anElement -] - -{ #category : #'private - displaying' } -BlBlocUINotificationPublisher >> enqueueTaskAction: aBlock [ - self element enqueueTask: (BlTaskAction new - action: aBlock) -] - -{ #category : #'api - accessing' } -BlBlocUINotificationPublisher >> notification [ - ^ notification -] - -{ #category : #'api - accessing' } -BlBlocUINotificationPublisher >> notification: aNotification [ - "aNotification must be an object that understands #asElement" - notification := aNotification -] - -{ #category : #'api - displaying' } -BlBlocUINotificationPublisher >> show [ - self enqueueTaskAction: [ self addNotification ] -] diff --git a/src/BlocHost-Morphic/BlElement.extension.st b/src/BlocHost-Morphic/BlElement.extension.st deleted file mode 100644 index edd9bc42c..000000000 --- a/src/BlocHost-Morphic/BlElement.extension.st +++ /dev/null @@ -1,12 +0,0 @@ -Extension { #name : #BlElement } - -{ #category : #'*BlocHost-Morphic' } -BlElement >> showNotification: aNotification [ - self parent ifNotNil: [ :aParent | - aParent showNotification: aNotification. - ^ self ]. - - BlBlocUINotificationPublisher - showNotification: aNotification - inElement: self -] diff --git a/src/BlocHost-Morphic/BlExternalForm.class.st b/src/BlocHost-Morphic/BlExternalForm.class.st index 76e092473..5064047ae 100644 --- a/src/BlocHost-Morphic/BlExternalForm.class.st +++ b/src/BlocHost-Morphic/BlExternalForm.class.st @@ -24,7 +24,7 @@ Class { #superclass : #OSSDL2ExternalForm, #traits : 'TBlDebug', #classTraits : 'TBlDebug classTrait', - #category : #'BlocHost-Morphic-Host - Common' + #category : #'BlocHost-Morphic-Common' } { #category : #'external resource management' } diff --git a/src/BlocHost-Morphic/BlMorphicEventHandler.class.st b/src/BlocHost-Morphic/BlMorphicEventHandler.class.st index d406fba12..09da86af2 100644 --- a/src/BlocHost-Morphic/BlMorphicEventHandler.class.st +++ b/src/BlocHost-Morphic/BlMorphicEventHandler.class.st @@ -14,7 +14,7 @@ Class { #classVars : [ 'HorizontalScrolling' ], - #category : #'BlocHost-Morphic-Support' + #category : #'BlocHost-Morphic-Common - Events' } { #category : #'instance creation' } diff --git a/src/BlocHost-Morphic/BlMorphicFormSurfaceRenderer.class.st b/src/BlocHost-Morphic/BlMorphicFormSurfaceRenderer.class.st index 1c9b18b9f..e59fbfa46 100644 --- a/src/BlocHost-Morphic/BlMorphicFormSurfaceRenderer.class.st +++ b/src/BlocHost-Morphic/BlMorphicFormSurfaceRenderer.class.st @@ -4,7 +4,7 @@ Class { #instVars : [ 'spaceHostMorph' ], - #category : #'BlocHost-Morphic-Host - Common' + #category : #'BlocHost-Morphic-Common' } { #category : #initialization } diff --git a/src/BlocHost-Morphic/BlMorphicHost.class.st b/src/BlocHost-Morphic/BlMorphicHost.class.st index c10f33ee6..120ff41a5 100644 --- a/src/BlocHost-Morphic/BlMorphicHost.class.st +++ b/src/BlocHost-Morphic/BlMorphicHost.class.st @@ -17,7 +17,7 @@ Class { #instVars : [ 'containerMorph' ], - #category : #'BlocHost-Morphic-Host - Morph' + #category : #'BlocHost-Morphic-Embedded' } { #category : #testing } diff --git a/src/BlocHost-Morphic/BlMorphicHostSpace.class.st b/src/BlocHost-Morphic/BlMorphicHostSpace.class.st index f1a6c5705..92173ae18 100644 --- a/src/BlocHost-Morphic/BlMorphicHostSpace.class.st +++ b/src/BlocHost-Morphic/BlMorphicHostSpace.class.st @@ -11,7 +11,7 @@ Class { #instVars : [ 'spaceHostMorph' ], - #category : #'BlocHost-Morphic-Host - Morph' + #category : #'BlocHost-Morphic-Embedded' } { #category : #'window - properties' } diff --git a/src/BlocHost-Morphic/BlMorphicSpaceHostMorph.class.st b/src/BlocHost-Morphic/BlMorphicSpaceHostMorph.class.st index 0d3981aec..4f88d792d 100644 --- a/src/BlocHost-Morphic/BlMorphicSpaceHostMorph.class.st +++ b/src/BlocHost-Morphic/BlMorphicSpaceHostMorph.class.st @@ -10,7 +10,7 @@ Class { 'preventResize', 'hostSpace' ], - #category : #'BlocHost-Morphic-Host - Common' + #category : #'BlocHost-Morphic-Common' } { #category : #drawing } diff --git a/src/BlocHost-Morphic/BlMorphicSteppingHost.class.st b/src/BlocHost-Morphic/BlMorphicSteppingHost.class.st index 27a4e2911..6b2a65506 100644 --- a/src/BlocHost-Morphic/BlMorphicSteppingHost.class.st +++ b/src/BlocHost-Morphic/BlMorphicSteppingHost.class.st @@ -4,7 +4,7 @@ I am a host that lives in a Morphic World's UI thread and uses stepping mechanis Class { #name : #BlMorphicSteppingHost, #superclass : #BlHost, - #category : #'BlocHost-Morphic-Host - Common' + #category : #'BlocHost-Morphic-Common' } { #category : #'api - ui process' } diff --git a/src/BlocHost-Morphic/BlMorphicWindow.class.st b/src/BlocHost-Morphic/BlMorphicWindow.class.st index 84d59926f..a887c5477 100644 --- a/src/BlocHost-Morphic/BlMorphicWindow.class.st +++ b/src/BlocHost-Morphic/BlMorphicWindow.class.st @@ -11,7 +11,7 @@ Class { 'preventResize', 'spaceHostMorph' ], - #category : #'BlocHost-Morphic-Host - Window' + #category : #'BlocHost-Morphic-Window' } { #category : #accessing } diff --git a/src/BlocHost-Morphic/BlMorphicWindowClosedEvent.class.st b/src/BlocHost-Morphic/BlMorphicWindowClosedEvent.class.st index a1b36b556..8d9c5b81c 100644 --- a/src/BlocHost-Morphic/BlMorphicWindowClosedEvent.class.st +++ b/src/BlocHost-Morphic/BlMorphicWindowClosedEvent.class.st @@ -4,7 +4,7 @@ I am fired by morphic host window when it is closed or deleted from the World Class { #name : #BlMorphicWindowClosedEvent, #superclass : #BlMorphicWindowEvent, - #category : #'BlocHost-Morphic-Events' + #category : #'BlocHost-Morphic-Common - Events' } { #category : #dispatching } diff --git a/src/BlocHost-Morphic/BlMorphicWindowEvent.class.st b/src/BlocHost-Morphic/BlMorphicWindowEvent.class.st index 9fbee12bd..704eb34a9 100644 --- a/src/BlocHost-Morphic/BlMorphicWindowEvent.class.st +++ b/src/BlocHost-Morphic/BlMorphicWindowEvent.class.st @@ -4,7 +4,7 @@ I am a super class of all window related events fired by morphic host window Class { #name : #BlMorphicWindowEvent, #superclass : #WindowEvent, - #category : #'BlocHost-Morphic-Events' + #category : #'BlocHost-Morphic-Common - Events' } { #category : #accessing } diff --git a/src/BlocHost-Morphic/BlMorphicWindowHost.class.st b/src/BlocHost-Morphic/BlMorphicWindowHost.class.st index d58a5d3a1..5402de56f 100644 --- a/src/BlocHost-Morphic/BlMorphicWindowHost.class.st +++ b/src/BlocHost-Morphic/BlMorphicWindowHost.class.st @@ -4,7 +4,7 @@ I am a host that opens spaces as windows in the Morphic World. Class { #name : #BlMorphicWindowHost, #superclass : #BlMorphicSteppingHost, - #category : #'BlocHost-Morphic-Host - Window' + #category : #'BlocHost-Morphic-Window' } { #category : #'driver selection' } diff --git a/src/BlocHost-Morphic/BlMorphicWindowHostSpace.class.st b/src/BlocHost-Morphic/BlMorphicWindowHostSpace.class.st index 9912679f2..559f5ba21 100644 --- a/src/BlocHost-Morphic/BlMorphicWindowHostSpace.class.st +++ b/src/BlocHost-Morphic/BlMorphicWindowHostSpace.class.st @@ -12,7 +12,7 @@ Class { 'isFullSize', 'isBorderless' ], - #category : #'BlocHost-Morphic-Host - Window' + #category : #'BlocHost-Morphic-Window' } { #category : #'window - properties' } diff --git a/src/BlocHost-Morphic/BlMorphicWindowOpenedEvent.class.st b/src/BlocHost-Morphic/BlMorphicWindowOpenedEvent.class.st index b6221f52b..46e197a22 100644 --- a/src/BlocHost-Morphic/BlMorphicWindowOpenedEvent.class.st +++ b/src/BlocHost-Morphic/BlMorphicWindowOpenedEvent.class.st @@ -4,7 +4,7 @@ I am fired by morphic host window when it is opened in the World Class { #name : #BlMorphicWindowOpenedEvent, #superclass : #BlMorphicWindowEvent, - #category : #'BlocHost-Morphic-Events' + #category : #'BlocHost-Morphic-Common - Events' } { #category : #dispatching } diff --git a/src/BlocHost-Morphic/BlMorphicWindowResizeEvent.class.st b/src/BlocHost-Morphic/BlMorphicWindowResizeEvent.class.st index 636c1b167..37c51903d 100644 --- a/src/BlocHost-Morphic/BlMorphicWindowResizeEvent.class.st +++ b/src/BlocHost-Morphic/BlMorphicWindowResizeEvent.class.st @@ -8,7 +8,7 @@ Class { 'width', 'height' ], - #category : #'BlocHost-Morphic-Events' + #category : #'BlocHost-Morphic-Common - Events' } { #category : #accessing } diff --git a/src/BlocHost-Morphic/BlMorphicWorldDisplayScreen.class.st b/src/BlocHost-Morphic/BlMorphicWorldDisplayScreen.class.st deleted file mode 100644 index 7e1e8e715..000000000 --- a/src/BlocHost-Morphic/BlMorphicWorldDisplayScreen.class.st +++ /dev/null @@ -1,22 +0,0 @@ -Class { - #name : #BlMorphicWorldDisplayScreen, - #superclass : #Form, - #category : #'BlocHost-Morphic-World' -} - -{ #category : #converting } -BlMorphicWorldDisplayScreen >> beDisplay [ -] - -{ #category : #testing } -BlMorphicWorldDisplayScreen >> isFullscreen [ - - ^ false -] - -{ #category : #other } -BlMorphicWorldDisplayScreen >> usableArea [ - "Answer the usable area of the receiver." - - ^ self boundingBox deepCopy -] diff --git a/src/BlocHost-Morphic/BlMorphicWorldEmbeddingElement.class.st b/src/BlocHost-Morphic/BlMorphicWorldEmbeddingElement.class.st deleted file mode 100644 index 85446cad2..000000000 --- a/src/BlocHost-Morphic/BlMorphicWorldEmbeddingElement.class.st +++ /dev/null @@ -1,136 +0,0 @@ -Class { - #name : #BlMorphicWorldEmbeddingElement, - #superclass : #BlElement, - #instVars : [ - 'world', - 'worldState', - 'shouldBeMain' - ], - #category : #'BlocHost-Morphic-World' -} - -{ #category : #'instance creation' } -BlMorphicWorldEmbeddingElement class >> open [ - - - | aSpace | - aSpace := BlSpace new. - aSpace title: 'Morph World'. - aSpace extent: 1280@800. - aSpace root: self new. - aSpace show -] - -{ #category : #'instance creation' } -BlMorphicWorldEmbeddingElement class >> openMain [ - - - | aSpace | - aSpace := BlSpace new. - aSpace title: 'Morph World'. - aSpace extent: 1280@800. - aSpace root: self new beMain. - aSpace show -] - -{ #category : #accessing } -BlMorphicWorldEmbeddingElement >> activeHand [ - - ^ self world activeHand ifNil: [ - | aHand | - aHand := world hands anyOne. - world activeHand: aHand. - aHand ] -] - -{ #category : #actions } -BlMorphicWorldEmbeddingElement >> beMain [ - - shouldBeMain := true. - self isAttachedToSceneGraph - ifTrue: [ world beMain ] -] - -{ #category : #drawing } -BlMorphicWorldEmbeddingElement >> drawOnSpartaCanvas: aCanvas [ - super drawOnSpartaCanvas: aCanvas. - - world drawOnSpartaCanvas: aCanvas -] - -{ #category : #initialization } -BlMorphicWorldEmbeddingElement >> initialize [ - - super initialize. - - self constraintsDo: [ :c | - c horizontal matchParent. - c vertical matchParent ]. - - shouldBeMain := false. - worldState := - BlMorphicWorldState new - element: self; - yourself. - - world := BlMorphicWorldMorph worldState: worldState. - world worldState worldRenderer: - (BlMorphicWorldRenderer new - element: self; - world: world; - yourself). - - self addEventHandler: BlMorphicWorldEmbeddingEventHandler new. - self - addEventHandlerOn: BlMouseDownEvent - do: [ self requestFocus ]. - - self enqueueTask: - (BlRepeatedTaskAction new - delay: 20 milliSeconds; - action: [ world runStepMethods ]; - yourself) -] - -{ #category : #'hooks - children' } -BlMorphicWorldEmbeddingElement >> onAddedToSceneGraph [ - - super onAddedToSceneGraph. - - shouldBeMain ifTrue: [ world beMain ] -] - -{ #category : #layout } -BlMorphicWorldEmbeddingElement >> onLayout: aRectangle context: aBlElementBoundsUpdater [ - - super onLayout: aRectangle context: aBlElementBoundsUpdater. - - world fullBounds. - - world viewBox = (0@0 extent: aRectangle extent) - ifFalse: [ world viewBox: (0@0 extent: aRectangle extent) ]. - - world displayExtent = aRectangle extent - ifFalse: [ world displayExtent: aRectangle extent ] -] - -{ #category : #layout } -BlMorphicWorldEmbeddingElement >> onMeasure: anExtentMeasurementSpec [ - - super onMeasure: anExtentMeasurementSpec. - world extent = self measuredExtent - ifTrue: [ ^ self ]. - world extent: self measuredExtent -] - -{ #category : #accessing } -BlMorphicWorldEmbeddingElement >> world [ - - ^ world -] - -{ #category : #accessing } -BlMorphicWorldEmbeddingElement >> world: aWorldMorph [ - - world := aWorldMorph -] diff --git a/src/BlocHost-Morphic/BlMorphicWorldEmbeddingEventHandler.class.st b/src/BlocHost-Morphic/BlMorphicWorldEmbeddingEventHandler.class.st deleted file mode 100644 index af75b210a..000000000 --- a/src/BlocHost-Morphic/BlMorphicWorldEmbeddingEventHandler.class.st +++ /dev/null @@ -1,300 +0,0 @@ -" -I can be used to convert OSWindow-level events to Morphic events. -So, that installing my instance as event handler for specific window would allow running Morphic World in it. - -Later, the Morphic can be integrated with OSWindow API to avoid unnecessary conversion and thus eliminating the need in having this class. -" -Class { - #name : #BlMorphicWorldEmbeddingEventHandler, - #superclass : #BlEventListener, - #instVars : [ - 'buttons' - ], - #classVars : [ - 'KeyCharacterMapping' - ], - #category : #'BlocHost-Morphic-World' -} - -{ #category : #'class initialization' } -BlMorphicWorldEmbeddingEventHandler class >> initialize [ - " - self initialize - " - KeyCharacterMapping := Dictionary new. - - (($A to: $Z) flatCollect: [ :c | { c asSymbol . c } ]), - { - #backspace . Character backspace. - #tab . Character tab. - #home . Character home. - #left . Character arrowLeft. - #up . Character arrowUp. - #right . Character arrowRight. - #down . Character arrowDown. - #end . Character end. - #pageUp . Character pageUp. - #pageDown . Character pageDown. - #delete. Character delete. - #space. Character space. - #zero . $0. - #one . $1. - #two . $2. - #three . $3. - #four . $4. - #five . $5. - #six . $6. - #seven . $7. - #eight . $8. - #nine . $9. - #slash . $/. - #backslash . $\. - #minus . $-. - #enter . Character cr. - #period . $.. - } pairsDo: [ :key :val | KeyCharacterMapping at: (KeyboardKey perform: key) put: val ] -] - -{ #category : #converting } -BlMorphicWorldEmbeddingEventHandler >> convertButton: aBlMouseButton [ - - aBlMouseButton = BlMouseButton primary - ifTrue: [ ^ MouseButtonEvent redButton ]. - aBlMouseButton = BlMouseButton middle - ifTrue: [ ^ MouseButtonEvent blueButton ]. - aBlMouseButton = BlMouseButton secondary - ifTrue: [ ^ MouseButtonEvent yellowButton ]. - - ^ 0 -] - -{ #category : #converting } -BlMorphicWorldEmbeddingEventHandler >> convertModifiers: modifiers [ - - | btns | - btns := 0. - - "Alt/Option key" - modifiers isAlt ifTrue: [ - "On windows and unix, treat alt key as command key" - btns := Smalltalk os isWin32 | Smalltalk os isUnix - ifTrue: [ btns | 2r01000000 ] - ifFalse: [ btns | 2r00100000 ] ]. - - modifiers isCtrl ifTrue: [ btns := btns | 2r00010000 ]. "Control key" - modifiers isShift ifTrue: [ btns := btns | 8 ]. "Shift key" - modifiers isCmd ifTrue: [ btns := btns | 2r01000000 ]. "Cmd key" - - ^ btns -] - -{ #category : #events } -BlMorphicWorldEmbeddingEventHandler >> dispatchMorphicEvent: anEvent hand: aHandMorph [ - - aHandMorph - ifNotNil: [ aHandMorph handleEvent: anEvent ] - ifNil: [ - NonInteractiveTranscript stderr - show: ('Can not handle {1} because hand is nil' - format: { anEvent }); - cr ] -] - -{ #category : #'keyboard handlers' } -BlMorphicWorldEmbeddingEventHandler >> keyDownEvent: anEvent [ - - | aHand aMorphicEvent aCharacter aKeyValue aCharCode | - - anEvent consume. - aHand := anEvent currentTarget activeHand. - - aCharacter := self mapKeyToCharacter: anEvent key. - - aKeyValue := aCharacter asciiValue. - aCharCode := aCharacter charCode. - (aCharCode > 255) ifTrue: [ aKeyValue := 0 ]. - - aMorphicEvent := KeyboardEvent new - setType: #keyDown - buttons: (self convertModifiers: anEvent modifiers) - position: anEvent position - keyValue: aKeyValue - charCode: aCharCode - hand: aHand - stamp: Time millisecondClockValue. - aMorphicEvent scanCode: anEvent scanCode. - - self dispatchMorphicEvent: aMorphicEvent hand: aHand. - - aCharacter = Character null - ifTrue: [ ^ self ]. - - (Unicode isPrintable: aCharacter) - ifTrue: [ ^ self ]. - - aMorphicEvent := KeyboardEvent new - setType: #keystroke - buttons: (self convertModifiers: anEvent modifiers) - position: anEvent position - keyValue: aKeyValue - charCode: aCharCode - hand: aHand - stamp: Time millisecondClockValue. - - self dispatchMorphicEvent: aMorphicEvent hand: aHand -] - -{ #category : #'keyboard handlers' } -BlMorphicWorldEmbeddingEventHandler >> keyUpEvent: anEvent [ - - | aHand aMorphicEvent | - - anEvent consume. - aHand := anEvent currentTarget activeHand. - - aMorphicEvent := KeyboardEvent new - setType: #keyUp - buttons: (self convertModifiers: anEvent modifiers) - position: anEvent position - keyValue: (self mapKeyToCharacter: anEvent key) asciiValue - charCode: (self mapKeyToCharacter: anEvent key) charCode - hand: aHand - stamp: Time millisecondClockValue. - aMorphicEvent scanCode: anEvent scanCode. - - self dispatchMorphicEvent: aMorphicEvent hand: aHand -] - -{ #category : #visiting } -BlMorphicWorldEmbeddingEventHandler >> mapKeyToCharacter: aKeyboardKey [ - - ^ KeyCharacterMapping - at: aKeyboardKey - ifAbsent: [ Character null ] -] - -{ #category : #'mouse handlers' } -BlMorphicWorldEmbeddingEventHandler >> mouseDownEvent: anEvent [ - - | aHand aMorphicEvent | - - anEvent consume. - - aHand := anEvent currentTarget activeHand. - - anEvent currentTarget world beCursorOwner. - - aMorphicEvent := MouseButtonEvent new - setType: #mouseDown - position: anEvent localPosition - which: (self convertButton: anEvent button) - buttons: (buttons := (self convertModifiers: anEvent modifiers) | (self convertButton: anEvent button)) - hand: aHand - stamp: Time millisecondClockValue. - - self dispatchMorphicEvent: aMorphicEvent hand: aHand -] - -{ #category : #'mouse handlers' } -BlMorphicWorldEmbeddingEventHandler >> mouseMoveEvent: anEvent [ - - | aHand aMorphicEvent oldPos theButtons | - - anEvent consume. - - aHand := anEvent currentTarget activeHand. - oldPos := aHand position. - - anEvent currentTarget world beCursorOwner. - - theButtons := (self convertModifiers: anEvent modifiers). - buttons ifNotNil: [ theButtons := theButtons | buttons ]. - - aMorphicEvent := MouseMoveEvent basicNew - setType: #mouseMove - startPoint: oldPos - endPoint: anEvent localPosition - trail: { oldPos. anEvent localPosition } - buttons: theButtons - hand: aHand - stamp: Time millisecondClockValue. - - self dispatchMorphicEvent: aMorphicEvent hand: aHand. - - "hand moved, we should invalidate a rect under it (hand does not propagate it to the world)" - anEvent currentTarget world invalidRect: aHand bounds from: aHand -] - -{ #category : #'mouse handlers' } -BlMorphicWorldEmbeddingEventHandler >> mouseUpEvent: anEvent [ - - | aHand aMorphicEvent | - - anEvent consume. - - aHand := anEvent currentTarget activeHand. - - anEvent currentTarget world beCursorOwner. - - aMorphicEvent := MouseButtonEvent new - setType: #mouseUp - position: anEvent localPosition - which: (self convertButton: anEvent button) - buttons: (buttons := (self convertModifiers: anEvent modifiers)) - hand: aHand - stamp: Time millisecondClockValue. - - self dispatchMorphicEvent: aMorphicEvent hand: aHand -] - -{ #category : #'mouse handlers' } -BlMorphicWorldEmbeddingEventHandler >> mouseWheelEvent: anEvent [ - - | vertical aHand aMorphicEvent | - - anEvent consume. - - anEvent currentTarget world beCursorOwner. - - anEvent vector x abs > anEvent vector y abs - ifTrue: [ ^ self ]. - - vertical := anEvent vector y. - - aHand := anEvent currentTarget activeHand. - - aMorphicEvent := MouseWheelEvent new - setType: #mouseWheel - position: anEvent localPosition - direction: (vertical > 0 ifTrue: [ Character arrowUp ] ifFalse: [ Character arrowDown ]) - buttons: (self convertModifiers: anEvent modifiers) - hand: aHand - stamp: Time millisecondClockValue. - - self dispatchMorphicEvent: aMorphicEvent hand: aHand -] - -{ #category : #'keyboard handlers' } -BlMorphicWorldEmbeddingEventHandler >> textInputEvent: anEvent [ - - | aHand aMorphicEvent anInputString | - - anEvent consume. - - (anEvent text allSatisfy: [ :aCharacter | Unicode isPrintable: aCharacter ]) - ifFalse: [ ^ self ]. - - aHand := anEvent currentTarget activeHand. - anInputString := anEvent text. - - aMorphicEvent := KeyboardEvent new - setType: #keystroke - buttons: (self convertModifiers: anEvent modifiers) - position: aHand position - keyValue: anInputString first asciiValue - charCode: anInputString first asciiValue - hand: aHand - stamp: Time millisecondClockValue. - - self dispatchMorphicEvent: aMorphicEvent hand: aHand -] diff --git a/src/BlocHost-Morphic/BlMorphicWorldMorph.class.st b/src/BlocHost-Morphic/BlMorphicWorldMorph.class.st deleted file mode 100644 index 8f7100eab..000000000 --- a/src/BlocHost-Morphic/BlMorphicWorldMorph.class.st +++ /dev/null @@ -1,180 +0,0 @@ -Class { - #name : #BlMorphicWorldMorph, - #superclass : #WorldMorph, - #instVars : [ - 'display', - 'drawingCache', - 'mySession' - ], - #category : #'BlocHost-Morphic-World' -} - -{ #category : #accessing } -BlMorphicWorldMorph class >> worldState: aWorldState [ - - ^ self basicNew - initializeWith: aWorldState; - yourself -] - -{ #category : #actions } -BlMorphicWorldMorph >> beMain [ - InputEventFetcher deinstall. - - Cursor currentCursor: Cursor normal. - World := self. - ActiveWorld := self. - ActiveHand := self hands first. - Display := display. - - worldState element isAttachedToSceneGraph - ifFalse: [ ^ self ]. - - worldState element space host class uiProcessDo: [ :aProcess | - (UIManager default uiProcess ~~ aProcess) - ifTrue: [ UIManager default uiProcess ifNotNil: #terminate ]. - - MorphicUIManager classVarNamed: #UIProcess put: aProcess ] -] - -{ #category : #api } -BlMorphicWorldMorph >> display [ - - ^ display -] - -{ #category : #initialization } -BlMorphicWorldMorph >> displayExtent [ - - ^ display extent -] - -{ #category : #initialization } -BlMorphicWorldMorph >> displayExtent: aPoint [ - - display setExtent: aPoint depth: display depth. - - self changed -] - -{ #category : #drawing } -BlMorphicWorldMorph >> drawOnSpartaCanvas: aCanvas [ - self validateDrawingCache. - - aCanvas fill - paint: self color; - path: self bounds; - draw. - - submorphs reverseDo: [ :eachMorph | - | aBitmap | - aBitmap := self drawingCache - at: eachMorph - ifAbsentPut: [ aCanvas bitmap fromForm: eachMorph imageForm ]. - - aCanvas fill - paint: aBitmap; - path: eachMorph bounds; - antialiasNone; - draw ]. - - self worldState hands reverseDo: [ :eachHand | - eachHand submorphs reverseDo: [ :eachMorph | - | aBitmap | - aBitmap := self drawingCache - at: eachMorph - ifAbsentPut: [ aCanvas bitmap fromForm: eachMorph imageForm ]. - - aCanvas fill - paint: aBitmap; - path: eachMorph bounds; - antialiasNone; - draw ] ] -] - -{ #category : #accessing } -BlMorphicWorldMorph >> drawingCache [ - - ^ drawingCache ifNil: [ drawingCache := IdentityDictionary new ] -] - -{ #category : #initialization } -BlMorphicWorldMorph >> initializeMenubar [ - - | oldWorld oldActiveWorld | - oldWorld := World. - oldActiveWorld := ActiveWorld. - World := self. - ActiveWorld := self. - - [ MenubarMorph new - menuBarItems: worldState menuBuilder menuSpec items; - open ] - ensure: [ - World := oldWorld. - ActiveWorld := oldActiveWorld ] -] - -{ #category : #initialization } -BlMorphicWorldMorph >> initializeWith: aWorldState [ - - | aHand | - self initialize. - - display := BlMorphicWorldDisplayScreen extent: 640 @ 480 depth: 32. - drawingCache := IdentityDictionary new. - - self color: (Color r: 0.94 g: 0.94 b: 0.94 alpha: 1.0). - self extent: 640@480. - - worldState := aWorldState. - worldState display: display. - - self addHand: (aHand := HandMorph new). - aHand instVarNamed: #targetOffset put: 0@0. - - self createTaskbarIfNecessary. - - (self theme desktopImageFor: self) ifNotNil: [:aForm | - self backgroundImage: aForm layout: self theme desktopImageLayout ]. - - self initializeMenubar -] - -{ #category : #'change reporting' } -BlMorphicWorldMorph >> invalidRect: damageRect from: aMorph [ - - | myChild | - super invalidRect: damageRect from: aMorph. - - aMorph == self ifTrue: [ ^ self ]. - - myChild := aMorph. - - [ myChild isNotNil and: [ myChild owner ~~ self ] ] - whileTrue: [ myChild := myChild owner ]. - - myChild owner == self ifTrue: [ - self drawingCache removeKey: myChild ifAbsent: [ ] ] -] - -{ #category : #recategorized } -BlMorphicWorldMorph >> layoutChanged [ - super layoutChanged. - - (worldState isKindOf: BlMorphicWorldState) - ifTrue: [ worldState element requestLayout ] -] - -{ #category : #drawing } -BlMorphicWorldMorph >> validateDrawingCache [ - mySession == Smalltalk session - ifFalse: [ - mySession := Smalltalk session. - self drawingCache removeAll ]. - - self drawingCache keys - do: [ :eachMorph | - (eachMorph owner == self) - ifFalse: [ self drawingCache removeKey: eachMorph ifAbsent: [ ] ] ] -] diff --git a/src/BlocHost-Morphic/BlMorphicWorldRenderer.class.st b/src/BlocHost-Morphic/BlMorphicWorldRenderer.class.st deleted file mode 100644 index d97c9a585..000000000 --- a/src/BlocHost-Morphic/BlMorphicWorldRenderer.class.st +++ /dev/null @@ -1,87 +0,0 @@ -" -I know how to render the world in a Bloc element -" -Class { - #name : #BlMorphicWorldRenderer, - #superclass : #AbstractWorldRenderer, - #instVars : [ - 'element', - 'display', - 'spartaCanvas' - ], - #category : #'BlocHost-Morphic-World' -} - -{ #category : #accessing } -BlMorphicWorldRenderer class >> isApplicableFor: aWorld [ - - ^ aWorld class = BlMorphicWorldMorph -] - -{ #category : #accessing } -BlMorphicWorldRenderer class >> priority [ - - ^ 3 -] - -{ #category : #operations } -BlMorphicWorldRenderer >> activateCursor: aCursor withMask: maskForm [ -] - -{ #category : #activation } -BlMorphicWorldRenderer >> actualScreenSize [ - - ^ self element extent -] - -{ #category : #accessing } -BlMorphicWorldRenderer >> canvas [ - - ^ display getCanvas -] - -{ #category : #accessing } -BlMorphicWorldRenderer >> canvas: aCanvas [ -] - -{ #category : #activation } -BlMorphicWorldRenderer >> deactivate [ -] - -{ #category : #activation } -BlMorphicWorldRenderer >> doActivate [ - - | initialExtent | - initialExtent := world worldState realWindowExtent - ifNil: [ 976@665 ]. - - display := Form extent: initialExtent depth: 32. - world extent: initialExtent. - - world worldState doFullRepaint. - world displayWorld -] - -{ #category : #accessing } -BlMorphicWorldRenderer >> element [ - - ^ element -] - -{ #category : #accessing } -BlMorphicWorldRenderer >> element: aBlElement [ - - element := aBlElement -] - -{ #category : #accessing } -BlMorphicWorldRenderer >> icon: aForm [ -] - -{ #category : #initialization } -BlMorphicWorldRenderer >> initialize [ - - super initialize. - - element := BlElement new -] diff --git a/src/BlocHost-Morphic/BlMorphicWorldState.class.st b/src/BlocHost-Morphic/BlMorphicWorldState.class.st deleted file mode 100644 index 3df44f9b6..000000000 --- a/src/BlocHost-Morphic/BlMorphicWorldState.class.st +++ /dev/null @@ -1,68 +0,0 @@ -Class { - #name : #BlMorphicWorldState, - #superclass : #WorldState, - #instVars : [ - 'element', - 'display' - ], - #category : #'BlocHost-Morphic-World' -} - -{ #category : #accessing } -BlMorphicWorldState >> display [ - - ^ display -] - -{ #category : #accessing } -BlMorphicWorldState >> display: aForm [ - - display := aForm -] - -{ #category : #'update cycle' } -BlMorphicWorldState >> displayWorld: aWorld submorphs: submorphs [ - - element invalidRect: - (BlBounds fromRectangle: (0 @ 0 extent: aWorld extent)) -] - -{ #category : #'update cycle' } -BlMorphicWorldState >> doOneCycleFor: aWorld [ - - self doOneCycleNowFor: aWorld -] - -{ #category : #'update cycle' } -BlMorphicWorldState >> doOneCycleNowFor: aWorld [ - - self element isAttachedToSceneGraph ifFalse: [ ^ self ]. - self element space host universe pulseSynchronously. - 10 milliSeconds wait -] - -{ #category : #accessing } -BlMorphicWorldState >> element [ - - ^ element -] - -{ #category : #accessing } -BlMorphicWorldState >> element: anObject [ - - element := anObject -] - -{ #category : #initialization } -BlMorphicWorldState >> initialize [ - - super initialize. - - self currentCursor: Cursor normal -] - -{ #category : #canvas } -BlMorphicWorldState >> recordDamagedRect: damageRect [ - - element invalidRect: (BlBounds fromRectangle: damageRect) -] diff --git a/src/BlocHost-Morphic/BlSpace.extension.st b/src/BlocHost-Morphic/BlSpace.extension.st index 8ab75f221..ccf84fc37 100644 --- a/src/BlocHost-Morphic/BlSpace.extension.st +++ b/src/BlocHost-Morphic/BlSpace.extension.st @@ -1,11 +1,5 @@ Extension { #name : #BlSpace } -{ #category : #'*BlocHost-Morphic' } -BlSpace >> showNotification: aNotification [ - - self root showNotification: aNotification -] - { #category : #'*BlocHost-Morphic' } BlSpace >> useMorphicHost [