cocoa.subclassing: new METHOD: syntax cleans up class definitions
Slava Pestov
parent
bc87b269c5
commit
bb4dae64f3
|
|
@ -7,12 +7,11 @@ IN: cocoa.tests
|
|||
CLASS: {
|
||||
{ +superclass+ "NSObject" }
|
||||
{ +name+ "Foo" }
|
||||
} {
|
||||
"foo:"
|
||||
void
|
||||
{ id SEL NSRect }
|
||||
[ gc "x" set 2drop ]
|
||||
} ;
|
||||
}
|
||||
|
||||
METHOD: void foo: NSRect rect [
|
||||
gc rect "x" set
|
||||
] ;
|
||||
|
||||
: test-foo ( -- )
|
||||
Foo -> alloc -> init
|
||||
|
|
@ -29,12 +28,9 @@ test-foo
|
|||
CLASS: {
|
||||
{ +superclass+ "NSObject" }
|
||||
{ +name+ "Bar" }
|
||||
} {
|
||||
"bar"
|
||||
NSRect
|
||||
{ id SEL }
|
||||
[ 2drop test-foo "x" get ]
|
||||
} ;
|
||||
}
|
||||
|
||||
METHOD: NSRect bar [ test-foo "x" get ] ;
|
||||
|
||||
Bar [
|
||||
-> alloc -> init
|
||||
|
|
@ -51,22 +47,16 @@ Bar [
|
|||
CLASS: {
|
||||
{ +superclass+ "NSObject" }
|
||||
{ +name+ "Bar" }
|
||||
} {
|
||||
"bar"
|
||||
NSRect
|
||||
{ id SEL }
|
||||
[ 2drop test-foo "x" get ]
|
||||
} {
|
||||
"babb"
|
||||
int
|
||||
{ id SEL int }
|
||||
[ 2nip sq ]
|
||||
} ;
|
||||
}
|
||||
|
||||
METHOD: NSRect bar [ test-foo "x" get ]
|
||||
|
||||
METHOD: int babb: int x [ x sq ] ;
|
||||
|
||||
[ 144 ] [
|
||||
Bar [
|
||||
-> alloc -> init
|
||||
dup 12 -> babb
|
||||
dup 12 -> babb:
|
||||
swap -> release
|
||||
] compile-call
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -24,20 +24,31 @@ HELP: define-objc-class
|
|||
{ "the selector naming the message; in most cases this value can be ignored" }
|
||||
"arguments passed to the message, if any"
|
||||
}
|
||||
"There is no way to define instance variables or class methods using this mechanism. However, instance variables can be simulated by using the receiver to key into a hashtable." } ;
|
||||
"There is no way to define instance variables or class methods using this mechanism. However, instance variables can be simulated by using the receiver to key into an assoc." } ;
|
||||
|
||||
HELP: CLASS:
|
||||
{ $syntax "CLASS: spec imeth... ;" }
|
||||
{ $values { "spec" "an array of pairs" } { "name" "a new class name" } { "imeth" "instance method definitions" } }
|
||||
{ $description "A sugared form of the following:"
|
||||
{ $code "{ imeth... } \"spec\" define-objc-class" }
|
||||
{ $values { "spec" "an array of pairs" } { "name" "a new class name" } { "imeth" "instance method definitions using " { $link POSTPONE: METHOD: } } }
|
||||
{ $description "Defines a new Objective C class. The hashtable can contain the following keys:"
|
||||
{ $list
|
||||
{ { $link +name+ } " - a string naming the new class. Required." }
|
||||
{ { $link +superclass+ } " - a string naming the superclass. Required." }
|
||||
{ { $link +protocols+ } " - an array of strings naming protocols implemented by the superclass. Optional." }
|
||||
}
|
||||
"Instance methods are defined with the " { $link POSTPONE: METHOD: } " parsing word."
|
||||
$nl
|
||||
"This word is preferred to calling " { $link define-objc-class } ", because it creates a class word in the " { $vocab-link "cocoa.classes" } " vocabulary at parse time, allowing code to refer to the class word in the same source file where the class is defined." } ;
|
||||
|
||||
{ define-objc-class POSTPONE: CLASS: } related-words
|
||||
{ define-objc-class POSTPONE: CLASS: POSTPONE: METHOD: } related-words
|
||||
|
||||
HELP: METHOD:
|
||||
{ $syntax "METHOD: return foo: type1 arg1 bar: type2 arg2 baz: ... [ body ]" }
|
||||
{ $values { "return" "a C type name" } { "type1" "a C type name" } { "arg1" "a local variable name" } { "body" "arbitrary code" } }
|
||||
{ $description "Defines a method inside of a " { $link POSTPONE: CLASS: } " form." } ;
|
||||
|
||||
ARTICLE: "objc-subclassing" "Subclassing Objective C classes"
|
||||
"Objective C classes can be subclassed, with new methods defined in Factor, using a parsing word:"
|
||||
{ $subsections POSTPONE: CLASS: }
|
||||
"Objective C classes can be subclassed, with new methods defined in Factor, using parsing words:"
|
||||
{ $subsections POSTPONE: CLASS: POSTPONE: METHOD: }
|
||||
"This word is actually syntax sugar for an ordinary word:"
|
||||
{ $subsections define-objc-class }
|
||||
"Objective C class definitions are saved in the image. If the image is saved and Factor is restarted with the saved image, custom class definitions are made available to the Objective C runtime when they are first accessed from within Factor." ;
|
||||
|
|
|
|||
|
|
@ -1,9 +1,11 @@
|
|||
! Copyright (C) 2006, 2008 Slava Pestov, Joe Groff.
|
||||
! Copyright (C) 2006, 2010 Slava Pestov, Joe Groff.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types alien.strings arrays assocs
|
||||
combinators compiler hashtables kernel libc math namespaces
|
||||
parser sequences words cocoa.messages cocoa.runtime locals
|
||||
compiler.units io.encodings.utf8 continuations make fry ;
|
||||
USING: alien alien.c-types alien.parser alien.strings arrays
|
||||
assocs combinators compiler hashtables kernel lexer libc
|
||||
locals.parser locals.types math namespaces parser sequences
|
||||
words cocoa.messages cocoa.runtime locals compiler.units
|
||||
io.encodings.utf8 continuations make fry effects stack-checker
|
||||
stack-checker.errors ;
|
||||
IN: cocoa.subclassing
|
||||
|
||||
: init-method ( method -- sel imp types )
|
||||
|
|
@ -49,13 +51,13 @@ IN: cocoa.subclassing
|
|||
] with-compilation-unit ;
|
||||
|
||||
:: (redefine-objc-method) ( class method -- )
|
||||
method init-method [| sel imp types |
|
||||
class sel class_getInstanceMethod [
|
||||
imp method_setImplementation drop
|
||||
] [
|
||||
class sel imp types add-method
|
||||
] if*
|
||||
] call ;
|
||||
method init-method :> ( sel imp types )
|
||||
|
||||
class sel class_getInstanceMethod [
|
||||
imp method_setImplementation drop
|
||||
] [
|
||||
class sel imp types add-method
|
||||
] if* ;
|
||||
|
||||
: redefine-objc-methods ( imeth name -- )
|
||||
dup class-exists? [
|
||||
|
|
@ -79,3 +81,35 @@ SYMBOL: +superclass+
|
|||
SYNTAX: CLASS:
|
||||
parse-definition unclip
|
||||
>hashtable define-objc-class ;
|
||||
|
||||
: (parse-selector) ( -- )
|
||||
scan-token {
|
||||
{ [ dup "[" = ] [ drop ] }
|
||||
{ [ dup ":" tail? ] [ scan-c-type scan-token 3array , (parse-selector) ] }
|
||||
[ f f 3array , "[" expect ]
|
||||
} cond ;
|
||||
|
||||
: parse-selector ( -- selector types names )
|
||||
[ (parse-selector) ] { } make
|
||||
flip first3
|
||||
[ concat ]
|
||||
[ sift { id SEL } prepend ]
|
||||
[ sift { "self" "selector" } prepend ] tri* ;
|
||||
|
||||
: parse-method-body ( names -- quot )
|
||||
[ [ make-local ] map ] H{ } make-assoc
|
||||
(parse-lambda) <lambda> ?rewrite-closures first ;
|
||||
|
||||
: method-effect ( quadruple -- effect )
|
||||
[ third ] [ second void? { } { "x" } ? ] bi <effect> ;
|
||||
|
||||
: check-method ( quadruple -- )
|
||||
[ fourth infer ] [ method-effect ] bi
|
||||
2dup effect<= [ 2drop ] [ effect-error ] if ;
|
||||
|
||||
SYNTAX: METHOD:
|
||||
scan-c-type
|
||||
parse-selector
|
||||
parse-method-body [ swap ] 2dip 4array
|
||||
dup check-method
|
||||
suffix! ;
|
||||
|
|
|
|||
|
|
@ -13,12 +13,6 @@ IN: tools.deploy.shaker.cocoa
|
|||
|
||||
: pool-values ( assoc -- assoc' ) [ pool-array ] assoc-map ;
|
||||
|
||||
IN: cocoa.application
|
||||
|
||||
: objc-error ( error -- ) die ;
|
||||
|
||||
[ [ die ] 19 set-special-object ] "cocoa.application" add-startup-hook
|
||||
|
||||
H{ } clone \ pool [
|
||||
global [
|
||||
! Only keeps those methods that we actually call
|
||||
|
|
|
|||
|
|
@ -9,16 +9,13 @@ IN: tools.deploy.test.14
|
|||
CLASS: {
|
||||
{ +superclass+ "NSObject" }
|
||||
{ +name+ "Bar" }
|
||||
} {
|
||||
"bar:"
|
||||
float
|
||||
{ id SEL NSRect }
|
||||
[
|
||||
[ origin>> [ x>> ] [ y>> ] bi + ]
|
||||
[ size>> [ w>> ] [ h>> ] bi + ]
|
||||
bi +
|
||||
]
|
||||
} ;
|
||||
}
|
||||
|
||||
METHOD: float bar: NSRect rect [
|
||||
rect origin>> [ x>> ] [ y>> ] bi +
|
||||
rect size>> [ w>> ] [ h>> ] bi +
|
||||
+
|
||||
] ;
|
||||
|
||||
: main ( -- )
|
||||
Bar -> alloc -> init
|
||||
|
|
|
|||
|
|
@ -233,9 +233,7 @@ CLASS: {
|
|||
{ +name+ "FactorApplicationDelegate" }
|
||||
}
|
||||
|
||||
{ "applicationDidUpdate:" void { id SEL id }
|
||||
[ 3drop reset-run-loop ]
|
||||
} ;
|
||||
METHOD: void applicationDidUpdate: id obj [ reset-run-loop ] ;
|
||||
|
||||
: install-app-delegate ( -- )
|
||||
NSApp FactorApplicationDelegate install-delegate ;
|
||||
|
|
|
|||
|
|
@ -26,45 +26,25 @@ CLASS: {
|
|||
{ +name+ "FactorWorkspaceApplicationDelegate" }
|
||||
}
|
||||
|
||||
{ "application:openFiles:" void { id SEL id id }
|
||||
[ [ 3drop ] dip finder-run-files ]
|
||||
}
|
||||
METHOD: void application: id app openFiles: id files [ files finder-run-files ]
|
||||
|
||||
{ "applicationShouldHandleReopen:hasVisibleWindows:" int { id SEL id int }
|
||||
[ [ 3drop ] dip 0 = [ show-listener ] when 1 ]
|
||||
}
|
||||
METHOD: int applicationShouldHandleReopen: id app hasVisibleWindows: int flag [ flag 0 = [ show-listener ] when 1 ]
|
||||
|
||||
{ "factorListener:" id { id SEL id }
|
||||
[ 3drop show-listener f ]
|
||||
}
|
||||
METHOD: id factorListener: id app [ show-listener f ]
|
||||
|
||||
{ "factorBrowser:" id { id SEL id }
|
||||
[ 3drop show-browser f ]
|
||||
}
|
||||
METHOD: id factorBrowser: id app [ show-browser f ]
|
||||
|
||||
{ "newFactorListener:" id { id SEL id }
|
||||
[ 3drop listener-window f ]
|
||||
}
|
||||
METHOD: id newFactorListener: id app [ listener-window f ]
|
||||
|
||||
{ "newFactorBrowser:" id { id SEL id }
|
||||
[ 3drop browser-window f ]
|
||||
}
|
||||
METHOD: id newFactorBrowser: id app [ browser-window f ]
|
||||
|
||||
{ "runFactorFile:" id { id SEL id }
|
||||
[ 3drop menu-run-files f ]
|
||||
}
|
||||
METHOD: id runFactorFile: id app [ menu-run-files f ]
|
||||
|
||||
{ "saveFactorImage:" id { id SEL id }
|
||||
[ 3drop save f ]
|
||||
}
|
||||
METHOD: id saveFactorImage: id app [ save f ]
|
||||
|
||||
{ "saveFactorImageAs:" id { id SEL id }
|
||||
[ 3drop menu-save-image f ]
|
||||
}
|
||||
METHOD: id saveFactorImageAs: id app [ menu-save-image f ]
|
||||
|
||||
{ "refreshAll:" id { id SEL id }
|
||||
[ 3drop [ refresh-all ] \ refresh-all call-listener f ]
|
||||
} ;
|
||||
METHOD: id refreshAll: id app [ [ refresh-all ] \ refresh-all call-listener f ] ;
|
||||
|
||||
: install-app-delegate ( -- )
|
||||
NSApp FactorWorkspaceApplicationDelegate install-delegate ;
|
||||
|
|
@ -78,25 +58,16 @@ CLASS: {
|
|||
CLASS: {
|
||||
{ +superclass+ "NSObject" }
|
||||
{ +name+ "FactorServiceProvider" }
|
||||
} {
|
||||
"evalInListener:userData:error:"
|
||||
void
|
||||
{ id SEL id id id }
|
||||
[
|
||||
nip
|
||||
[ eval-listener f ] do-service
|
||||
2drop
|
||||
]
|
||||
} {
|
||||
"evalToString:userData:error:"
|
||||
void
|
||||
{ id SEL id id id }
|
||||
[
|
||||
nip
|
||||
[ [ (eval>string) ] with-interactive-vocabs ] do-service
|
||||
2drop
|
||||
]
|
||||
} ;
|
||||
}
|
||||
|
||||
METHOD: void evalInListener: id pboard userData: id userData error: id error
|
||||
[ pboard error [ eval-listener f ] do-service ]
|
||||
|
||||
METHOD: void evalToString: id pboard userData: id userData error: id error
|
||||
[
|
||||
pboard error
|
||||
[ [ (eval>string) ] with-interactive-vocabs ] do-service
|
||||
] ;
|
||||
|
||||
: register-services ( -- )
|
||||
NSApp
|
||||
|
|
|
|||
|
|
@ -148,269 +148,168 @@ CLASS: {
|
|||
}
|
||||
|
||||
! Rendering
|
||||
{ "drawRect:" void { id SEL NSRect }
|
||||
[ 2drop window draw-world ]
|
||||
}
|
||||
METHOD: void drawRect: NSRect rect [ self window draw-world ]
|
||||
|
||||
! Events
|
||||
{ "acceptsFirstMouse:" char { id SEL id }
|
||||
[ 3drop 1 ]
|
||||
}
|
||||
METHOD: char acceptsFirstMouse: id event [ 1 ]
|
||||
|
||||
{ "mouseEntered:" void { id SEL id }
|
||||
[ nip send-mouse-moved ]
|
||||
}
|
||||
METHOD: void mouseEntered: id event [ self event send-mouse-moved ]
|
||||
|
||||
{ "mouseExited:" void { id SEL id }
|
||||
[ 3drop forget-rollover ]
|
||||
}
|
||||
METHOD: void mouseExited: id event [ forget-rollover ]
|
||||
|
||||
{ "mouseMoved:" void { id SEL id }
|
||||
[ nip send-mouse-moved ]
|
||||
}
|
||||
METHOD: void mouseMoved: id event [ self event send-mouse-moved ]
|
||||
|
||||
{ "mouseDragged:" void { id SEL id }
|
||||
[ nip send-mouse-moved ]
|
||||
}
|
||||
METHOD: void mouseDragged: id event [ self event send-mouse-moved ]
|
||||
|
||||
{ "rightMouseDragged:" void { id SEL id }
|
||||
[ nip send-mouse-moved ]
|
||||
}
|
||||
METHOD: void rightMouseDragged: id event [ self event send-mouse-moved ]
|
||||
|
||||
{ "otherMouseDragged:" void { id SEL id }
|
||||
[ nip send-mouse-moved ]
|
||||
}
|
||||
METHOD: void otherMouseDragged: id event [ self event send-mouse-moved ]
|
||||
|
||||
{ "mouseDown:" void { id SEL id }
|
||||
[ nip send-button-down$ ]
|
||||
}
|
||||
METHOD: void mouseDown: id event [ self event send-button-down$ ]
|
||||
|
||||
{ "mouseUp:" void { id SEL id }
|
||||
[ nip send-button-up$ ]
|
||||
}
|
||||
METHOD: void mouseUp: id event [ self event send-button-up$ ]
|
||||
|
||||
{ "rightMouseDown:" void { id SEL id }
|
||||
[ nip send-button-down$ ]
|
||||
}
|
||||
METHOD: void rightMouseDown: id event [ self event send-button-down$ ]
|
||||
|
||||
{ "rightMouseUp:" void { id SEL id }
|
||||
[ nip send-button-up$ ]
|
||||
}
|
||||
METHOD: void rightMouseUp: id event [ self event send-button-up$ ]
|
||||
|
||||
{ "otherMouseDown:" void { id SEL id }
|
||||
[ nip send-button-down$ ]
|
||||
}
|
||||
METHOD: void otherMouseDown: id event [ self event send-button-down$ ]
|
||||
|
||||
{ "otherMouseUp:" void { id SEL id }
|
||||
[ nip send-button-up$ ]
|
||||
}
|
||||
METHOD: void otherMouseUp: id event [ self event send-button-up$ ]
|
||||
|
||||
{ "scrollWheel:" void { id SEL id }
|
||||
[ nip send-scroll$ ]
|
||||
}
|
||||
METHOD: void scrollWheel: id event [ self event send-scroll$ ]
|
||||
|
||||
{ "keyDown:" void { id SEL id }
|
||||
[ nip send-key-down-event ]
|
||||
}
|
||||
METHOD: void keyDown: id event [ self event send-key-down-event ]
|
||||
|
||||
{ "keyUp:" void { id SEL id }
|
||||
[ nip send-key-up-event ]
|
||||
}
|
||||
METHOD: void keyUp: id event [ self event send-key-up-event ]
|
||||
|
||||
{ "validateUserInterfaceItem:" char { id SEL id }
|
||||
[
|
||||
nip -> action
|
||||
2dup [ window ] [ utf8 alien>string ] bi* validate-action
|
||||
[ [ 2drop ] dip >c-bool ] [ SUPER-> validateUserInterfaceItem: ] if
|
||||
]
|
||||
}
|
||||
METHOD: char validateUserInterfaceItem: id event
|
||||
[
|
||||
self window
|
||||
event -> action utf8 alien>string validate-action
|
||||
[ >c-bool ] [ drop self event SUPER-> validateUserInterfaceItem: ] if
|
||||
]
|
||||
|
||||
{ "undo:" id { id SEL id }
|
||||
[ nip undo-action send-action$ ]
|
||||
}
|
||||
METHOD: id undo: id event [ self event undo-action send-action$ ]
|
||||
|
||||
{ "redo:" id { id SEL id }
|
||||
[ nip redo-action send-action$ ]
|
||||
}
|
||||
METHOD: id redo: id event [ self event redo-action send-action$ ]
|
||||
|
||||
{ "cut:" id { id SEL id }
|
||||
[ nip cut-action send-action$ ]
|
||||
}
|
||||
METHOD: id cut: id event [ self event cut-action send-action$ ]
|
||||
|
||||
{ "copy:" id { id SEL id }
|
||||
[ nip copy-action send-action$ ]
|
||||
}
|
||||
METHOD: id copy: id event [ self event copy-action send-action$ ]
|
||||
|
||||
{ "paste:" id { id SEL id }
|
||||
[ nip paste-action send-action$ ]
|
||||
}
|
||||
METHOD: id paste: id event [ self event paste-action send-action$ ]
|
||||
|
||||
{ "delete:" id { id SEL id }
|
||||
[ nip delete-action send-action$ ]
|
||||
}
|
||||
METHOD: id delete: id event [ self event delete-action send-action$ ]
|
||||
|
||||
{ "selectAll:" id { id SEL id }
|
||||
[ nip select-all-action send-action$ ]
|
||||
}
|
||||
METHOD: id selectAll: id event [ self event select-all-action send-action$ ]
|
||||
|
||||
{ "newDocument:" id { id SEL id }
|
||||
[ nip new-action send-action$ ]
|
||||
}
|
||||
METHOD: id newDocument: id event [ self event new-action send-action$ ]
|
||||
|
||||
{ "openDocument:" id { id SEL id }
|
||||
[ nip open-action send-action$ ]
|
||||
}
|
||||
METHOD: id openDocument: id event [ self event open-action send-action$ ]
|
||||
|
||||
{ "saveDocument:" id { id SEL id }
|
||||
[ nip save-action send-action$ ]
|
||||
}
|
||||
METHOD: id saveDocument: id event [ self event save-action send-action$ ]
|
||||
|
||||
{ "saveDocumentAs:" id { id SEL id }
|
||||
[ nip save-as-action send-action$ ]
|
||||
}
|
||||
METHOD: id saveDocumentAs: id event [ self event save-as-action send-action$ ]
|
||||
|
||||
{ "revertDocumentToSaved:" id { id SEL id }
|
||||
[ nip revert-action send-action$ ]
|
||||
}
|
||||
METHOD: id revertDocumentToSaved: id event [ self event revert-action send-action$ ]
|
||||
|
||||
! Multi-touch gestures: this is undocumented.
|
||||
! http://cocoadex.com/2008/02/nsevent-modifications-swipe-ro.html
|
||||
{ "magnifyWithEvent:" void { id SEL id }
|
||||
[
|
||||
nip
|
||||
dup -> deltaZ sgn {
|
||||
{ 1 [ zoom-in-action send-action$ ] }
|
||||
{ -1 [ zoom-out-action send-action$ ] }
|
||||
{ 0 [ 2drop ] }
|
||||
} case
|
||||
]
|
||||
}
|
||||
! Multi-touch gestures
|
||||
METHOD: void magnifyWithEvent: id event
|
||||
[
|
||||
self event
|
||||
dup -> deltaZ sgn {
|
||||
{ 1 [ zoom-in-action send-action$ drop ] }
|
||||
{ -1 [ zoom-out-action send-action$ drop ] }
|
||||
{ 0 [ 2drop ] }
|
||||
} case
|
||||
]
|
||||
|
||||
{ "swipeWithEvent:" void { id SEL id }
|
||||
[
|
||||
nip
|
||||
dup -> deltaX sgn {
|
||||
{ 1 [ left-action send-action$ ] }
|
||||
{ -1 [ right-action send-action$ ] }
|
||||
{ 0
|
||||
[
|
||||
dup -> deltaY sgn {
|
||||
{ 1 [ up-action send-action$ ] }
|
||||
{ -1 [ down-action send-action$ ] }
|
||||
{ 0 [ 2drop ] }
|
||||
} case
|
||||
]
|
||||
}
|
||||
} case
|
||||
]
|
||||
}
|
||||
METHOD: void swipeWithEvent: id event
|
||||
[
|
||||
self event
|
||||
dup -> deltaX sgn {
|
||||
{ 1 [ left-action send-action$ drop ] }
|
||||
{ -1 [ right-action send-action$ drop ] }
|
||||
{ 0
|
||||
[
|
||||
dup -> deltaY sgn {
|
||||
{ 1 [ up-action send-action$ drop ] }
|
||||
{ -1 [ down-action send-action$ drop ] }
|
||||
{ 0 [ 2drop ] }
|
||||
} case
|
||||
]
|
||||
}
|
||||
} case
|
||||
]
|
||||
|
||||
{ "acceptsFirstResponder" char { id SEL }
|
||||
[ 2drop 1 ]
|
||||
}
|
||||
METHOD: char acceptsFirstResponder [ 1 ]
|
||||
|
||||
! Services
|
||||
{ "validRequestorForSendType:returnType:" id { id SEL id id }
|
||||
[
|
||||
! We return either self or nil
|
||||
[ over window-focus ] 2dip
|
||||
valid-service? [ drop ] [ 2drop f ] if
|
||||
]
|
||||
}
|
||||
METHOD: id validRequestorForSendType: id sendType returnType: id returnType
|
||||
[
|
||||
! We return either self or nil
|
||||
self window world-focus sendType returnType
|
||||
valid-service? [ self ] [ f ] if
|
||||
]
|
||||
|
||||
{ "writeSelectionToPasteboard:types:" char { id SEL id id }
|
||||
[
|
||||
CF>string-array NSStringPboardType swap member? [
|
||||
[ drop window-focus gadget-selection ] dip over
|
||||
[ set-pasteboard-string 1 ] [ 2drop 0 ] if
|
||||
] [ 3drop 0 ] if
|
||||
]
|
||||
}
|
||||
METHOD: char writeSelectionToPasteboard: id pboard types: id types
|
||||
[
|
||||
NSStringPboardType types CF>string-array member? [
|
||||
self window world-focus gadget-selection
|
||||
[ pboard set-pasteboard-string 1 ] [ 0 ] if*
|
||||
] [ 0 ] if
|
||||
]
|
||||
|
||||
{ "readSelectionFromPasteboard:" char { id SEL id }
|
||||
[
|
||||
pasteboard-string dup [
|
||||
[ drop window ] dip swap user-input 1
|
||||
] [ 3drop 0 ] if
|
||||
]
|
||||
}
|
||||
METHOD: char readSelectionFromPasteboard: id pboard
|
||||
[
|
||||
pboard pasteboard-string
|
||||
[ self window user-input 1 ] [ 0 ] if*
|
||||
]
|
||||
|
||||
! Text input
|
||||
{ "insertText:" void { id SEL id }
|
||||
[ nip CF>string swap window user-input ]
|
||||
}
|
||||
METHOD: void insertText: id text
|
||||
[ text CF>string self window user-input ]
|
||||
|
||||
{ "hasMarkedText" char { id SEL }
|
||||
[ 2drop 0 ]
|
||||
}
|
||||
METHOD: char hasMarkedText [ 0 ]
|
||||
|
||||
{ "markedRange" NSRange { id SEL }
|
||||
[ 2drop 0 0 <NSRange> ]
|
||||
}
|
||||
METHOD: NSRange markedRange [ 0 0 <NSRange> ]
|
||||
|
||||
{ "selectedRange" NSRange { id SEL }
|
||||
[ 2drop 0 0 <NSRange> ]
|
||||
}
|
||||
METHOD: NSRange selectedRange [ 0 0 <NSRange> ]
|
||||
|
||||
{ "setMarkedText:selectedRange:" void { id SEL id NSRange }
|
||||
[ 2drop 2drop ]
|
||||
}
|
||||
METHOD: void setMarkedText: id text selectedRange: NSRange range [ ]
|
||||
|
||||
{ "unmarkText" void { id SEL }
|
||||
[ 2drop ]
|
||||
}
|
||||
METHOD: void unmarkText [ ]
|
||||
|
||||
{ "validAttributesForMarkedText" id { id SEL }
|
||||
[ 2drop NSArray -> array ]
|
||||
}
|
||||
METHOD: id validAttributesForMarkedText [ NSArray -> array ]
|
||||
|
||||
{ "attributedSubstringFromRange:" id { id SEL NSRange }
|
||||
[ 3drop f ]
|
||||
}
|
||||
METHOD: id attributedSubstringFromRange: NSRange range [ f ]
|
||||
|
||||
{ "characterIndexForPoint:" NSUInteger { id SEL NSPoint }
|
||||
[ 3drop 0 ]
|
||||
}
|
||||
METHOD: NSUInteger characterIndexForPoint: NSPoint point [ 0 ]
|
||||
|
||||
{ "firstRectForCharacterRange:" NSRect { id SEL NSRange }
|
||||
[ 3drop 0 0 0 0 <CGRect> ]
|
||||
}
|
||||
METHOD: NSRect firstRectForCharacterRange: NSRange range [ 0 0 0 0 <CGRect> ]
|
||||
|
||||
{ "conversationIdentifier" NSInteger { id SEL }
|
||||
[ drop alien-address ]
|
||||
}
|
||||
METHOD: NSInteger conversationIdentifier [ self alien-address ]
|
||||
|
||||
! Initialization
|
||||
{ "updateFactorGadgetSize:" void { id SEL id }
|
||||
[ 2drop [ window ] [ view-dim ] bi >>dim drop yield ]
|
||||
}
|
||||
METHOD: void updateFactorGadgetSize: id notification
|
||||
[ self view-dim self window dim<< yield ]
|
||||
|
||||
{ "doCommandBySelector:" void { id SEL SEL }
|
||||
[ 3drop ]
|
||||
}
|
||||
METHOD: void doCommandBySelector: SEL selector [ ]
|
||||
|
||||
{ "initWithFrame:pixelFormat:" id { id SEL NSRect id }
|
||||
[
|
||||
[ drop ] 2dip
|
||||
SUPER-> initWithFrame:pixelFormat:
|
||||
dup dup add-resize-observer
|
||||
]
|
||||
}
|
||||
METHOD: id initWithFrame: NSRect frame pixelFormat: id pixelFormat
|
||||
[
|
||||
self frame pixelFormat SUPER-> initWithFrame:pixelFormat:
|
||||
dup dup add-resize-observer
|
||||
]
|
||||
|
||||
{ "isOpaque" char { id SEL }
|
||||
[
|
||||
2drop 0
|
||||
]
|
||||
}
|
||||
METHOD: char isOpaque [ 0 ]
|
||||
|
||||
{ "dealloc" void { id SEL }
|
||||
[
|
||||
drop
|
||||
[ remove-observer ]
|
||||
[ SUPER-> dealloc ]
|
||||
bi
|
||||
]
|
||||
} ;
|
||||
METHOD: void dealloc
|
||||
[
|
||||
self remove-observer
|
||||
self SUPER-> dealloc
|
||||
] ;
|
||||
|
||||
: sync-refresh-to-screen ( GLView -- )
|
||||
-> openGLContext -> CGLContextObj NSOpenGLCPSwapInterval 1 <int>
|
||||
|
|
@ -423,44 +322,37 @@ CLASS: {
|
|||
-> frame CGRect-top-left 2array >>window-loc drop ;
|
||||
|
||||
CLASS: {
|
||||
{ +superclass+ "NSObject" }
|
||||
{ +name+ "FactorWindowDelegate" }
|
||||
{ +superclass+ "NSObject" }
|
||||
}
|
||||
|
||||
{ "windowDidMove:" void { id SEL id }
|
||||
[
|
||||
2nip -> object [ -> contentView window ] keep save-position
|
||||
]
|
||||
}
|
||||
METHOD: void windowDidMove: id notification
|
||||
[
|
||||
notification -> object -> contentView window
|
||||
notification -> object save-position
|
||||
]
|
||||
|
||||
{ "windowDidBecomeKey:" void { id SEL id }
|
||||
[
|
||||
2nip -> object -> contentView window focus-world
|
||||
]
|
||||
}
|
||||
METHOD: void windowDidBecomeKey: id notification
|
||||
[
|
||||
notification -> object -> contentView window
|
||||
focus-world
|
||||
]
|
||||
|
||||
{ "windowDidResignKey:" void { id SEL id }
|
||||
[
|
||||
forget-rollover
|
||||
2nip -> object -> contentView
|
||||
dup -> isInFullScreenMode 0 =
|
||||
[ window [ unfocus-world ] when* ]
|
||||
[ drop ] if
|
||||
]
|
||||
}
|
||||
METHOD: void windowDidResignKey: id notification
|
||||
[
|
||||
forget-rollover
|
||||
notification -> object -> contentView
|
||||
dup -> isInFullScreenMode 0 =
|
||||
[ window [ unfocus-world ] when* ] [ drop ] if
|
||||
]
|
||||
|
||||
{ "windowShouldClose:" char { id SEL id }
|
||||
[
|
||||
3drop 1
|
||||
]
|
||||
}
|
||||
METHOD: char windowShouldClose: id notification [ 1 ]
|
||||
|
||||
{ "windowWillClose:" void { id SEL id }
|
||||
[
|
||||
2nip -> object -> contentView
|
||||
[ window ungraft ] [ unregister-window ] bi
|
||||
]
|
||||
} ;
|
||||
METHOD: void windowWillClose: id notification
|
||||
[
|
||||
notification -> object -> contentView
|
||||
[ window ungraft ] [ unregister-window ] bi
|
||||
] ;
|
||||
|
||||
: install-window-delegate ( window -- )
|
||||
FactorWindowDelegate install-delegate ;
|
||||
|
|
|
|||
|
|
@ -16,8 +16,6 @@ SYMBOL: windows
|
|||
|
||||
: window ( handle -- world ) windows get-global at ;
|
||||
|
||||
: window-focus ( handle -- gadget ) window world-focus ;
|
||||
|
||||
: register-window ( world handle -- )
|
||||
#! Add the new window just below the topmost window. Why?
|
||||
#! So that if the new window doesn't actually receive focus
|
||||
|
|
|
|||
Loading…
Reference in New Issue