<commit_before>! Copyright (C) 2006, 2010 <NAME>, <NAME>.
! See http://factorcode.org/license.txt for BSD license.
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 )
    first3 swap
    [ sel_registerName ] [ execute( -- xt ) ] [ utf8 string>alien ]
    tri* ;

: throw-if-false ( obj what -- )
    swap { f 0 } member?
    [ "Failed to " prepend throw ] [ drop ] if ;

: add-method ( class sel imp types -- )
    class_addMethod "add method to class" throw-if-false ;

: add-methods ( methods class -- )
    '[ [ _ ] dip init-method add-method ] each ;

: add-protocol ( class protocol -- )
    class_addProtocol "add protocol to class" throw-if-false ;

: add-protocols ( protocols class -- )
    '[ [ _ ] dip objc-protocol add-protocol ] each ;

: (define-objc-class) ( methods protocols superclass name -- )
    [ objc-class ] dip 0 objc_allocateClassPair
    [ add-protocols ] [ add-methods ] [ objc_registerClassPair ]
    tri ;

: encode-type ( type -- encoded )
    dup alien>objc-types get at [ ] [ no-objc-type ] ?if ;

: encode-types ( return types -- encoding )
    swap prefix [ encode-type "0" append ] map concat ;

: prepare-method ( ret types quot -- type imp )
    [ [ encode-types ] 2keep ] dip
    '[ _ _ cdecl _ alien-callback ]
    (( -- callback )) define-temp ;

: prepare-methods ( methods -- methods )
    [
        [ first4 prepare-method 3array ] map
    ] 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* ;
    
: redefine-objc-methods ( methods name -- )
    dup class-exists? [
        objc_getClass '[ [ _ ] dip (redefine-objc-method) ] each
    ] [ 2drop ] if ;

:: define-objc-class ( name superclass protocols methods -- )
    methods prepare-methods :> methods
    name "cocoa.classes" create drop
    methods name redefine-objc-methods
    name [ methods protocols superclass name (define-objc-class) ] import-objc-class ;
<commit_msg>cocoa.subclassing: sometimes, compiled Cocoa method bodies would not be updated when words were redefined. Fixes #66<commit_after>! Copyright (C) 2006, 2010 <NAME>, <NAME>.
! See http://factorcode.org/license.txt for BSD license.
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 )
    first3 swap
    [ sel_registerName ] [ execute( -- xt ) ] [ utf8 string>alien ]
    tri* ;

: throw-if-false ( obj what -- )
    swap { f 0 } member?
    [ "Failed to " prepend throw ] [ drop ] if ;

: add-method ( class sel imp types -- )
    class_addMethod "add method to class" throw-if-false ;

: add-methods ( methods class -- )
    '[ [ _ ] dip init-method add-method ] each ;

: add-protocol ( class protocol -- )
    class_addProtocol "add protocol to class" throw-if-false ;

: add-protocols ( protocols class -- )
    '[ [ _ ] dip objc-protocol add-protocol ] each ;

: (define-objc-class) ( methods protocols superclass name -- )
    [ objc-class ] dip 0 objc_allocateClassPair
    [ add-protocols ] [ add-methods ] [ objc_registerClassPair ]
    tri ;

: encode-type ( type -- encoded )
    dup alien>objc-types get at [ ] [ no-objc-type ] ?if ;

: encode-types ( return types -- encoding )
    swap prefix [ encode-type "0" append ] map concat ;

: prepare-method ( ret types quot -- type imp )
    [ [ encode-types ] 2keep ] dip
    '[ _ _ cdecl _ alien-callback ]
    (( -- callback )) define-temp ;

: prepare-methods ( methods -- methods )
    [
        [ first4 prepare-method 3array ] map
    ] with-nested-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* ;
    
: redefine-objc-methods ( methods name -- )
    dup class-exists? [
        objc_getClass '[ [ _ ] dip (redefine-objc-method) ] each
    ] [ 2drop ] if ;

:: define-objc-class ( name superclass protocols methods -- )
    methods prepare-methods :> methods
    name "cocoa.classes" create drop
    methods name redefine-objc-methods
    name [ methods protocols superclass name (define-objc-class) ] import-objc-class ;

{'fraction_non_alphanumeric': 0.11507293354943274, 'fraction_numerical': 0.007698541329011345, 'mean_word_length': 2.848012470771629, 'pattern_counts': {'":': 0, '<': 7, '<?xml version=': 0, '>': 15, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '2389677', 'n_tokens_mistral': 1561, 'n_tokens_neox': 1507, 'n_words': 439}